added NEWS entry

* Fix #1399: Duplicate binding error with insertUI and nested uiOutput

* Update NEWS.md

.Rbuildignore

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

.travis.yml

@@ -1,4 +1,8 @@
 language: r
+r:
+  - oldrel
+  - release
+  - devel
 sudo: false
 cache: packages
 

DESCRIPTION

@@ -1,8 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.13.1.9002
-Date: 2016-02-17
+Version: 0.14.1.9001
 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",
@@ -83,9 +82,11 @@ Suggests:
     ggplot2
 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'
@@ -95,7 +96,6 @@ Collate:
     'cache.R'
     'diagnose.R'
     'fileupload.R'
-    'stack.R'
     'graph.R'
     'hooks.R'
     'html-deps.R'
@@ -116,10 +116,13 @@ 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'
@@ -130,8 +133,10 @@ Collate:
     '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'

NAMESPACE

@@ -11,6 +11,7 @@ S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
 S3method("[<-",shinyoutput)
 S3method("[[",reactivevalues)
+S3method("[[",session_proxy)
 S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
 S3method("[[<-",shinyoutput)
@@ -37,8 +38,10 @@ export(actionButton)
 export(actionLink)
 export(addResourcePath)
 export(animationOptions)
+export(applyInputHandlers)
 export(as.shiny.appobj)
 export(basicPage)
+export(bookmarkButton)
 export(bootstrapLib)
 export(bootstrapPage)
 export(br)
@@ -46,7 +49,6 @@ export(browserViewer)
 export(brushOpts)
 export(brushedPoints)
 export(callModule)
-export(cancelOutput)
 export(captureStackTraces)
 export(checkboxGroupInput)
 export(checkboxInput)
@@ -66,6 +68,7 @@ export(downloadButton)
 export(downloadHandler)
 export(downloadLink)
 export(em)
+export(enableBookmarking)
 export(eventReactive)
 export(exprToFunction)
 export(extractStackTrace)
@@ -80,7 +83,9 @@ export(flowLayout)
 export(fluidPage)
 export(fluidRow)
 export(formatStackTrace)
+export(freezeReactiveValue)
 export(getDefaultReactiveDomain)
+export(getShinyOption)
 export(h1)
 export(h2)
 export(h3)
@@ -103,12 +108,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)
@@ -120,6 +127,8 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
+export(modalButton)
+export(modalDialog)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
@@ -129,7 +138,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)
@@ -155,7 +171,9 @@ export(reactiveValues)
 export(reactiveValuesToList)
 export(registerInputHandler)
 export(removeInputHandler)
+export(removeModal)
 export(removeNotification)
+export(removeUI)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -165,21 +183,27 @@ 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)
@@ -202,6 +226,7 @@ export(tagAppendChildren)
 export(tagList)
 export(tagSetChildren)
 export(tags)
+export(textAreaInput)
 export(textInput)
 export(textOutput)
 export(titlePanel)
@@ -214,12 +239,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,998 +0,0 @@
-shiny 0.13.1.9001
---------------------------------------------------------------------------------
-
-* Added the ability for the client browser to reconnect to a new session on
-  the server, by setting `session$allowReconnect(TRUE)`. This requires a
-  version of Shiny Server that supports reconnections. (#1074)
-
-* Improved `renderTable()` function to make the tables look prettier and also
-  provide the user with a lot more parameters to customize their tables with.
-
-* Added `updateActionButton()` function, so the user can change an Action Button's
-  (or Link's) label and/or icon. Also check that the icon argument (for both
-  creation and updating of a button) is valid and throw a warning otherwise.
-
-* Fixed #1056: Upgraded Bootstrap to 3.3.6.
-
-* Updated ion.RangeSlider to 2.1.2.
-
-* Fixed #561: DataTables might pop up a warning when the data is updated
-  extremely frequently.
-
-* Fixed #776: In some browsers, plots sometimes flickered when updated.
-
-* When resized, plots are drawn with `replayPlot()`, instead of re-executing
-  all plotting code. This results in faster plot rendering.
-
-* Added `cancelOutput` function, and a `cancelOutput` parameter to `req`. The
-  function causes the currently executing output to cancel its execution, and
-  leave its previous state alone (as opposed to clearing the output). The `req`
-  parameter similarly modifies the behavior of `req`.
-
-* Added code diagnostics: if there is an error parsing ui.R, server.R, app.R,
-  or global.R, Shiny will search the code for missing commas, extra commas,
-  and unmatched braces, parens, and brackets, and will print out messages
-  pointing out those problems.
-
-shiny 0.13.1
---------------------------------------------------------------------------------
-
-* `flexCol` did not work on RStudio for Windows or Linux.
-
-* Fixed RStudio debugger integration.
-
-* BREAKING CHANGE: The long-deprecated ability to pass functions (rather than
-  expressions) to reactive() and observe() has finally been removed.
-
-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

@@ -27,6 +27,12 @@
 #'   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.
 #'
@@ -59,10 +65,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 +81,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 +130,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 +197,8 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     }
   }
 
+  shinyOptions(appDir = appDir)
+
   oldwd <- NULL
   monitorHandle <- NULL
   onStart <- function() {
@@ -199,7 +220,8 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       serverFuncSource = serverFuncSource,
       onStart = onStart,
       onEnd = onEnd,
-      options = options),
+      options = options
+    ),
     class = "shiny.appobj"
   )
 }
@@ -209,13 +231,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 +274,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 +288,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)
     }
   )

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,11 @@ titlePanel <- function(title, windowTitle=title) {
 #'   layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
 #' # Define UI
-#' shinyUI(fluidPage(
+#' ui <- fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -248,8 +300,18 @@ titlePanel <- function(title, windowTitle=title) {
 #'       plotOutput("distPlot")
 #'     )
 #'   )
-#' ))
+#' )
 #'
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
 #' @export
 sidebarLayout <- function(sidebarPanel,
                           mainPanel,
@@ -286,13 +348,18 @@ sidebarLayout <- function(sidebarPanel,
 #' @seealso \code{\link{fluidPage}}, \code{\link{flowLayout}}
 #'
 #' @examples
-#' shinyUI(fluidPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
 #'   verticalLayout(
 #'     a(href="http://example.com/link1", "Link One"),
 #'     a(href="http://example.com/link2", "Link Two"),
 #'     a(href="http://example.com/link3", "Link Three")
 #'   )
-#' ))
+#' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 verticalLayout <- function(..., fluid = TRUE) {
   lapply(list(...), function(row) {
@@ -319,11 +386,16 @@ verticalLayout <- function(..., fluid = TRUE) {
 #' @seealso \code{\link{verticalLayout}}
 #'
 #' @examples
-#' flowLayout(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- flowLayout(
 #'   numericInput("rows", "How many rows?", 5),
 #'   selectInput("letter", "Which letter?", LETTERS),
 #'   sliderInput("value", "What value?", 0, 100, 50)
 #' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 flowLayout <- function(..., cellArgs = list()) {
 
@@ -346,7 +418,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 +440,33 @@ inputPanel <- function(...) {
 #'   of the layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # Server code used for all examples
+#' server <- function(input, output) {
+#'   output$plot1 <- renderPlot(plot(cars))
+#'   output$plot2 <- renderPlot(plot(pressure))
+#'   output$plot3 <- renderPlot(plot(AirPassengers))
+#' }
+#'
 #' # Equal sizing
-#' splitLayout(
+#' ui <- splitLayout(
 #'   plotOutput("plot1"),
 #'   plotOutput("plot2")
 #' )
+#' shinyApp(ui, server)
 #'
 #' # Custom widths
-#' splitLayout(cellWidths = c("25%", "75%"),
+#' ui <- splitLayout(cellWidths = c("25%", "75%"),
 #'   plotOutput("plot1"),
 #'   plotOutput("plot2")
 #' )
+#' shinyApp(ui, server)
 #'
 #' # All cells at 300 pixels wide, with cell padding
 #' # and a border around everything
-#' splitLayout(
+#' ui <- splitLayout(
 #'   style = "border: 1px solid silver;",
 #'   cellWidths = 300,
 #'   cellArgs = list(style = "padding: 6px"),
@@ -391,6 +474,8 @@ inputPanel <- function(...) {
 #'   plotOutput("plot2"),
 #'   plotOutput("plot3")
 #' )
+#' shinyApp(ui, server)
+#' }
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
@@ -460,10 +545,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 +565,6 @@ splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 #' shinyApp(ui, server)
 #'
 #' }
-#' }
 #' @export
 fillRow <- function(..., flex = 1, width = "100%", height = "100%") {
   flexfill(..., direction = "row", flex = flex, width = width, height = height)

R/bootstrap.R

@@ -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) {
 
@@ -61,7 +60,7 @@ bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
 #' @inheritParams bootstrapPage
 #' @export
 bootstrapLib <- function(theme = NULL) {
-  htmlDependency("bootstrap", "3.3.6",
+  htmlDependency("bootstrap", "3.3.7",
     c(
       href = "shared/bootstrap",
       file = system.file("www/shared/bootstrap", package = "shiny")
@@ -153,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) {
@@ -196,7 +194,7 @@ collapseSizes <- function(padding) {
 #'
 #' @examples
 #' # Define UI
-#' shinyUI(pageWithSidebar(
+#' pageWithSidebar(
 #'
 #'   # Application title
 #'   headerPanel("Hello Shiny!"),
@@ -214,8 +212,7 @@ collapseSizes <- function(padding) {
 #'   mainPanel(
 #'     plotOutput("distPlot")
 #'   )
-#' ))
-#'
+#' )
 #' @export
 pageWithSidebar <- function(headerPanel,
                             sidebarPanel,
@@ -242,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
@@ -285,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,
@@ -329,9 +335,12 @@ 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)
 
   # built the container div dynamically to support optional collapsibility
   if (collapsible) {
@@ -421,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", ...)
@@ -525,7 +533,6 @@ mainPanel <- function(..., width = 8) {
 #'       )
 #'    )
 #' )
-#'
 #' @export
 conditionalPanel <- function(condition, ...) {
   div('data-display-if'=condition, ...)
@@ -598,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}}
@@ -621,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
@@ -670,7 +678,7 @@ tabsetPanel <- function(...,
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
 #' @examples
-#' shinyUI(fluidPage(
+#' fluidPage(
 #'
 #'   titlePanel("Application Title"),
 #'
@@ -680,7 +688,7 @@ tabsetPanel <- function(...,
 #'     tabPanel("Second"),
 #'     tabPanel("Third")
 #'   )
-#' ))
+#' )
 #' @export
 navlistPanel <- function(...,
                          id = NULL,
@@ -694,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,
@@ -716,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)
 }
 
 
@@ -1413,12 +1495,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(
@@ -1446,7 +1527,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.6.3", 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/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

@@ -43,7 +43,6 @@ writeReactLog <- function(file=stdout(), sessionToken = NULL) {
 #'
 #' @param time A boolean that specifies whether or not to display the
 #' time that each reactive.
-#'
 #' @export
 showReactLog <- function(time = TRUE) {
   utils::browseURL(renderReactLog(time = as.logical(time)))

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

R/imageutils.R

@@ -25,7 +25,6 @@
 #'   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,29 +11,42 @@
 #'
 #' @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",
+    `data-val` = value,
     list(validateIcon(icon), label),
     ...
   )
@@ -42,9 +55,12 @@ 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",
+    `data-val` = value,
     list(validateIcon(icon), label),
     ...
   )

R/input-checkbox.R

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

R/input-checkboxgroup.R

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

R/input-date.R

@@ -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

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

R/input-file.R

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

R/input-numeric.R

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

R/input-password.R

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

R/input-radiobuttons.R

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

R/input-select.R

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

@@ -48,6 +48,27 @@
 #' @family input elements
 #' @seealso \code{\link{updateSliderInput}}
 #'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("obs", "Number of observations:",
+#'     min = 0, max = 1000, value = 500
+#'   ),
+#'   plotOutput("distPlot")
+#' )
+#'
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
                         round = FALSE, format = NULL, locale = NULL,
@@ -64,6 +85,8 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
+  value <- restoreInput(id = inputId, default = value)
+
   # If step is NULL, use heuristic to set the step size.
   findStepSize <- function(min, max, step) {
     if (!is.null(step)) return(step)
@@ -140,7 +163,6 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-grid` = ticks,
     `data-grid-num` = n_ticks,
     `data-grid-snap` = FALSE,
-    `data-prettify-separator` = sep,
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
@@ -152,6 +174,12 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-timezone` = timezone
   ))
 
+  if (sep == "") {
+    sliderProps$`data-prettify-enabled` <- "0"
+  } else {
+    sliderProps$`data-prettify-separator` <- sep
+  }
+
   # Replace any TRUE and FALSE with "true" and "false"
   sliderProps <- lapply(sliderProps, function(x) {
     if (identical(x, TRUE)) "true"
@@ -221,7 +249,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-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

@@ -4,10 +4,13 @@ controlLabel <- function(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.
+# refers to values. Below is a function for backward compatibility. It also
+# coerces the value to `character`.
 validateSelected <- function(selected, choices, inputId) {
-  # drop names, otherwise toJSON() keeps them too
-  selected <- unname(selected)
+  # this line accomplishes two tings:
+  #   - coerces selected to character
+  #   - drops name, otherwise toJSON() keeps it too
+  selected <- as.character(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)
@@ -48,10 +51,10 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
       # 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(HTML(name)))
       } else {
         tags$div(class = type,
-          tags$label(inputTag, tags$span(name))
+          tags$label(inputTag, tags$span(HTML(name)))
         )
       }
     },
@@ -63,7 +66,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 +82,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

@@ -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

@@ -24,6 +24,7 @@
 #' @return An ID for the notification.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
 #' if (interactive()) {
 #' # Show a message when button is clicked
 #' shinyApp(
@@ -74,7 +75,7 @@ showNotification <- function(ui, action = NULL, duration = 5,
 {
 
   if (is.null(id))
-    id <- randomID()
+    id <- createUniqueId(8)
 
   res <- processDeps(ui, session)
   actionRes <- processDeps(action, session)

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)}}{
@@ -48,6 +56,10 @@
 #' @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 +67,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 +88,9 @@
 #'     }
 #'     plot(cars)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @seealso \code{\link{withProgress}}
 #' @format NULL
@@ -82,18 +101,22 @@ Progress <- R6Class(
   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 <- randomID()
+      private$id <- createUniqueId(8)
       private$min <- min
       private$max <- max
+      private$style <- match.arg(style, choices = c("notification", "old"))
       private$value <- NULL
       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) {
@@ -115,7 +138,8 @@ Progress <- R6Class(
         id = private$id,
         message = message,
         detail = detail,
-        value = value
+        value = value,
+        style = private$style
       ))
 
        private$session$sendProgress('update', data)
@@ -141,7 +165,9 @@ 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
     }
   ),
@@ -151,6 +177,7 @@ Progress <- R6Class(
     id = character(0),
     min = numeric(0),
     max = numeric(0),
+    style = character(0),
     value = NULL,
     closed = logical(0)
   )
@@ -179,6 +206,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 +234,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.
 #'
 #' @examples
-#' \dontrun{
-#' # server.R
-#' shinyServer(function(input, output) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output) {
 #'   output$plot <- renderPlot({
 #'     withProgress(message = 'Calculation in progress',
 #'                  detail = 'This may take a while...', value = 0, {
@@ -217,16 +261,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 +282,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/reactives.R

@@ -47,6 +47,7 @@ ReactiveValues <- R6Class(
     # For debug purposes
     .label = character(0),
     .values = 'environment',
+    .metadata = 'environment',
     .dependents = 'environment',
     # Dependents for the list of all names, including hidden
     .namesDeps = 'Dependents',
@@ -60,32 +61,40 @@ ReactiveValues <- R6Class(
                        p_randomInt(1000, 10000),
                        sep="")
       .values <<- new.env(parent=emptyenv())
+      .metadata <<- new.env(parent=emptyenv())
       .dependents <<- new.env(parent=emptyenv())
       .namesDeps <<- Dependents$new()
       .allValuesDeps <<- Dependents$new()
       .valuesDeps <<- Dependents$new()
     },
+
     get = function(key) {
+      # Register the "downstream" reactive which is accessing this value, so
+      # that we know to invalidate them when this value changes.
       ctx <- .getReactiveEnvironment()$currentContext()
       dep.key <- paste(key, ':', ctx$id, sep='')
-      if (!exists(dep.key, where=.dependents, inherits=FALSE)) {
+      if (!exists(dep.key, envir=.dependents, inherits=FALSE)) {
         .graphDependsOn(ctx$id, sprintf('%s$%s', .label, key))
-        assign(dep.key, ctx, pos=.dependents, inherits=FALSE)
+        .dependents[[dep.key]] <- ctx
         ctx$onInvalidate(function() {
-          rm(list=dep.key, pos=.dependents, inherits=FALSE)
+          rm(list=dep.key, envir=.dependents, inherits=FALSE)
         })
       }
 
-      if (!exists(key, where=.values, inherits=FALSE))
+      if (isFrozen(key))
+        reactiveStop()
+
+      if (!exists(key, envir=.values, inherits=FALSE))
         NULL
       else
-        base::get(key, pos=.values, inherits=FALSE)
+        .values[[key]]
     },
+
     set = function(key, value) {
       hidden <- substr(key, 1, 1) == "."
 
-      if (exists(key, where=.values, inherits=FALSE)) {
-        if (identical(base::get(key, pos=.values, inherits=FALSE), value)) {
+      if (exists(key, envir=.values, inherits=FALSE)) {
+        if (identical(.values[[key]], value)) {
           return(invisible())
         }
       }
@@ -98,14 +107,14 @@ ReactiveValues <- R6Class(
       else
         .valuesDeps$invalidate()
 
-      assign(key, value, pos=.values, inherits=FALSE)
+      .values[[key]] <- value
 
       .graphValueChange(sprintf('names(%s)', .label), ls(.values, all.names=TRUE))
       .graphValueChange(sprintf('%s (all)', .label), as.list(.values))
       .graphValueChange(sprintf('%s$%s', .label, key), value)
 
       dep.keys <- objects(
-        pos=.dependents,
+        envir=.dependents,
         pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
         all.names=TRUE
       )
@@ -118,18 +127,54 @@ ReactiveValues <- R6Class(
       )
       invisible()
     },
+
     mset = function(lst) {
       lapply(base::names(lst),
              function(name) {
                self$set(name, lst[[name]])
              })
     },
+
     names = function() {
       .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                       sprintf('names(%s)', .label))
       .namesDeps$register()
       return(ls(.values, all.names=TRUE))
     },
+
+    # Get a metadata value. Does not trigger reactivity.
+    getMeta = function(key, metaKey) {
+      # Make sure to use named (not numeric) indexing into list.
+      metaKey <- as.character(metaKey)
+      .metadata[[key]][[metaKey]]
+    },
+
+    # Set a metadata value. Does not trigger reactivity.
+    setMeta = function(key, metaKey, value) {
+      # Make sure to use named (not numeric) indexing into list.
+      metaKey <- as.character(metaKey)
+
+      if (!exists(key, envir = .metadata, inherits = FALSE)) {
+        .metadata[[key]] <<- list()
+      }
+
+      .metadata[[key]][[metaKey]] <<- value
+    },
+
+    # Mark a value as frozen If accessed while frozen, a shiny.silent.error will
+    # be thrown.
+    freeze = function(key) {
+      setMeta(key, "frozen", TRUE)
+    },
+
+    thaw = function(key) {
+      setMeta(key, "frozen", NULL)
+    },
+
+    isFrozen = function(key) {
+      isTRUE(getMeta(key, "frozen"))
+    },
+
     toList = function(all.names=FALSE) {
       .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                       sprintf('%s (all)', .label))
@@ -140,6 +185,7 @@ ReactiveValues <- R6Class(
 
       return(as.list(.values, all.names=all.names))
     },
+
     .setLabel = function(label) {
       .label <<- label
     }
@@ -186,7 +232,6 @@ ReactiveValues <- R6Class(
 #'   these objects must be named.
 #'
 #' @seealso \code{\link{isolate}} and \code{\link{is.reactivevalues}}.
-#'
 #' @export
 reactiveValues <- function(...) {
   args <- list(...)
@@ -317,10 +362,25 @@ as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
 #' # isolate() can also be used when calling from outside a reactive context (e.g.
 #' # at the console)
 #' isolate(reactiveValuesToList(values))
-#'
 #' @export
 reactiveValuesToList <- function(x, all.names=FALSE) {
-  .subset2(x, 'impl')$toList(all.names)
+  # Default case
+  res <- .subset2(x, 'impl')$toList(all.names)
+
+  prefix <- .subset2(x, 'ns')("")
+  # Special handling for namespaces
+  if (nzchar(prefix)) {
+    fullNames <- names(res)
+
+    # Filter out items that match namespace
+    fullNames <- fullNames[substring(fullNames, 1, nchar(prefix)) == prefix]
+    res <- res[fullNames]
+
+    # Remove namespace prefix
+    names(res) <- substring(fullNames, nchar(prefix) + 1)
+  }
+
+  res
 }
 
 # This function is needed because str() on a reactivevalues object will call
@@ -334,6 +394,67 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
   utils::str(class(object))
 }
 
+
+#' Freeze a reactive value
+#'
+#' This freezes a reactive value. If the value is accessed while frozen, a
+#' "silent" exception is raised and the operation is stopped. This is the same
+#' thing that happens if \code{req(FALSE)} is called. The value is thawed
+#' (un-frozen; accessing it will no longer raise an exception) when the current
+#' reactive domain is flushed. In a Shiny application, this occurs after all of
+#' the observers are executed.
+#'
+#' @param x A \code{\link{reactiveValues}} object (like \code{input}).
+#' @param name The name of a value in the \code{\link{reactiveValues}} object.
+#'
+#' @seealso \code{\link{req}}
+#' @examples
+#' ## Only run this examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   selectInput("data", "Data Set", c("mtcars", "pressure")),
+#'   checkboxGroupInput("cols", "Columns (select 2)", character(0)),
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observe({
+#'     data <- get(input$data)
+#'     # Sets a flag on input$cols to essentially do req(FALSE) if input$cols
+#'     # is accessed. Without this, an error will momentarily show whenever a
+#'     # new data set is selected.
+#'     freezeReactiveValue(input, "cols")
+#'     updateCheckboxGroupInput(session, "cols", choices = names(data))
+#'   })
+#'
+#'   output$plot <- renderPlot({
+#'     # When a new data set is selected, input$cols will have been invalidated
+#'     # above, and this will essentially do the same as req(FALSE), causing
+#'     # this observer to stop and raise a silent exception.
+#'     cols <- input$cols
+#'     data <- get(input$data)
+#'
+#'     if (length(cols) == 2) {
+#'       plot(data[[ cols[1] ]], data[[ cols[2] ]])
+#'     }
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+freezeReactiveValue <- function(x, name) {
+  domain <- getDefaultReactiveDomain()
+  if (is.null(getDefaultReactiveDomain)) {
+    stop("freezeReactiveValue() must be called when a default reactive domain is active.")
+  }
+
+  domain$freezeValue(x, name)
+  invisible()
+}
+
+
 # Observable ----------------------------------------------------------------
 
 Observable <- R6Class(
@@ -360,7 +481,16 @@ Observable <- R6Class(
              "or more parameters; only functions without parameters can be ",
              "reactive.")
 
-      .func <<- wrapFunctionLabel(func, paste("reactive", label),
+      # This is to make sure that the function labels that show in the profiler
+      # and in stack traces doesn't contain whitespace. See
+      # https://github.com/rstudio/profvis/issues/58
+      if (grepl("\\s", label, perl = TRUE)) {
+        funcLabel <- "<reactive>"
+      } else {
+        funcLabel <- paste0("<reactive:", label, ">")
+      }
+
+      .func <<- wrapFunctionLabel(func, funcLabel,
         ..stacktraceon = ..stacktraceon)
       .label <<- label
       .domain <<- domain
@@ -490,7 +620,6 @@ Observable <- R6Class(
 #' isolate(reactiveB())
 #' isolate(reactiveC())
 #' isolate(reactiveD())
-#'
 #' @export
 reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
                      domain = getDefaultReactiveDomain(),
@@ -553,7 +682,7 @@ srcrefToLabel <- function(srcref, defaultLabel) {
 
 #' @export
 print.reactive <- function(x, ...) {
-  label <- attr(x, "observable")$.label
+  label <- attr(x, "observable", exact = TRUE)$.label
   cat(label, "\n")
 }
 
@@ -564,7 +693,7 @@ is.reactive <- function(x) inherits(x, "reactive")
 # Return the number of times that a reactive expression or observer has been run
 execCount <- function(x) {
   if (is.reactive(x))
-    return(attr(x, "observable")$.execCount)
+    return(attr(x, "observable", exact = TRUE)$.execCount)
   else if (inherits(x, 'Observer'))
     return(x$.execCount)
   else
@@ -582,12 +711,18 @@ Observer <- R6Class(
     .domain = 'ANY',
     .priority = numeric(0),
     .autoDestroy = logical(0),
+    # A function that, when invoked, unsubscribes the autoDestroy
+    # listener (or NULL if autodestroy is disabled for this observer).
+    # We must unsubscribe when this observer is destroyed, or else
+    # the observer cannot be garbage collected until the session ends.
+    .autoDestroyHandle = 'ANY',
     .invalidateCallbacks = list(),
     .execCount = integer(0),
     .onResume = 'function',
     .suspended = logical(0),
     .destroyed = logical(0),
     .prevId = character(0),
+    .ctx = NULL,
 
     initialize = function(observerFunc, label, suspended = FALSE, priority = 0,
                           domain = getDefaultReactiveDomain(),
@@ -602,15 +737,14 @@ registerDebugHook("observerFunc", environment(), label)
             ..stacktraceon..(observerFunc())
           else
             observerFunc(),
-          validation = function(e) {
-            # It's OK for a validation error to cause an observer to stop
-            # running
-          }
+          # It's OK for shiny.silent.error errors to cause an observer to stop running
+          shiny.silent.error = function(e) NULL
+          # validation = function(e) NULL,
+          # shiny.output.cancel = function(e) NULL
         )
       }
       .label <<- label
       .domain <<- domain
-      .autoDestroy <<- autoDestroy
       .priority <<- normalizePriority(priority)
       .execCount <<- 0L
       .suspended <<- suspended
@@ -618,7 +752,9 @@ registerDebugHook("observerFunc", environment(), label)
       .destroyed <<- FALSE
       .prevId <<- ''
 
-      onReactiveDomainEnded(.domain, self$.onDomainEnded)
+      .autoDestroy <<- FALSE
+      .autoDestroyHandle <<- NULL
+      setAutoDestroy(autoDestroy)
 
       # Defer the first running of this until flushReact is called
       .createContext()$invalidate()
@@ -627,7 +763,23 @@ registerDebugHook("observerFunc", environment(), label)
       ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId)
       .prevId <<- ctx$id
 
+      if (!is.null(.ctx)) {
+        # If this happens, something went wrong.
+        warning("Created a new context without invalidating previous context.")
+      }
+      # Store the context explicitly in the Observer object. This is necessary
+      # to make sure that when the observer is destroyed, it also gets
+      # invalidated. Otherwise the upstream reactive (on which the observer
+      # depends) will hold a (indirect) reference to this context until the
+      # reactive is invalidated, which may not happen immediately or at all.
+      # This can lead to a memory leak (#1253).
+      .ctx <<- ctx
+
       ctx$onInvalidate(function() {
+        # Context is invalidated, so we don't need to store a reference to it
+        # anymore.
+        .ctx <<- NULL
+
         lapply(.invalidateCallbacks, function(invalidateCallback) {
           invalidateCallback()
           NULL
@@ -680,11 +832,28 @@ registerDebugHook("observerFunc", environment(), label)
       "Sets whether this observer should be automatically destroyed when its
       domain (if any) ends. If autoDestroy is TRUE and the domain already
       ended, then destroy() is called immediately."
+
+      if (.autoDestroy == autoDestroy) {
+        return(.autoDestroy)
+      }
+
       oldValue <- .autoDestroy
       .autoDestroy <<- autoDestroy
-      if (!is.null(.domain) && .domain$isEnded()) {
-        destroy()
+
+      if (autoDestroy) {
+        if (!.destroyed && !is.null(.domain)) { # Make sure to not try to destroy twice.
+          if (.domain$isEnded()) {
+            destroy()
+          } else {
+            .autoDestroyHandle <<- onReactiveDomainEnded(.domain, .onDomainEnded)
+          }
+        }
+      } else {
+        if (!is.null(.autoDestroyHandle))
+          .autoDestroyHandle()
+        .autoDestroyHandle <<- NULL
       }
+
       invisible(oldValue)
     },
     suspend = function() {
@@ -710,8 +879,21 @@ registerDebugHook("observerFunc", environment(), label)
       "Prevents this observer from ever executing again (even if a flush has
       already been scheduled)."
 
+      # Make sure to not try to destory twice.
+      if (.destroyed)
+        return()
+
       suspend()
       .destroyed <<- TRUE
+
+      if (!is.null(.autoDestroyHandle)) {
+        .autoDestroyHandle()
+      }
+      .autoDestroyHandle <<- NULL
+
+      if (!is.null(.ctx)) {
+        .ctx$invalidate()
+      }
     },
     .onDomainEnded = function() {
       if (isTRUE(.autoDestroy)) {
@@ -740,8 +922,8 @@ registerDebugHook("observerFunc", environment(), label)
 #' soon as their dependencies change, they schedule themselves to re-execute.
 #'
 #' Starting with Shiny 0.10.0, observers are automatically destroyed by default
-#' when the \link[=domains]{domain} that owns them ends (e.g. when a Shiny session
-#' ends).
+#' when the \link[=domains]{domain} that owns them ends (e.g. when a Shiny
+#' session ends).
 #'
 #' @param x An expression (quoted or unquoted). Any return value will be
 #'   ignored.
@@ -752,12 +934,13 @@ registerDebugHook("observerFunc", environment(), label)
 #'   This is useful when you want to use an expression that is stored in a
 #'   variable; to do so, it must be quoted with \code{quote()}.
 #' @param label A label for the observer, useful for debugging.
-#' @param suspended If \code{TRUE}, start the observer in a suspended state.
-#'   If \code{FALSE} (the default), start in a non-suspended state.
+#' @param suspended If \code{TRUE}, start the observer in a suspended state. If
+#'   \code{FALSE} (the default), start in a non-suspended state.
 #' @param priority An integer or numeric that controls the priority with which
-#'   this observer should be executed. An observer with a given priority level
-#'   will always execute sooner than all observers with a lower priority level.
-#'   Positive, negative, and zero values are allowed.
+#'   this observer should be executed. A higher value means higher priority: an
+#'   observer with a higher priority value will execute before all observers
+#'   with lower priority values. Positive, negative, and zero values are
+#'   allowed.
 #' @param domain See \link{domains}.
 #' @param autoDestroy If \code{TRUE} (the default), the observer will be
 #'   automatically destroyed when its domain (if any) ends.
@@ -816,7 +999,6 @@ registerDebugHook("observerFunc", environment(), label)
 #' # In a normal Shiny app, the web client will trigger flush events. If you
 #' # are at the console, you can force a flush with flushReact()
 #' shiny:::flushReact()
-#'
 #' @export
 observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
                     suspended=FALSE, priority=0,
@@ -856,9 +1038,9 @@ observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
 #' }
 #' @export
 makeReactiveBinding <- function(symbol, env = parent.frame()) {
-  if (exists(symbol, where = env, inherits = FALSE)) {
-    initialValue <- get(symbol, pos = env, inherits = FALSE)
-    rm(list = symbol, pos = env, inherits = FALSE)
+  if (exists(symbol, envir = env, inherits = FALSE)) {
+    initialValue <- env[[symbol]]
+    rm(list = symbol, envir = env, inherits = FALSE)
   }
   else
     initialValue <- NULL
@@ -931,8 +1113,15 @@ setAutoflush <- local({
 #' @seealso \code{\link{invalidateLater}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("n", "Number of observations", 2, 1000, 500),
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output) {
 #'
 #'   # Anything that calls autoInvalidate will automatically invalidate
 #'   # every 2 seconds.
@@ -953,11 +1142,12 @@ setAutoflush <- local({
 #'   # input$n changes.
 #'   output$plot <- renderPlot({
 #'     autoInvalidate()
-#'     hist(isolate(input$n))
+#'     hist(rnorm(isolate(input$n)))
 #'   })
-#' })
 #' }
 #'
+#' shinyApp(ui, server)
+#' }
 #' @export
 reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain()) {
   dependents <- Map$new()
@@ -1009,8 +1199,15 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #' @seealso \code{\link{reactiveTimer}} is a slightly less safe alternative.
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("n", "Number of observations", 2, 1000, 500),
+#'   plotOutput("plot")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'
 #'   observe({
 #'     # Re-execute this reactive expression after 1000 milliseconds
@@ -1027,11 +1224,12 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #'   output$plot <- renderPlot({
 #'     # Re-execute this reactive expression after 2000 milliseconds
 #'     invalidateLater(2000)
-#'     hist(isolate(input$n))
+#'     hist(rnorm(isolate(input$n)))
 #'   })
-#' })
 #' }
 #'
+#' shinyApp(ui, server)
+#' }
 #' @export
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
   ctx <- .getReactiveEnvironment()$currentContext()
@@ -1101,16 +1299,13 @@ coerceToFunc <- function(x) {
 #' @seealso \code{\link{reactiveFileReader}}
 #'
 #' @examples
-#' \dontrun{
 #' # Assume the existence of readTimestamp and readValue functions
-#' shinyServer(function(input, output, session) {
+#' function(input, output, session) {
 #'   data <- reactivePoll(1000, session, readTimestamp, readValue)
 #'   output$dataTable <- renderTable({
 #'     data()
 #'   })
-#' })
 #' }
-#'
 #' @export
 reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
   intervalMillis <- coerceToFunc(intervalMillis)
@@ -1170,7 +1365,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' @examples
 #' \dontrun{
 #' # Per-session reactive file reader
-#' shinyServer(function(input, output, session)) {
+#' function(input, output, session) {
 #'   fileData <- reactiveFileReader(1000, session, 'data.csv', read.csv)
 #'
 #'   output$data <- renderTable({
@@ -1182,13 +1377,12 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' # the same reader, so read.csv only gets executed once no matter how many
 #' # user sessions are connected.
 #' fileData <- reactiveFileReader(1000, session, 'data.csv', read.csv)
-#' shinyServer(function(input, output, session)) {
+#' function(input, output, session) {
 #'   output$data <- renderTable({
 #'     fileData()
 #'   })
 #' }
 #' }
-#'
 #' @export
 reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...) {
   filePath <- coerceToFunc(filePath)
@@ -1276,7 +1470,6 @@ reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...)
 #'
 #' # isolate also works if the reactive expression accesses values from the
 #' # input object, like input$x
-#'
 #' @export
 isolate <- function(expr) {
   ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate')
@@ -1298,7 +1491,6 @@ isolate <- function(expr) {
 #' @return The value of \code{expr}.
 #'
 #' @seealso \code{\link{isolate}}
-#'
 #' @export
 maskReactiveContext <- function(expr) {
   .getReactiveEnvironment()$runWith(NULL, function() {
@@ -1425,7 +1617,6 @@ maskReactiveContext <- function(expr) {
 #'   }
 #'   shinyApp(ui=ui, server=server)
 #' }
-#'
 #' @export
 observeEvent <- function(eventExpr, handlerExpr,
   event.env = parent.frame(), event.quoted = FALSE,

R/render-plot.R

@@ -35,18 +35,20 @@
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
 #'   is useful if you want to save an expression in a variable.
-#' @param func A function that generates a plot (deprecated; use \code{expr}
-#'   instead).
 #' @param execOnResize If \code{FALSE} (the default), then when a plot is
 #'   resized, Shiny will \emph{replay} the plot drawing commands with
 #'   \code{\link[grDevices]{replayPlot}()} instead of re-executing \code{expr}.
 #'   This can result in faster plot redrawing, but there may be rare cases where
 #'   it is undesirable. If you encounter problems when resizing a plot, you can
 #'   have Shiny re-execute the code on resize by setting this to \code{TRUE}.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{plotOutput}} when \code{renderPlot} is used in an
+#'   interactive R Markdown document.
 #' @export
 renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
-                       env=parent.frame(), quoted=FALSE, func=NULL,
-                       execOnResize=FALSE) {
+                       env=parent.frame(), quoted=FALSE,
+                       execOnResize=FALSE, outputArgs=list()
+) {
   # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
   # is called
   installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
@@ -131,7 +133,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 
       coordmap <- NULL
       plotFunc <- function() {
-        ..stacktraceon..(replayPlot(plotData$recordedPlot))
+        ..stacktraceon..(grDevices::replayPlot(plotData$recordedPlot))
 
         # Coordmap must be recalculated after replaying plot, because pixel
         # dimensions will have changed.
@@ -161,11 +163,11 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   }
 
 
-  plotObj <- reactive({
+  plotObj <- reactive(label = "plotObj", {
     if (execOnResize) {
-      isolate({ dims <- getDims() })
-    } else {
       dims <- getDims()
+    } else {
+      isolate({ dims <- getDims() })
     }
 
     if (is.null(dims$width) || is.null(dims$height) ||
@@ -183,6 +185,9 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
       success <-FALSE
       tryCatch(
         {
+          # This is necessary to enable displaylist recording
+          grDevices::dev.control(displaylist = "enable")
+
           # Actually perform the plotting
           result <- withVisible(func())
           success <- TRUE
@@ -213,7 +218,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
         })
       }
 
-      recordedPlot <<- recordPlot()
+      recordedPlot <<- grDevices::recordPlot()
 
       if (inherits(plotResult, "ggplot_build_gtable")) {
         coordmap <<- getGgplotCoordmap(plotResult, pixelratio, res)
@@ -258,7 +263,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   outputFunc <- plotOutput
   if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
 
-  markRenderFunction(outputFunc, renderFunc)
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
 }
 
 # The coordmap extraction functions below return something like the examples
@@ -413,23 +418,39 @@ getPrevPlotCoordmap <- function(width, height) {
 
 # Given a ggplot_build_gtable object, return a coordmap for it.
 getGgplotCoordmap <- function(p, pixelratio, res) {
+  # Structure of ggplot objects changed after 2.1.0
+  new_ggplot <- (utils::packageVersion("ggplot2") > "2.1.0")
+
   if (!inherits(p, "ggplot_build_gtable"))
     return(NULL)
 
   # Given a built ggplot object, return x and y domains (data space coords) for
   # each panel.
   find_panel_info <- function(b) {
-    layout <- b$panel$layout
+    if (new_ggplot) {
+      layout <- b$layout$panel_layout
+    } else {
+      layout <- b$panel$layout
+    }
     # Convert factor to numbers
     layout$PANEL <- as.integer(as.character(layout$PANEL))
 
     # Names of facets
-    facet <- b$plot$facet
     facet_vars <- NULL
-    if (inherits(facet, "grid")) {
-      facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
-    } else if (inherits(facet, "wrap")) {
-      facet_vars <- vapply(facet$facets, as.character, character(1))
+    if (new_ggplot) {
+      facet <- b$layout$facet
+      if (inherits(facet, "FacetGrid")) {
+        facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
+      } else if (inherits(facet, "FacetWrap")) {
+        facet_vars <- vapply(facet$params$facets, as.character, character(1))
+      }
+    } else {
+      facet <- b$plot$facet
+      if (inherits(facet, "grid")) {
+        facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
+      } else if (inherits(facet, "wrap")) {
+        facet_vars <- vapply(facet$facets, as.character, character(1))
+      }
     }
 
     # Iterate over each row in the layout data frame
@@ -471,7 +492,11 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
   # Given a single range object (representing the data domain) from a built
   # ggplot object, return the domain.
   find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
-    range <- b$panel$ranges[[panel_num]]
+    if (new_ggplot) {
+      range <- b$layout$panel_ranges[[panel_num]]
+    } else {
+      range <- b$panel$ranges[[panel_num]]
+    }
     domain <- list(
       left   = range$x.range[1],
       right  = range$x.range[2],
@@ -480,9 +505,13 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     )
 
     # Check for reversed scales
-    xscale <- b$panel$x_scales[[scalex_num]]
-    yscale <- b$panel$y_scales[[scaley_num]]
-
+    if (new_ggplot) {
+      xscale <- b$layout$panel_scales$x[[scalex_num]]
+      yscale <- b$layout$panel_scales$y[[scaley_num]]
+    } else {
+      xscale <- b$panel$x_scales[[scalex_num]]
+      yscale <- b$panel$y_scales[[scaley_num]]
+    }
     if (!is.null(xscale$trans) && xscale$trans$name == "reverse") {
       domain$left  <- -domain$left
       domain$right <- -domain$right
@@ -517,10 +546,18 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     y_names <- character(0)
 
     # Continuous scales have a trans; discrete ones don't
-    if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
-      x_names <- b$panel$x_scales[[scalex_num]]$trans$name
-    if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
-      y_names <- b$panel$y_scales[[scaley_num]]$trans$name
+    if (new_ggplot) {
+      if (!is.null(b$layout$panel_scales$x[[scalex_num]]$trans))
+        x_names <- b$layout$panel_scales$x[[scalex_num]]$trans$name
+      if (!is.null(b$layout$panel_scales$y[[scaley_num]]$trans))
+        y_names <- b$layout$panel_scales$y[[scaley_num]]$trans$name
+
+    } else {
+      if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
+        x_names <- b$panel$x_scales[[scalex_num]]$trans$name
+      if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
+        y_names <- b$panel$y_scales[[scaley_num]]$trans$name
+    }
 
     coords <- b$plot$coordinates
     if (!is.null(coords$trans)) {
@@ -574,6 +611,11 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
       )
     }
 
+    # Look for CoordFlip
+    if (inherits(b$plot$coordinates, "CoordFlip")) {
+      mappings[c("x", "y")] <- mappings[c("y", "x")]
+    }
+
     mappings_cache <<- mappings
     mappings
   }
@@ -605,7 +647,7 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     # res setting of the device. If res=72, then it returns 400 (as expected),
     # but if, e.g., res=96, it will return 300, which is incorrect.
     devScaleFactor <- 1
-    if (grepl("quartz", names(dev.cur()), fixed = TRUE)) {
+    if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
       devScaleFactor <- res / 72
     }
 

R/render-table.R

@@ -43,21 +43,18 @@
 #' @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 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, 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, func = NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg = "renderTable: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+                        env = parent.frame(), quoted = FALSE,
+                        outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
   if (!is.function(spacing)) spacing <- match.arg(spacing)
 
@@ -82,8 +79,9 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
   digitsWrapper <- createWrapper(digits)
   naWrapper <- createWrapper(na)
 
-  # Main render function
-  markRenderFunction(tableOutput, function() {
+  dots <- list(...)  ## used later (but defined here because of scoping)
+
+  renderFunc <- function(shinysession, name, ...) {
     striped <- stripedWrapper()
     hover <- hoverWrapper()
     bordered <- borderedWrapper()
@@ -116,7 +114,6 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
       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)]
@@ -133,7 +130,7 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
       cols <- paste(vapply(data, defaultAlignment, character(1)), collapse = "")
       cols <- paste0(names, cols)
     } else {
-    ## Case 2: user-specified alignment
+      ## 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) {
@@ -159,15 +156,30 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
 
     # Set up print args
     print_args <- list(
-      xtable_res,
+      x = xtable_res,
       type = 'html',
-      include.rownames = rownames,
-      include.colnames = colnames,
-      NA.string = na,
-      html.table.attributes = paste0("class = '", htmlEscape(classNames, TRUE), "' ",
-                                     "style = 'width:", validateCssUnit(width), ";'"))
+      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), ";'"))
 
     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
@@ -204,5 +216,8 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
       }
     }
     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,72 @@ removeInputHandler <- function(type){
   inputHandlers$remove(type)
 }
 
+
+# Apply input handler to a single input value
+applyInputHandler <- function(name, val) {
+  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.
+#'
+#' @seealso registerInputHandler
+#'
+#' @examples
+#' applyInputHandlers(list(
+#'   "m1" = list(list(1, 2), list(3, 4)),
+#'   "m2:shiny.matrix" = list(list(1, 2), list(3, 4)),
+#'
+#'   "d1" = "2016-01-01",
+#'   "d2:shiny.date" = "2016-01-01",  # Date object
+#'
+#'   "n1" = NULL,
+#'   "n2:shiny.number" = NULL  # Converts to NA
+#' ))
+#' @export
+applyInputHandlers <- function(inputs) {
+  inputs <- mapply(applyInputHandler, names(inputs), inputs, 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 +155,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 +189,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

@@ -49,7 +49,6 @@ registerClient <- function(client) {
 #'
 #' @examples
 #' addResourcePath('datasets', system.file('data', package='datasets'))
-#'
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
@@ -141,7 +140,6 @@ resourcePathHandler <- function(req) {
 #'   })
 #' }
 #' }
-#'
 #' @export
 shinyServer <- function(func) {
   .globals$server <- list(func)
@@ -232,121 +230,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()
           })
         })
       }
@@ -447,6 +429,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 +448,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
@@ -565,17 +550,23 @@ runApp <- function(appDir=getwd(),
     handlerManager$clear()
   }, add = TRUE)
 
+  # Enable per-app Shiny options
+  oldOptionSet <- .globals$options
+  on.exit({
+    .globals$options <- oldOptionSet
+  },add = TRUE)
 
   if (is.null(host) || is.na(host))
     host <- '0.0.0.0'
 
   # 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)
 
   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
@@ -607,21 +598,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 +650,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
@@ -656,6 +671,12 @@ 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))
@@ -718,7 +739,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 +857,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 +952,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/shiny.R

@@ -53,10 +53,10 @@ NULL
 #'
 #'     You can customize the file patterns Shiny will monitor by setting the
 #'     shiny.autoreload.pattern option. For example, to monitor only ui.R:
-#'     \code{option(shiny.autoreload.pattern = glob2rx("ui.R"))}
+#'     \code{options(shiny.autoreload.pattern = glob2rx("ui.R"))}
 #'
 #'     The default polling interval is 500 milliseconds. You can change this
-#'     by setting e.g. \code{option(shiny.autoreload.interval = 2000)} (every
+#'     by setting e.g. \code{options(shiny.autoreload.interval = 2000)} (every
 #'     two seconds).}
 #'   \item{shiny.reactlog}{If \code{TRUE}, enable logging of reactive events,
 #'     which can be viewed later with the \code{\link{showReactLog}} function.
@@ -96,6 +96,14 @@ NULL
 #'     an arguably more intuitive arrangement for casual R users, as the name
 #'     of a function appears next to the srcref where it is defined, rather than
 #'     where it is currently being called from.}
+#'   \item{shiny.sanitize.errors}{If \code{TRUE}, then normal errors (i.e.
+#'     errors not wrapped in \code{safeError}) won't show up in the app; a simple
+#'     generic error message is printed instead (the error and strack trace printed
+#'     to the console remain unchanged). The default is \code{FALSE} (unsanitized
+#'     errors).If you want to sanitize errors in general, but you DO want a
+#'     particular error \code{e} to get displayed to the user, then set this option
+#'     to \code{TRUE} and use \code{stop(safeError(e))} for errors you want the
+#'     user to see.}
 #' }
 #' @name shiny-options
 NULL
@@ -115,10 +123,14 @@ createUniqueId <- function(bytes, prefix = "", suffix = "") {
 toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
   auto_unbox = TRUE, digits = getOption("shiny.json.digits", 16),
   use_signif = TRUE, force = TRUE, POSIXt = "ISO8601", UTC = TRUE,
-  rownames = FALSE, keep_vec_names = TRUE) {
+  rownames = FALSE, keep_vec_names = TRUE, strict_atomic = TRUE) {
+
+  if (strict_atomic) {
+    x <- I(x)
+  }
 
   # I(x) is so that length-1 atomic vectors get put in [].
-  jsonlite::toJSON(I(x), dataframe = dataframe, null = null, na = na,
+  jsonlite::toJSON(x, dataframe = dataframe, null = null, na = na,
    auto_unbox = auto_unbox, digits = digits, use_signif = use_signif,
    force = force, POSIXt = POSIXt, UTC = UTC, rownames = rownames,
    keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...)
@@ -160,6 +172,18 @@ workerId <- local({
 #' example, \code{session$clientData$url_search}).
 #'
 #' @return
+#' \item{allowReconnect(value)}{
+#'   If \code{value} is \code{TRUE} and run in a hosting environment (Shiny
+#'   Server or Connect) with reconnections enabled,  then when the session ends
+#'   due to the network connection closing, the client will attempt to
+#'   reconnect to the server. If a reconnection is successful, the browser will
+#'   send all the current input values to the new session on the server, and
+#'   the server will recalculate any outputs and send them back to the client.
+#'   If \code{value} is \code{FALSE}, reconnections will be disabled (this is
+#'   the default state). If \code{"force"}, then the client browser will always
+#'   attempt to reconnect. The only reason to use \code{"force"} is for testing
+#'   on a local connection (without Shiny Server or Connect).
+#' }
 #' \item{clientData}{
 #'   A \code{\link{reactiveValues}} object that contains information about the client.
 #'   \itemize{
@@ -194,6 +218,11 @@ workerId <- local({
 #' \item{isClosed()}{A function that returns \code{TRUE} if the client has
 #'   disconnected.
 #' }
+#' \item{ns(id)}{
+#'   Server-side version of \code{ns <- \link{NS}(id)}. If bare IDs need to be
+#'   explicitly namespaced for the current module, \code{session$ns("name")}
+#'   will return the fully-qualified ID.
+#' }
 #' \item{onEnded(callback)}{
 #'   Synonym for \code{onSessionEnded}.
 #' }
@@ -241,17 +270,9 @@ workerId <- local({
 #'   This is the request that was used to initiate the websocket connection
 #'   (as opposed to the request that downloaded the web page for the app).
 #' }
-#' \item{allowReconnect(value)}{
-#'   If \code{value} is \code{TRUE} and run in a hosting environment (Shiny
-#'   Server or Connect) with reconnections enabled,  then when the session ends
-#'   due to the network connection closing, the client will attempt to
-#'   reconnect to the server. If a reconnection is successful, the browser will
-#'   send all the current input values to the new session on the server, and
-#'   the server will recalculate any outputs and send them back to the client.
-#'   If \code{value} is \code{FALSE}, reconnections will be disabled (this is
-#'   the default state). If \code{"force"}, then the client browser will always
-#'   attempt to reconnect. The only reason to use \code{"force"} is for testing
-#'   on a local connection (without Shiny Server or Connect).
+#' \item{resetBrush(brushId)}{
+#'   Resets/clears the brush with the given \code{brushId}, if it exists on
+#'   any \code{imageOutput} or \code{plotOutput} in the app.
 #' }
 #' \item{sendCustomMessage(type, message)}{
 #'   Sends a custom message to the web page. \code{type} must be a
@@ -265,6 +286,12 @@ workerId <- local({
 #'   \code{addCustomMessageHandler} will be invoked each time
 #'   \code{sendCustomMessage} is called on the server.
 #' }
+#' \item{sendBinaryMessage(type, message)}{
+#'   Similar to \code{sendCustomMessage}, but the message must be a raw vector
+#'   and the registration method on the client is
+#'   \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The
+#'   message argument on the client will be a \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
+#' }
 #' \item{sendInputMessage(inputId, message)}{
 #'   Sends a message to an input on the session's client web page; if the input
 #'   is present and bound on the page at the time the message is received, then
@@ -273,10 +300,28 @@ workerId <- local({
 #'   from Shiny apps, but through friendlier wrapper functions like
 #'   \code{\link{updateTextInput}}.
 #' }
-#' \item{ns(id)}{
-#'   Server-side version of \code{ns <- \link{NS}(id)}. If bare IDs need to be
-#'   explicitly namespaced for the current module, \code{session$ns("name")}
-#'   will return the fully-qualified ID.
+#' \item{setBookmarkExclude(names)}{
+#'   Set input names to be excluded from bookmarking.
+#' }
+#' \item{getBookmarkExclude()}{
+#'   Returns the set of input names to be excluded from bookmarking.
+#' }
+#' \item{onBookmark(fun)}{
+#'   Registers a function that will be called just before bookmarking state.
+#' }
+#' \item{onBookmarked(fun)}{
+#'   Registers a function that will be called just after bookmarking state.
+#' }
+#' \item{onRestore(fun)}{
+#'   Registers a function that will be called when a session is restored, before
+#'   all other reactives, observers, and render functions are run.
+#' }
+#' \item{onRestored(fun)}{
+#'   Registers a function that will be called when a session is restored, after
+#'   all other reactives, observers, and render functions are run.
+#' }
+#' \item{doBookmark()}{
+#'   Do bookmarking and invoke the onBookmark and onBookmarked callback functions.
 #' }
 #'
 #' @name session
@@ -304,7 +349,6 @@ NULL
 #' @return If \code{id} is missing, returns a function that expects an id string
 #'   as its only argument and returns that id with the namespace prepended.
 #' @seealso \url{http://shiny.rstudio.com/articles/modules.html}
-#'
 #' @export
 NS <- function(namespace, id = NULL) {
   if (missing(id)) {
@@ -320,6 +364,7 @@ NS <- function(namespace, id = NULL) {
 #' @export
 ns.sep <- "-"
 
+
 #' @include utils.R
 ShinySession <- R6Class(
   'ShinySession',
@@ -333,7 +378,7 @@ ShinySession <- R6Class(
     .outputs = list(),          # Keeps track of all the output observer objects
     .outputOptions = list(),     # Options for each of the output observer objects
     progressKeys = 'character',
-    showcase   = 'ANY',
+    showcase   = FALSE,
     fileUploadContext = 'FileUploadContext',
     .input      = 'ANY', # Internal ReactiveValues object for normal input sent from client
     .clientData = 'ANY', # Internal ReactiveValues object for other data sent from the client
@@ -342,6 +387,12 @@ ShinySession <- R6Class(
     flushCallbacks = 'Callbacks',
     flushedCallbacks = 'Callbacks',
     inputReceivedCallbacks = 'Callbacks',
+    bookmarkCallbacks = 'Callbacks',
+    bookmarkedCallbacks = 'Callbacks',
+    restoreCallbacks = 'Callbacks',
+    restoredCallbacks = 'Callbacks',
+    bookmarkExclude = character(0),  # Names of inputs to exclude from bookmarking
+
     sendResponse = function(requestMsg, value) {
       if (is.null(requestMsg$tag)) {
         warning("Tried to send response for untagged message; method: ",
@@ -408,9 +459,99 @@ ShinySession <- R6Class(
 
       # Clear file upload directories, if present
       self$onSessionEnded(private$fileUploadContext$rmUploadDirs)
+    },
+
+    createBookmarkObservers = function() {
+      # This is to be called from the initialization. It registers observers
+      # for bookmarking to work.
+
+      # Get bookmarking config
+      store <- getShinyOption("bookmarkStore", default = "disable")
+      if (store == "disable")
+        return()
+
+      # Warn if trying to enable save-to-server bookmarking on a version of SS,
+      # SSP, or Connect that doesn't support it.
+      if (store == "server" && inShinyServer() &&
+          is.null(getShinyOption("save.interface")))
+      {
+        showNotification(
+          "This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.",
+          duration = NULL, type = "warning", session = self
+        )
+        return()
+      }
+
+      withReactiveDomain(self, {
+        # This observer fires when the bookmark button is clicked.
+        observeEvent(self$input[["._bookmark_"]], {
+          self$doBookmark()
+        })
+
+        # If there was an error initializing the current restore context, show
+        # notification in the client.
+        observe({
+          rc <- getCurrentRestoreContext()
+          if (!is.null(rc$initErrorMessage)) {
+            showNotification(
+              paste("Error in RestoreContext initialization:", rc$initErrorMessage),
+              duration = NULL, type = "error"
+            )
+          }
+        })
+
+        # Run the onRestore function at the beginning of the flush cycle, but after
+        # the server function has been executed.
+        observe({
+          if (private$restoreCallbacks$count() > 0) {
+            tryCatch(
+              withLogErrors(
+                isolate({
+                  rc <- getCurrentRestoreContext()
+                  if (rc$active) {
+                    restoreState <- getCurrentRestoreContext()$asList()
+                    private$restoreCallbacks$invoke(restoreState)
+                  }
+                })
+              ),
+              error = function(e) {
+                showNotification(
+                  paste0("Error calling onRestore callback: ", e$message),
+                  duration = NULL, type = "error"
+                )
+              }
+            )
+          }
+        }, priority = 1000000)
+
+        # Run the onRestored function after the flush cycle completes and information
+        # is sent to the client.
+        self$onFlushed(function() {
+          if (private$restoredCallbacks$count() > 0) {
+
+            tryCatch(
+              withLogErrors(
+                isolate({
+                  rc <- getCurrentRestoreContext()
+                  if (rc$active) {
+                    restoreState <- getCurrentRestoreContext()$asList()
+                    private$restoredCallbacks$invoke(restoreState)
+                  }
+                })
+              ),
+              error = function(e) {
+                msg <- paste0("Error calling onRestored callback: ", e$message)
+                showNotification(msg, duration = NULL, type = "error")
+              }
+            )
+          }
+        })
+
+      }) # withReactiveDomain
     }
   ),
   public = list(
+    restoreContext = NULL,
     progressStack = 'Stack', # Stack of progress objects
     input       = 'reactivevalues', # Externally-usable S3 wrapper object for .input
     output      = 'ANY',    # Externally-usable S3 wrapper object for .outputs
@@ -453,6 +594,12 @@ ShinySession <- R6Class(
       private$.outputs <- list()
       private$.outputOptions <- list()
 
+      private$bookmarkCallbacks <- Callbacks$new()
+      private$bookmarkedCallbacks <- Callbacks$new()
+      private$restoreCallbacks <- Callbacks$new()
+      private$restoredCallbacks <- Callbacks$new()
+      private$createBookmarkObservers()
+
       private$registerSessionEndCallbacks()
 
       if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
@@ -475,10 +622,20 @@ ShinySession <- R6Class(
         )
       )
     },
+    rootScope = function() {
+      self
+    },
     makeScope = function(namespace) {
       ns <- NS(namespace)
 
-      createSessionProxy(self,
+      # Private items for this scope. Can't be part of the scope object because
+      # `$<-.session_proxy` doesn't allow assignment on overidden names.
+      bookmarkCallbacks <- Callbacks$new()
+      restoreCallbacks  <- Callbacks$new()
+      restoredCallbacks <- Callbacks$new()
+      bookmarkExclude   <- character(0)
+
+      scope <- createSessionProxy(self,
         input = .createReactiveValues(private$.input, readonly = TRUE, ns = ns),
         output = .createOutputWriter(self, ns = ns),
         sendInputMessage = function(inputId, message) {
@@ -490,12 +647,157 @@ ShinySession <- R6Class(
         ns = ns,
         makeScope = function(namespace) {
           self$makeScope(ns(namespace))
+        },
+
+        setBookmarkExclude = function(names) {
+          bookmarkExclude <<- names
+        },
+        getBookmarkExclude = function() {
+          bookmarkExclude
+        },
+        onBookmark = function(fun) {
+          if (!is.function(fun) || length(fun) != 1) {
+            stop("`fun` must be a function that takes one argument")
+          }
+          bookmarkCallbacks$register(fun)
+        },
+        onBookmarked = function(fun) {
+          stop("onBookmarked() can't be used in a module.")
+        },
+        onRestore = function(fun) {
+          if (!is.function(fun) || length(fun) != 1) {
+            stop("`fun` must be a function that takes one argument")
+          }
+          restoreCallbacks$register(fun)
+        },
+        onRestored = function(fun) {
+          if (!is.function(fun) || length(fun) != 1) {
+            stop("`fun` must be a function that takes one argument")
+          }
+          restoredCallbacks$register(fun)
         }
       )
+
+      # Given a char vector, return a logical vector indicating which of those
+      # strings are names of things in the namespace.
+      filterNamespace <- function(x) {
+        nsString <- paste0(namespace, ns.sep)
+        substr(x, 1, nchar(nsString)) == nsString
+      }
+
+      # Given a char vector of namespaced names, return a char vector of corresponding
+      # names with namespace prefix removed.
+      unNamespace <- function(x) {
+        if (!all(filterNamespace(x))) {
+          stop("x contains strings(s) that do not have namespace prefix ", namespace)
+        }
+
+        nsString <- paste0(namespace, ns.sep)
+        substring(x, nchar(nsString) + 1)
+      }
+
+      # Given a restore state object (a list), return a modified version that's
+      # scoped to this namespace.
+      scopeRestoreState <- function(state) {
+        # State is a list. We need to copy and transform some things for the
+        # scope.
+        scopeState <- state
+        # `values` is an environment and we don't want to modify the original.
+        scopeState$values <- new.env(parent = emptyenv())
+
+        # Keep only inputs that are in the scope, and rename them
+        scopeState$input <- scopeState$input[filterNamespace(names(scopeState$input))]
+        names(scopeState$input) <- unNamespace(names(scopeState$input))
+
+        # Same for values. This is an environment so we have to handle a little
+        # differently.
+        origNames <- names(state$values)
+        origNames <- origNames[filterNamespace(origNames)]
+        lapply(origNames, function(origName) {
+          scopedName <- unNamespace(origName)
+          scopeState$values[[scopedName]] <- state$values[[origName]]
+        })
+
+        if (!is.null(state$dir)) {
+          dir <- file.path(state$dir, namespace)
+          if (dirExists(dir))
+            scopeState$dir <- dir
+        }
+
+        scopeState
+      }
+
+      # When scope is created, register these bookmarking callbacks on the main
+      # session object. They will invoke the scope's own callbacks, if any are
+      # present.
+      self$onBookmark(function(state) {
+        # Exit if no user-defined callbacks.
+        if (bookmarkCallbacks$count() == 0)
+          return()
+
+        scopeState <- ShinySaveState$new(scope$input, scope$getBookmarkExclude())
+
+        # Create subdir for this scope
+        if (!is.null(state$dir)) {
+          scopeState$dir <- file.path(state$dir, namespace)
+          res <- dir.create(scopeState$dir)
+          if (res == FALSE) {
+            stop("Error creating subdirectory for scope ", namespace)
+          }
+        }
+
+        # Invoke the callback on the scopeState object
+        bookmarkCallbacks$invoke(scopeState)
+
+        # Copy `values` from scopeState to state, adding namespace
+        if (length(scopeState$values) != 0) {
+          if (anyUnnamed(scopeState$values)) {
+            stop("All scope values in must be named.")
+          }
+
+          lapply(names(scopeState$values), function(origName) {
+            scopedName <- ns(origName)
+            state$values[[scopedName]] <- scopeState$values[[origName]]
+          })
+        }
+      })
+
+      self$onRestore(function(state) {
+        # Exit if no user-defined callbacks.
+        if (restoreCallbacks$count() == 0)
+          return()
+
+        scopeState <- scopeRestoreState(state)
+        # Invoke user callbacks
+        restoreCallbacks$invoke(scopeState)
+      })
+
+      self$onRestored(function(state) {
+        # Exit if no user-defined callbacks.
+        if (restoredCallbacks$count() == 0)
+          return()
+
+        scopeState <- scopeRestoreState(state)
+        # Invoke user callbacks
+        restoredCallbacks$invoke(scopeState)
+      })
+
+      scope
     },
     ns = function(id) {
       NS(NULL, id)
     },
+
+    # Freeze a value until the flush cycle completes
+    freezeValue = function(x, name) {
+      if (!is.reactivevalues(x))
+        stop("x must be a reactivevalues object")
+
+      impl <- .subset2(x, 'impl')
+      impl$freeze(name)
+      self$onFlushed(function() impl$thaw(name))
+    },
+
     onSessionEnded = function(sessionEndedCallback) {
       "Registers the given callback to be invoked when the session is closed
       (i.e. the connection to the client has been severed). The return value
@@ -528,10 +830,7 @@ ShinySession <- R6Class(
       # ..stacktraceon matches with the top-level ..stacktraceoff..
       private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
       flushReact()
-      lapply(appsByToken$values(), function(shinysession) {
-        shinysession$flushOutput()
-        NULL
-      })
+      flushAllSessions()
     },
     isClosed = function() {
       return(self$closed)
@@ -593,6 +892,10 @@ ShinySession <- R6Class(
 
           value <- tryCatch(
             shinyCallingHandlers(func()),
+            shiny.custom.error = function(cond) {
+              if (isTRUE(getOption("show.error.messages"))) printError(cond)
+              structure(NULL, class = "try-error", condition = cond)
+            },
             shiny.output.cancel = function(cond) {
               structure(NULL, class = "cancel-output")
             },
@@ -601,18 +904,16 @@ ShinySession <- R6Class(
               # path of try, because we don't want it to print. But we
               # do want to try to return the same looking result so that
               # the code below can send the error to the browser.
-              structure(
-                NULL,
-                class = "try-error",
-                condition = cond
-              )
+              structure(NULL, class = "try-error", condition = cond)
             },
             error = function(cond) {
-              msg <- paste0("Error in output$", name, ": ", conditionMessage(cond), "\n")
-              if (isTRUE(getOption("show.error.messages"))) {
-                printError(cond)
+              if (isTRUE(getOption("show.error.messages"))) printError(cond)
+              if (getOption("shiny.sanitize.errors", FALSE)) {
+                cond <- simpleError(paste("An error has occurred. Check your",
+                                          "logs or contact the app author for",
+                                          "clarification."))
               }
-              invisible(structure(msg, class = "try-error", condition = cond))
+              invisible(structure(NULL, class = "try-error", condition = cond))
             },
             finally = {
               private$sendMessage(recalculating = list(
@@ -654,21 +955,43 @@ ShinySession <- R6Class(
       }
     },
     flushOutput = function() {
+      if (self$isClosed())
+        return()
+
+      # Return TRUE if there's any stuff to send to the client.
+      hasPendingUpdates <- function() {
+        # Even though progressKeys isn't sent to the client, we use it in this
+        # check. This is because if it is non-empty, sending `values` to the
+        # client tells it that the flushReact loop is finished, and the client
+        # then knows to stop showing progress.
+        return(
+          length(private$progressKeys) != 0 ||
+          length(private$invalidatedOutputValues) != 0 ||
+          length(private$invalidatedOutputErrors) != 0 ||
+          length(private$inputMessageQueue) != 0
+        )
+      }
 
       # ..stacktraceon matches with the top-level ..stacktraceoff..
       private$flushCallbacks$invoke(..stacktraceon = TRUE)
-      # ..stacktraceon matches with the top-level ..stacktraceoff..
-      on.exit(private$flushedCallbacks$invoke(..stacktraceon = TRUE))
 
-      if (length(private$progressKeys) == 0
-          && length(private$invalidatedOutputValues) == 0
-          && length(private$invalidatedOutputErrors) == 0
-          && length(private$inputMessageQueue) == 0) {
+      # Schedule execution of onFlushed callbacks
+      on.exit({
+        # ..stacktraceon matches with the top-level ..stacktraceoff..
+        private$flushedCallbacks$invoke(..stacktraceon = TRUE)
+
+        # If one of the flushedCallbacks added anything to send to the client,
+        # or invalidated any observers, set up another flush cycle.
+        if (hasPendingUpdates() || .getReactiveEnvironment()$hasPendingFlush()) {
+          scheduleFlush()
+        }
+      })
+
+      if (!hasPendingUpdates()) {
         return(invisible())
       }
 
       private$progressKeys <- character(0)
-
       values <- private$invalidatedOutputValues
       private$invalidatedOutputValues <- Map$new()
       errors <- private$invalidatedOutputErrors
@@ -710,6 +1033,11 @@ ShinySession <- R6Class(
         notification = list(type = type, message = message)
       )
     },
+    sendModal = function(type, message) {
+      private$sendMessage(
+        modal = list(type = type, message = message)
+      )
+    },
     dispatch = function(msg) {
       method <- paste('@', msg$method, sep='')
       func <- try(self[[method]], silent = TRUE)
@@ -726,6 +1054,13 @@ ShinySession <- R6Class(
         private$sendResponse(msg, value)
       }
     },
+    sendBinaryMessage = function(type, message) {
+      typeBytes <- charToRaw(type)
+      if (length(typeBytes) > 255) {
+        stop("'type' argument is too long")
+      }
+      private$write(c(as.raw(length(typeBytes)), typeBytes, message))
+    },
     sendCustomMessage = function(type, message) {
       data <- list()
       data[[type]] <- message
@@ -759,13 +1094,124 @@ ShinySession <- R6Class(
         return(dereg)
       }
     },
+
+    setBookmarkExclude = function(names) {
+      private$bookmarkExclude <- names
+    },
+    getBookmarkExclude = function() {
+      private$bookmarkExclude
+    },
+    onBookmark = function(fun) {
+      if (!is.function(fun) || length(fun) != 1) {
+        stop("`fun` must be a function that takes one argument")
+      }
+      private$bookmarkCallbacks$register(fun)
+    },
+    onBookmarked = function(fun) {
+      if (!is.function(fun) || length(fun) != 1) {
+        stop("`fun` must be a function that takes one argument")
+      }
+      private$bookmarkedCallbacks$register(fun)
+    },
+    onRestore = function(fun) {
+      if (!is.function(fun) || length(fun) != 1) {
+        stop("`fun` must be a function that takes one argument")
+      }
+      private$restoreCallbacks$register(fun)
+    },
+    onRestored = function(fun) {
+      if (!is.function(fun) || length(fun) != 1) {
+        stop("`fun` must be a function that takes one argument")
+      }
+      private$restoredCallbacks$register(fun)
+    },
+    doBookmark = function() {
+      # Get bookmarking store config
+      store <- getShinyOption("bookmarkStore", default = "disable")
+      if (store == "disable")
+        return()
+
+      tryCatch(
+        withLogErrors({
+          saveState <- ShinySaveState$new(
+            input = self$input,
+            exclude = self$getBookmarkExclude(),
+            onSave = function(state) {
+              private$bookmarkCallbacks$invoke(state)
+            }
+          )
+
+          if (store == "server") {
+            url <- saveShinySaveState(saveState)
+          } else if (store == "url") {
+            url <- encodeShinySaveState(saveState)
+          } else {
+            stop("Unknown store type: ", store)
+          }
+
+          clientData <- self$clientData
+          url <- paste0(
+            clientData$url_protocol, "//",
+            clientData$url_hostname,
+            if (nzchar(clientData$url_port)) paste0(":", clientData$url_port),
+            clientData$url_pathname,
+            "?", url
+          )
+
+
+          # If onBookmarked callback was provided, invoke it; if not call
+          # the default.
+          if (private$bookmarkedCallbacks$count() > 0) {
+            private$bookmarkedCallbacks$invoke(url)
+          } else {
+            showBookmarkUrlModal(url)
+          }
+        }),
+        error = function(e) {
+          msg <- paste0("Error bookmarking state: ", e$message)
+          showNotification(msg, duration = NULL, type = "error")
+        }
+      )
+    },
+
+
     reactlog = function(logEntry) {
+      # Use sendCustomMessage instead of sendMessage, because the handler in
+      # shiny-showcase.js only has access to public API of the Shiny object.
       if (private$showcase)
-        private$sendMessage(reactlog = logEntry)
+        self$sendCustomMessage("reactlog", logEntry)
     },
     reload = function() {
       private$sendMessage(reload = TRUE)
     },
+    sendInsertUI = function(selector, multiple, where, content) {
+      private$sendMessage(
+        `shiny-insert-ui` = list(
+          selector = selector,
+          multiple = multiple,
+          where = where,
+          content = content
+        )
+      )
+    },
+    sendRemoveUI = function(selector, multiple) {
+      private$sendMessage(
+        `shiny-remove-ui` = list(
+          selector = selector,
+          multiple = multiple
+        )
+      )
+    },
+    updateQueryString = function(queryString) {
+      private$sendMessage(updateQueryString = list(queryString = queryString))
+    },
+    resetBrush = function(brushId) {
+      private$sendMessage(
+        resetBrush = list(
+          brushId = brushId
+        )
+      )
+    },
 
     # Public RPC methods
     `@uploadieFinish` = function() {
@@ -792,6 +1238,9 @@ ShinySession <- R6Class(
     `@uploadEnd` = function(jobId, inputId) {
       fileData <- private$fileUploadContext$getUploadOperation(jobId)$finish()
       private$.input$set(inputId, fileData)
+
+      private$.input$setMeta(inputId, "shiny.serializer", serializerFileInput)
+
       invisible()
     },
     # Provides a mechanism for handling direct HTTP requests that are posted
@@ -898,13 +1347,14 @@ ShinySession <- R6Class(
         # ..stacktraceon matches with the top-level ..stacktraceoff..
         result <- try(shinyCallingHandlers(Context$new(getDefaultReactiveDomain(), '[download]')$run(
           function() { ..stacktraceon..(download$func(tmpdata)) }
-        )))
+        )), silent = TRUE)
         if (inherits(result, 'try-error')) {
-          cond <- attr(result, 'condition', exact = TRUE)
-          printError(cond)
           unlink(tmpdata)
-          return(httpResponse(500, 'text/plain; charset=UTF-8',
-                              enc2utf8(conditionMessage(cond))))
+          stop(attr(result, "condition", exact = TRUE))
+        }
+        if (!file.exists(tmpdata)) {
+          # If no file was created, return a 404
+          return(httpResponse(404, content = "404 Not found"))
         }
         return(httpResponse(
           200,
@@ -976,10 +1426,11 @@ ShinySession <- R6Class(
     registerDataObj = function(name, data, filterFunc) {
       # abusing downloads at the moment
       self$downloads$set(name, list(data = data, filter = filterFunc))
-      return(sprintf('session/%s/dataobj/%s?w=%s',
+      return(sprintf('session/%s/dataobj/%s?w=%s&nonce=%s',
                      URLencode(self$token, TRUE),
                      URLencode(name, TRUE),
-                     workerId()))
+                     workerId(),
+                     URLencode(createUniqueId(8), TRUE)))
     },
     # This function suspends observers for hidden outputs and resumes observers
     # for un-hidden outputs.
@@ -1145,10 +1596,72 @@ ShinySession <- R6Class(
 #' @param ... Options to set for the output observer.
 #' @export
 outputOptions <- function(x, name, ...) {
-  if (!inherits(x, "shinyoutput"))
+  if (!inherits(x, "shinyoutput")) {
     stop("x must be a shinyoutput object.")
+  }
 
-  name <- .subset2(x, 'ns')(name)
+  if (!missing(name)) {
+    name <- .subset2(x, 'ns')(name)
+  } else {
+    name <- NULL
+  }
 
   .subset2(x, 'impl')$outputOptions(name, ...)
 }
+
+
+#' Add callbacks for Shiny session events
+#'
+#' These functions are for registering callbacks on Shiny session events.
+#' \code{onFlush} registers a function that will be called before Shiny flushes
+#' the reactive system. \code{onFlushed} registers a function that will be
+#' called after Shiny flushes the reactive system. \code{onSessionEnded}
+#' registers a function to be called after the client has disconnected.
+#'
+#' These functions should be called within the application's server function.
+#'
+#' All of these functions return a function which can be called with no
+#' arguments to cancel the registration.
+#'
+#' @param fun A callback function.
+#' @param once Should the function be run once, and then cleared, or should it
+#'   re-run each time the event occurs. (Only for \code{onFlush} and
+#'   \code{onFlushed}.)
+#' @param session A shiny session object.
+#'
+#' @export
+onFlush <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
+  session$onFlush(fun, once = once)
+}
+
+#' @rdname onFlush
+#' @export
+onFlushed <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
+  session$onFlushed(fun, once = once)
+}
+
+#' @rdname onFlush
+#' @export
+onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) {
+  session$onSessionEnded(fun)
+}
+
+
+scheduleFlush <- function() {
+  timerCallbacks$schedule(0, function() {})
+}
+
+flushAllSessions <- function() {
+  lapply(appsByToken$values(), function(shinysession) {
+    tryCatch(
+      shinysession$flushOutput(),
+
+      stop = function(e) {
+        # If there are any uncaught errors that bubbled up to here, close the
+        # session.
+        shinysession$close()
+      }
+    )
+    NULL
+  })
+}

R/shinyui.R

@@ -44,7 +44,7 @@ renderPage <- function(ui, connection, showcase=0) {
 
   shiny_deps <- list(
     htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
-    htmlDependency("jquery", "1.11.3", c(href="shared"), script = "jquery.min.js"),
+    htmlDependency("jquery", "1.12.4", c(href="shared"), script = "jquery.min.js"),
     htmlDependency("babel-polyfill", "6.7.2", c(href="shared"), script = "babel-polyfill.min.js"),
     htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
       script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
@@ -64,7 +64,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)
@@ -91,17 +90,34 @@ 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())
-      }
+
+    # 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)
 

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
@@ -69,13 +119,23 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'   it is sent to the client browser? Generally speaking, if the image is a
 #'   temp file generated within \code{func}, then this should be \code{TRUE};
 #'   if the image is not a temp file, this should be \code{FALSE}.
-#'
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{imageOutput}} when \code{renderImage} is used in an
+#'   interactive R Markdown document.
 #' @export
 #'
 #' @examples
-#' \dontrun{
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#' shinyServer(function(input, output, clientData) {
+#' ui <- fluidPage(
+#'   sliderInput("n", "Number of observations", 2, 1000, 500),
+#'   plotOutput("plot1"),
+#'   plotOutput("plot2"),
+#'   plotOutput("plot3")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'
 #'   # A plot of fixed size
 #'   output$plot1 <- renderImage({
@@ -97,14 +157,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 +175,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 +185,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 +210,9 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
     # Return a list with src, and other img attributes
     c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
       extra_attr)
-  }))
+  }
+
+  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
 }
 
 
@@ -173,28 +238,27 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'   object.
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
-#' @param func A function that may print output and/or return a printable R
-#'   object (deprecated; use \code{expr} instead).
+#'   is useful if you want to save an expression in a variable.
 #' @param width The value for \code{\link{options}('width')}.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{verbatimTextOutput}} when \code{renderPrint} is used
+#'   in an interactive R Markdown document.
 #' @seealso \code{\link{renderText}} for displaying the value returned from a
 #'   function, instead of the printed output.
 #'
 #' @example res/text-example.R
-#'
 #' @export
-renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, func = NULL,
-                        width = getOption('width')) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderPrint: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
+                        width = getOption('width'), outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(verbatimTextOutput, function() {
+  renderFunc <- function(shinysession, name, ...) {
     op <- options(width = width)
     on.exit(options(op), add = TRUE)
     paste(utils::capture.output(func()), collapse = "\n")
-  })
+  }
+
+  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' Text Output
@@ -215,26 +279,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,34 +313,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)
 
     processDeps(result, shinysession)
-  })
+  }
+
+  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' File Downloads
@@ -303,28 +376,40 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
 #'   example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or
 #'   \code{NA}, the content type will be guessed based on the filename
 #'   extension, or \code{application/octet-stream} if the extension is unknown.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{downloadButton}} when \code{downloadHandler} is used
+#'   in an interactive R Markdown document.
 #'
 #' @examples
-#' \dontrun{
-#' # In server.R:
-#' output$downloadData <- downloadHandler(
-#'   filename = function() {
-#'     paste('data-', Sys.Date(), '.csv', sep='')
-#'   },
-#'   content = function(file) {
-#'     write.csv(data, file)
-#'   }
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   downloadLink("downloadData", "Download")
 #' )
 #'
-#' # In ui.R:
-#' downloadLink('downloadData', 'Download')
+#' server <- function(input, output) {
+#'   # Our dataset
+#'   data <- mtcars
+#'
+#'   output$downloadData <- downloadHandler(
+#'     filename = function() {
+#'       paste("data-", Sys.Date(), ".csv", sep="")
+#'     },
+#'     content = function(file) {
+#'       write.csv(data, file)
+#'     }
+#'   )
 #' }
 #'
+#' shinyApp(ui, server)
+#' }
 #' @export
-downloadHandler <- function(filename, content, contentType=NA) {
-  return(markRenderFunction(downloadButton, function(shinysession, name, ...) {
+downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()) {
+  renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
-  }))
+  }
+  markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
 }
 
 #' Table output with the JavaScript library DataTables
@@ -355,6 +440,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
@@ -389,10 +478,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)
@@ -418,7 +508,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

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

R/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,16 +86,24 @@ 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
@@ -63,10 +118,23 @@ updateCheckboxInput <- updateTextInput
 #' @seealso \code{\link{actionButton}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## 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",
@@ -80,9 +148,11 @@ updateCheckboxInput <- updateTextInput
 #'     # Leaves goButton3's icon, if it exists,
 #'     # unchaged and changes its label
 #'     updateActionButton(session, "goButton3",
-#'       label = "New label")
+#'       label = "New label 3")
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
@@ -96,7 +166,7 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 #'
 #' @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
@@ -105,32 +175,44 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 #' @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)
@@ -141,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
@@ -152,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,
@@ -180,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
   ))
@@ -200,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) {
@@ -242,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
@@ -256,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,
@@ -347,11 +457,11 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
   if (!is.null(choices))
     choices <- choicesWithNames(choices)
   if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+    selected <- validateSelected(selected, choices, session$ns(inputId))
 
   options <- if (!is.null(choices)) {
     format(tagList(
-      generateOptions(inputId, choices, selected, inline, type = type)
+      generateOptions(session$ns(inputId), choices, selected, inline, type = type)
     ))
   }
 
@@ -368,31 +478,35 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' @seealso \code{\link{checkboxGroupInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The first checkbox group controls the second"),
+#'   checkboxGroupInput("inCheckboxGroup", "Input checkbox",
+#'     c("Item A", "Item B", "Item C")),
+#'   checkboxGroupInput("inCheckboxGroup2", "Input checkbox 2",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inCheckboxGroup
 #'
-#'     # Create a list of new options, where the name of the items is something
-#'     # like 'option label x 1', and the values are 'option-x-1'.
-#'     cb_options <- list()
-#'     cb_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     cb_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
-#'
-#'     # Change values for input$inCheckboxGroup
-#'     updateCheckboxGroupInput(session, "inCheckboxGroup", choices = cb_options)
+#'     # Can use character(0) to remove all choices
+#'     if (is.null(x))
+#'       x <- character(0)
 #'
 #'     # Can also set the label and select items
 #'     updateCheckboxGroupInput(session, "inCheckboxGroup2",
-#'       label = paste("checkboxgroup label", x),
-#'       choices = cb_options,
-#'       selected = sprintf("option-%d-2", x)
+#'       label = paste("Checkboxgroup label", length(x)),
+#'       choices = x,
+#'       selected = x
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateCheckboxGroupInput <- function(session, inputId, label = NULL,
@@ -410,29 +524,31 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' @seealso \code{\link{radioButtons}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The first radio button group controls the second"),
+#'   radioButtons("inRadioButtons", "Input radio buttons",
+#'     c("Item A", "Item B", "Item C")),
+#'   radioButtons("inRadioButtons2", "Input radio buttons 2",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inRadioButtons
 #'
-#'     r_options <- list()
-#'     r_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     r_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
-#'
-#'     # Change values for input$inRadio
-#'     updateRadioButtons(session, "inRadio", choices = r_options)
-#'
-#'     # Can also set the label and select an item
-#'     updateRadioButtons(session, "inRadio2",
-#'       label = paste("Radio label", x),
-#'       choices = r_options,
-#'       selected = sprintf("option-%d-2", x)
+#'     # Can also set the label and select items
+#'     updateRadioButtons(session, "inRadioButtons2",
+#'       label = paste("radioButtons label", x),
+#'       choices = x,
+#'       selected = x
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
@@ -451,32 +567,35 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @seealso \code{\link{selectInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The checkbox group controls the select input"),
+#'   checkboxGroupInput("inCheckboxGroup", "Input checkbox",
+#'     c("Item A", "Item B", "Item C")),
+#'   selectInput("inSelect", "Select input",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inCheckboxGroup
 #'
-#'     # Create a list of new options, where the name of the items is something
-#'     # like 'option label x 1', and the values are 'option-x-1'.
-#'     s_options <- list()
-#'     s_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     s_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
+#'     # Can use character(0) to remove all choices
+#'     if (is.null(x))
+#'       x <- character(0)
 #'
-#'     # Change values for input$inSelect
-#'     updateSelectInput(session, "inSelect", choices = s_options)
-#'
-#'     # Can also set the label and select an item (or more than one if it's a
-#'     # multi-select)
-#'     updateSelectInput(session, "inSelect2",
-#'       label = paste("Select label", x),
-#'       choices = s_options,
-#'       selected = sprintf("option-%d-2", x)
+#'     # Can also set the label and select items
+#'     updateSelectInput(session, "inSelect",
+#'       label = paste("Select input label", length(x)),
+#'       choices = x,
+#'       selected = tail(x, 1)
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,

R/utils.R

@@ -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)
@@ -120,16 +119,6 @@ p_randomInt <- function(...) {
   withPrivateSeed(randomInt(...))
 }
 
-# Return a random hexadecimal string with `length` digits.
-randomID <- function(length = 16) {
-  paste(sample(
-    c("0", "1", "2", "3", "4", "5", "6", "7", "8","9",
-      "a", "b", "c", "d", "e", "f"),
-    length,
-    replace = TRUE
-  ), collapse = '')
-}
-
 isWholeNum <- function(x, tol = .Machine$double.eps^0.5) {
   abs(x - round(x)) < tol
 }
@@ -165,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
@@ -179,6 +182,21 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
+# Given two named vectors, join them together, and keep only the last element
+# with a given name in the resulting vector. If b has any elements with the same
+# name as elements in a, the element in a is dropped. Also, if there are any
+# duplicated names in a or b, only the last one with that name is kept.
+mergeVectors <- function(a, b) {
+  if (anyUnnamed(a) || anyUnnamed(b)) {
+    stop("Vectors must be either NULL or have names for all elements")
+  }
+
+  x <- c(a, b)
+  drop_idx <- duplicated(names(x), fromLast = TRUE)
+  x[!drop_idx]
+}
+
+
 # Combine dir and (file)name into a file path. If a file already exists with a
 # name differing only by case, then use it instead.
 file.path.ci <- function(...) {
@@ -221,6 +239,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.
@@ -386,7 +410,6 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #'
 #' isolate(tripleA())
 #' # "text, text, text"
-#'
 #' @export
 exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
   if (!quoted) {
@@ -420,7 +443,6 @@ exprToFunction <- function(expr, env=parent.frame(), 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,
@@ -464,7 +486,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)
@@ -480,7 +502,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) {
@@ -492,6 +514,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))
@@ -607,7 +631,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) {
@@ -872,6 +899,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
@@ -928,15 +1092,16 @@ 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()) {
+#'
+#' 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!'),
@@ -945,6 +1110,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
@@ -965,8 +1134,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
@@ -1060,20 +1228,67 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #'
 #' \code{req(input$a != 0)}
 #'
+#' \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
+#' @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)) {
       if (isTRUE(cancelOutput)) {
         cancelOutput()
       } else {
-        stopWithCondition("validation", "")
+        reactiveStop(class = "validation")
       }
     }
   }, ...)
@@ -1084,20 +1299,44 @@ req <- function(..., cancelOutput = FALSE) {
     invisible()
 }
 
-#' Cancel processing of the current output
-#'
-#' Signals an error that Shiny treats specially if an output is currently being
-#' evaluated. Execution will stop, but rather than clearing the output (as
-#' \code{\link{req}} does) or showing an error message (as \code{\link{stop}}
-#' does), the output simply remains unchanged.
-#'
-#' If \code{cancelOutput} is called in any non-output context (like in an
-#' \code{\link{observe}} or \code{\link{observeEvent}}), the effect is the same
-#' as \code{\link{req}(FALSE)}.
-#'
-#' @export
+#***********************************************************************#
+#**** 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() {
-  stopWithCondition("shiny.output.cancel", "")
+  reactiveStop(class = "shiny.output.cancel")
 }
 
 # Execute a function against each element of ..., but only evaluate each element
@@ -1112,6 +1351,8 @@ dotloop <- function(fun_, ...) {
   invisible()
 }
 
+#' @export
+#' @rdname req
 isTruthy <- function(x) {
   if (inherits(x, 'try-error'))
     return(FALSE)
@@ -1140,7 +1381,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)
 }
@@ -1295,3 +1536,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.
 

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"),
@@ -24,4 +24,4 @@ shinyUI(fluidPage(
       tableOutput("view")
     )
   )
-))
+)

inst/examples/03_reactivity/server.R

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

inst/examples/03_reactivity/ui.R

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

inst/examples/04_mpg/server.R

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

inst/examples/04_mpg/ui.R

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

inst/examples/05_sliders/server.R

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

inst/examples/05_sliders/ui.R

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

inst/examples/06_tabsets/server.R

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

inst/examples/06_tabsets/ui.R

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

inst/examples/07_widgets/server.R

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

inst/examples/07_widgets/ui.R

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

inst/examples/08_html/server.R

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

inst/examples/09_upload/server.R

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

inst/examples/09_upload/ui.R

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

inst/examples/10_download/server.R

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

inst/examples/10_download/ui.R

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

inst/examples/11_timer/server.R

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

inst/examples/11_timer/ui.R

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

inst/staticdocs/index.r

@@ -44,7 +44,9 @@ sd_section("UI Inputs",
     "sliderInput",
     "submitButton",
     "textInput",
+    "textAreaInput",
     "passwordInput",
+    "modalButton",
     "updateActionButton",
     "updateCheckboxGroupInput",
     "updateCheckboxInput",
@@ -55,7 +57,9 @@ sd_section("UI Inputs",
     "updateSelectInput",
     "updateSliderInput",
     "updateTabsetPanel",
-    "updateTextInput"
+    "updateTextInput",
+    "updateTextAreaInput",
+    "updateQueryString"
   )
 )
 sd_section("UI Outputs",
@@ -69,7 +73,11 @@ sd_section("UI Outputs",
     "verbatimTextOutput",
     "downloadButton",
     "Progress",
-    "withProgress"
+    "withProgress",
+    "modalDialog",
+    "urlModal",
+    "showModal",
+    "showNotification"
   )
 )
 sd_section("Interface builder functions",
@@ -84,7 +92,9 @@ sd_section("Interface builder functions",
     "withTags",
     "htmlTemplate",
     "bootstrapLib",
-    "suppressDependencies"
+    "suppressDependencies",
+    "insertUI",
+    "removeUI"
   )
 )
 sd_section("Rendering functions",
@@ -120,6 +130,7 @@ sd_section("Reactive constructs",
     "reactiveTimer",
     "reactiveValues",
     "reactiveValuesToList",
+    "freezeReactiveValue",
     "domains",
     "showReactLog"
   )
@@ -143,6 +154,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(
@@ -157,9 +178,13 @@ sd_section("Utility functions",
   "Miscellaneous utilities that may be useful to advanced users or when extending Shiny.",
   c(
     "req",
-    "cancelOutput",
     "validate",
     "session",
+    "shinyOptions",
+    "safeError",
+    "onFlush",
+    "restoreInput",
+    "applyInputHandlers",
     "exprToFunction",
     "installExprFunction",
     "parseQueryString",

inst/www/reactive-graph.html

@@ -66,7 +66,7 @@ svg {
 }
 .node path {
   fill: white;
-  stroke: #777;
+  stroke: #999;
   stroke-width: 7.5px;
   transition: fill 0.75s ease;
 }
@@ -83,6 +83,9 @@ svg {
 .node.running path {
   fill: #61B97E;
 }
+.node.fixed path {
+  stroke: #000;
+}
 #legend {
   font-size: 22px;
   position: fixed;
@@ -1094,7 +1097,13 @@ function update() {
       .on('mouseout', function(d, i) {
         $('#description').text('');
       })
-      .call(force.drag);
+      .on('dblclick', function(d) {
+        d3.event.stopPropagation();
+        d3.select(this).classed('fixed', d.fixed = false);
+      })
+      .call(force.drag().on('dragstart', function(d) {
+        d3.select(this).classed('fixed', d.fixed = true);
+      }));
   newG.append('path')
       .attr('transform', 'scale(0.08)')
       .attr('stroke', 'black')

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

@@ -1,6 +1,6 @@
 /*!
- * Bootstrap v3.3.6 (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.6 (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 */
@@ -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;
 }
@@ -3029,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;
 }

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

@@ -1,6 +1,6 @@
 /*!
- * Bootstrap v3.3.6 (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) || (version[0] > 2)) {
-    throw new Error('Bootstrap\'s JavaScript requires jQuery version 1.9.1 or higher, but lower than version 3')
+  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.6
+ * 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.6
+ * 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.6'
+  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.6
+ * 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.6'
+  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.6
+ * 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.6'
+  Carousel.VERSION  = '3.3.7'
 
   Carousel.TRANSITION_DURATION = 600
 
@@ -531,13 +536,14 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: collapse.js v3.3.6
+ * 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.6'
+  Collapse.VERSION  = '3.3.7'
 
   Collapse.TRANSITION_DURATION = 350
 
@@ -743,10 +749,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: dropdown.js v3.3.6
+ * 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.6'
+  Dropdown.VERSION = '3.3.7'
 
   function getParent($this) {
     var selector = $this.attr('data-target')
@@ -909,10 +915,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: modal.js v3.3.6
+ * 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.6'
+  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.6
+ * 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.6'
+  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.6
+ * 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.6'
+  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.6
+ * 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.6'
+  ScrollSpy.VERSION  = '3.3.7'
 
   ScrollSpy.DEFAULTS = {
     offset: 10
@@ -2044,10 +2058,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: tab.js v3.3.6
+ * 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.6'
+  Tab.VERSION = '3.3.7'
 
   Tab.TRANSITION_DURATION = 150
 
@@ -2200,10 +2214,10 @@ if (typeof jQuery === 'undefined') {
 }(jQuery);
 
 /* ========================================================================
- * Bootstrap: affix.js v3.3.6
+ * 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.6'
+  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 */

inst/www/shared/datepicker/css/datepicker.css

@@ -1,442 +0,0 @@
-/*!
- * Datepicker for Bootstrap
- *
- * Copyright 2012 Stefan Petre
- * Improvements by Andrew Rowls
- * Licensed under the Apache License v2.0
- * http://www.apache.org/licenses/LICENSE-2.0
- *
- */
-.datepicker {
-  padding: 4px;
-  -webkit-border-radius: 4px;
-  -moz-border-radius: 4px;
-  border-radius: 4px;
-  direction: ltr;
-  /*.dow {
-		border-top: 1px solid #ddd !important;
-	}*/
-
-}
-.datepicker-inline {
-  width: 220px;
-}
-.datepicker.datepicker-rtl {
-  direction: rtl;
-}
-.datepicker.datepicker-rtl table tr td span {
-  float: right;
-}
-.datepicker-dropdown {
-  top: 0;
-  left: 0;
-}
-.datepicker-dropdown:before {
-  content: '';
-  display: inline-block;
-  border-left: 7px solid transparent;
-  border-right: 7px solid transparent;
-  border-bottom: 7px solid #ccc;
-  border-bottom-color: rgba(0, 0, 0, 0.2);
-  position: absolute;
-  top: -7px;
-  left: 6px;
-}
-.datepicker-dropdown:after {
-  content: '';
-  display: inline-block;
-  border-left: 6px solid transparent;
-  border-right: 6px solid transparent;
-  border-bottom: 6px solid #ffffff;
-  position: absolute;
-  top: -6px;
-  left: 7px;
-}
-.datepicker > div {
-  display: none;
-}
-.datepicker.days div.datepicker-days {
-  display: block;
-}
-.datepicker.months div.datepicker-months {
-  display: block;
-}
-.datepicker.years div.datepicker-years {
-  display: block;
-}
-.datepicker table {
-  margin: 0;
-}
-.datepicker td,
-.datepicker th {
-  text-align: center;
-  width: 20px;
-  height: 20px;
-  -webkit-border-radius: 4px;
-  -moz-border-radius: 4px;
-  border-radius: 4px;
-  border: none;
-}
-.table-striped .datepicker table tr td,
-.table-striped .datepicker table tr th {
-  background-color: transparent;
-}
-.datepicker table tr td.day:hover {
-  background: #eeeeee;
-  cursor: pointer;
-}
-.datepicker table tr td.old,
-.datepicker table tr td.new {
-  color: #999999;
-}
-.datepicker table tr td.disabled,
-.datepicker table tr td.disabled:hover {
-  background: none;
-  color: #999999;
-  cursor: default;
-}
-.datepicker table tr td.today,
-.datepicker table tr td.today:hover,
-.datepicker table tr td.today.disabled,
-.datepicker table tr td.today.disabled:hover {
-  background-color: #fde19a;
-  background-image: -moz-linear-gradient(top, #fdd49a, #fdf59a);
-  background-image: -ms-linear-gradient(top, #fdd49a, #fdf59a);
-  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#fdd49a), to(#fdf59a));
-  background-image: -webkit-linear-gradient(top, #fdd49a, #fdf59a);
-  background-image: -o-linear-gradient(top, #fdd49a, #fdf59a);
-  background-image: linear-gradient(top, #fdd49a, #fdf59a);
-  background-repeat: repeat-x;
-  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fdd49a', endColorstr='#fdf59a', GradientType=0);
-  border-color: #fdf59a #fdf59a #fbed50;
-  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
-  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
-  color: #000 !important;
-}
-.datepicker table tr td.today:hover,
-.datepicker table tr td.today:hover:hover,
-.datepicker table tr td.today.disabled:hover,
-.datepicker table tr td.today.disabled:hover:hover,
-.datepicker table tr td.today:active,
-.datepicker table tr td.today:hover:active,
-.datepicker table tr td.today.disabled:active,
-.datepicker table tr td.today.disabled:hover:active,
-.datepicker table tr td.today.active,
-.datepicker table tr td.today:hover.active,
-.datepicker table tr td.today.disabled.active,
-.datepicker table tr td.today.disabled:hover.active,
-.datepicker table tr td.today.disabled,
-.datepicker table tr td.today:hover.disabled,
-.datepicker table tr td.today.disabled.disabled,
-.datepicker table tr td.today.disabled:hover.disabled,
-.datepicker table tr td.today[disabled],
-.datepicker table tr td.today:hover[disabled],
-.datepicker table tr td.today.disabled[disabled],
-.datepicker table tr td.today.disabled:hover[disabled] {
-  background-color: #fdf59a;
-}
-.datepicker table tr td.today:active,
-.datepicker table tr td.today:hover:active,
-.datepicker table tr td.today.disabled:active,
-.datepicker table tr td.today.disabled:hover:active,
-.datepicker table tr td.today.active,
-.datepicker table tr td.today:hover.active,
-.datepicker table tr td.today.disabled.active,
-.datepicker table tr td.today.disabled:hover.active {
-  background-color: #fbf069 \9;
-}
-.datepicker table tr td.range,
-.datepicker table tr td.range:hover,
-.datepicker table tr td.range.disabled,
-.datepicker table tr td.range.disabled:hover {
-  background: #eeeeee;
-  -webkit-border-radius: 0;
-  -moz-border-radius: 0;
-  border-radius: 0;
-}
-.datepicker table tr td.range.today,
-.datepicker table tr td.range.today:hover,
-.datepicker table tr td.range.today.disabled,
-.datepicker table tr td.range.today.disabled:hover {
-  background-color: #f3d17a;
-  background-image: -moz-linear-gradient(top, #f3c17a, #f3e97a);
-  background-image: -ms-linear-gradient(top, #f3c17a, #f3e97a);
-  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#f3c17a), to(#f3e97a));
-  background-image: -webkit-linear-gradient(top, #f3c17a, #f3e97a);
-  background-image: -o-linear-gradient(top, #f3c17a, #f3e97a);
-  background-image: linear-gradient(top, #f3c17a, #f3e97a);
-  background-repeat: repeat-x;
-  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#f3c17a', endColorstr='#f3e97a', GradientType=0);
-  border-color: #f3e97a #f3e97a #edde34;
-  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
-  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
-  -webkit-border-radius: 0;
-  -moz-border-radius: 0;
-  border-radius: 0;
-}
-.datepicker table tr td.range.today:hover,
-.datepicker table tr td.range.today:hover:hover,
-.datepicker table tr td.range.today.disabled:hover,
-.datepicker table tr td.range.today.disabled:hover:hover,
-.datepicker table tr td.range.today:active,
-.datepicker table tr td.range.today:hover:active,
-.datepicker table tr td.range.today.disabled:active,
-.datepicker table tr td.range.today.disabled:hover:active,
-.datepicker table tr td.range.today.active,
-.datepicker table tr td.range.today:hover.active,
-.datepicker table tr td.range.today.disabled.active,
-.datepicker table tr td.range.today.disabled:hover.active,
-.datepicker table tr td.range.today.disabled,
-.datepicker table tr td.range.today:hover.disabled,
-.datepicker table tr td.range.today.disabled.disabled,
-.datepicker table tr td.range.today.disabled:hover.disabled,
-.datepicker table tr td.range.today[disabled],
-.datepicker table tr td.range.today:hover[disabled],
-.datepicker table tr td.range.today.disabled[disabled],
-.datepicker table tr td.range.today.disabled:hover[disabled] {
-  background-color: #f3e97a;
-}
-.datepicker table tr td.range.today:active,
-.datepicker table tr td.range.today:hover:active,
-.datepicker table tr td.range.today.disabled:active,
-.datepicker table tr td.range.today.disabled:hover:active,
-.datepicker table tr td.range.today.active,
-.datepicker table tr td.range.today:hover.active,
-.datepicker table tr td.range.today.disabled.active,
-.datepicker table tr td.range.today.disabled:hover.active {
-  background-color: #efe24b \9;
-}
-.datepicker table tr td.selected,
-.datepicker table tr td.selected:hover,
-.datepicker table tr td.selected.disabled,
-.datepicker table tr td.selected.disabled:hover {
-  background-color: #9e9e9e;
-  background-image: -moz-linear-gradient(top, #b3b3b3, #808080);
-  background-image: -ms-linear-gradient(top, #b3b3b3, #808080);
-  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#b3b3b3), to(#808080));
-  background-image: -webkit-linear-gradient(top, #b3b3b3, #808080);
-  background-image: -o-linear-gradient(top, #b3b3b3, #808080);
-  background-image: linear-gradient(top, #b3b3b3, #808080);
-  background-repeat: repeat-x;
-  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#b3b3b3', endColorstr='#808080', GradientType=0);
-  border-color: #808080 #808080 #595959;
-  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
-  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
-  color: #fff;
-  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
-}
-.datepicker table tr td.selected:hover,
-.datepicker table tr td.selected:hover:hover,
-.datepicker table tr td.selected.disabled:hover,
-.datepicker table tr td.selected.disabled:hover:hover,
-.datepicker table tr td.selected:active,
-.datepicker table tr td.selected:hover:active,
-.datepicker table tr td.selected.disabled:active,
-.datepicker table tr td.selected.disabled:hover:active,
-.datepicker table tr td.selected.active,
-.datepicker table tr td.selected:hover.active,
-.datepicker table tr td.selected.disabled.active,
-.datepicker table tr td.selected.disabled:hover.active,
-.datepicker table tr td.selected.disabled,
-.datepicker table tr td.selected:hover.disabled,
-.datepicker table tr td.selected.disabled.disabled,
-.datepicker table tr td.selected.disabled:hover.disabled,
-.datepicker table tr td.selected[disabled],
-.datepicker table tr td.selected:hover[disabled],
-.datepicker table tr td.selected.disabled[disabled],
-.datepicker table tr td.selected.disabled:hover[disabled] {
-  background-color: #808080;
-}
-.datepicker table tr td.selected:active,
-.datepicker table tr td.selected:hover:active,
-.datepicker table tr td.selected.disabled:active,
-.datepicker table tr td.selected.disabled:hover:active,
-.datepicker table tr td.selected.active,
-.datepicker table tr td.selected:hover.active,
-.datepicker table tr td.selected.disabled.active,
-.datepicker table tr td.selected.disabled:hover.active {
-  background-color: #666666 \9;
-}
-.datepicker table tr td.active,
-.datepicker table tr td.active:hover,
-.datepicker table tr td.active.disabled,
-.datepicker table tr td.active.disabled:hover {
-  background-color: #006dcc;
-  background-image: -moz-linear-gradient(top, #0088cc, #0044cc);
-  background-image: -ms-linear-gradient(top, #0088cc, #0044cc);
-  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0044cc));
-  background-image: -webkit-linear-gradient(top, #0088cc, #0044cc);
-  background-image: -o-linear-gradient(top, #0088cc, #0044cc);
-  background-image: linear-gradient(top, #0088cc, #0044cc);
-  background-repeat: repeat-x;
-  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#0088cc', endColorstr='#0044cc', GradientType=0);
-  border-color: #0044cc #0044cc #002a80;
-  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
-  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
-  color: #fff;
-  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
-}
-.datepicker table tr td.active:hover,
-.datepicker table tr td.active:hover:hover,
-.datepicker table tr td.active.disabled:hover,
-.datepicker table tr td.active.disabled:hover:hover,
-.datepicker table tr td.active:active,
-.datepicker table tr td.active:hover:active,
-.datepicker table tr td.active.disabled:active,
-.datepicker table tr td.active.disabled:hover:active,
-.datepicker table tr td.active.active,
-.datepicker table tr td.active:hover.active,
-.datepicker table tr td.active.disabled.active,
-.datepicker table tr td.active.disabled:hover.active,
-.datepicker table tr td.active.disabled,
-.datepicker table tr td.active:hover.disabled,
-.datepicker table tr td.active.disabled.disabled,
-.datepicker table tr td.active.disabled:hover.disabled,
-.datepicker table tr td.active[disabled],
-.datepicker table tr td.active:hover[disabled],
-.datepicker table tr td.active.disabled[disabled],
-.datepicker table tr td.active.disabled:hover[disabled] {
-  background-color: #0044cc;
-}
-.datepicker table tr td.active:active,
-.datepicker table tr td.active:hover:active,
-.datepicker table tr td.active.disabled:active,
-.datepicker table tr td.active.disabled:hover:active,
-.datepicker table tr td.active.active,
-.datepicker table tr td.active:hover.active,
-.datepicker table tr td.active.disabled.active,
-.datepicker table tr td.active.disabled:hover.active {
-  background-color: #003399 \9;
-}
-.datepicker table tr td span {
-  display: block;
-  width: 23%;
-  height: 54px;
-  line-height: 54px;
-  float: left;
-  margin: 1%;
-  cursor: pointer;
-  -webkit-border-radius: 4px;
-  -moz-border-radius: 4px;
-  border-radius: 4px;
-}
-.datepicker table tr td span:hover {
-  background: #eeeeee;
-}
-.datepicker table tr td span.disabled,
-.datepicker table tr td span.disabled:hover {
-  background: none;
-  color: #999999;
-  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 {
-  background-color: #006dcc;
-  background-image: -moz-linear-gradient(top, #0088cc, #0044cc);
-  background-image: -ms-linear-gradient(top, #0088cc, #0044cc);
-  background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0044cc));
-  background-image: -webkit-linear-gradient(top, #0088cc, #0044cc);
-  background-image: -o-linear-gradient(top, #0088cc, #0044cc);
-  background-image: linear-gradient(top, #0088cc, #0044cc);
-  background-repeat: repeat-x;
-  filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#0088cc', endColorstr='#0044cc', GradientType=0);
-  border-color: #0044cc #0044cc #002a80;
-  border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25);
-  filter: progid:DXImageTransform.Microsoft.gradient(enabled=false);
-  color: #fff;
-  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
-}
-.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,
-.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,
-.datepicker table tr td span.active.disabled,
-.datepicker table tr td span.active:hover.disabled,
-.datepicker table tr td span.active.disabled.disabled,
-.datepicker table tr td span.active.disabled:hover.disabled,
-.datepicker table tr td span.active[disabled],
-.datepicker table tr td span.active:hover[disabled],
-.datepicker table tr td span.active.disabled[disabled],
-.datepicker table tr td span.active.disabled:hover[disabled] {
-  background-color: #0044cc;
-}
-.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 {
-  background-color: #003399 \9;
-}
-.datepicker table tr td span.old {
-  color: #999999;
-}
-.datepicker th.datepicker-switch {
-  width: 145px;
-}
-.datepicker thead tr:first-child th,
-.datepicker tfoot tr:first-child th {
-  cursor: pointer;
-}
-.datepicker thead tr:first-child th:hover,
-.datepicker tfoot tr:first-child th:hover {
-  background: #eeeeee;
-}
-.datepicker .cw {
-  font-size: 10px;
-  width: 12px;
-  padding: 0 2px 0 5px;
-  vertical-align: middle;
-}
-.datepicker thead tr:first-child th.cw {
-  cursor: default;
-  background-color: transparent;
-}
-.input-append.date .add-on i,
-.input-prepend.date .add-on i {
-  display: block;
-  cursor: pointer;
-  width: 16px;
-  height: 16px;
-}
-.input-daterange input {
-  text-align: center;
-}
-.input-daterange input:first-child {
-  -webkit-border-radius: 3px 0 0 3px;
-  -moz-border-radius: 3px 0 0 3px;
-  border-radius: 3px 0 0 3px;
-}
-.input-daterange input:last-child {
-  -webkit-border-radius: 0 3px 3px 0;
-  -moz-border-radius: 0 3px 3px 0;
-  border-radius: 0 3px 3px 0;
-}
-.input-daterange .add-on {
-  display: inline-block;
-  width: auto;
-  min-width: 16px;
-  height: 18px;
-  padding: 4px 5px;
-  font-weight: normal;
-  line-height: 18px;
-  text-align: center;
-  text-shadow: 0 1px 0 #ffffff;
-  vertical-align: middle;
-  background-color: #eeeeee;
-  border: 1px solid #ccc;
-  margin-left: -5px;
-  margin-right: -5px;
-}

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.ar.min.js

@@ -0,0 +1 @@
+!function(a){a.fn.datepicker.dates.ar={days:["الأحد","الاثنين","الثلاثاء","الأربعاء","الخميس","الجمعة","السبت","الأحد"],daysShort:["أحد","اثنين","ثلاثاء","أربعاء","خميس","جمعة","سبت","أحد"],daysMin:["ح","ن","ث","ع","خ","ج","س","ح"],months:["يناير","فبراير","مارس","أبريل","مايو","يونيو","يوليو","أغسطس","سبتمبر","أكتوبر","نوفمبر","ديسمبر"],monthsShort:["يناير","فبراير","مارس","أبريل","مايو","يونيو","يوليو","أغسطس","سبتمبر","أكتوبر","نوفمبر","ديسمبر"],today:"هذا اليوم",rtl:!0}}(jQuery);

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.az.min.js

@@ -0,0 +1 @@
+!function(a){a.fn.datepicker.dates.az={days:["Bazar","Bazar ertəsi","Çərşənbə axşamı","Çərşənbə","Cümə axşamı","Cümə","Şənbə"],daysShort:["B.","B.e","Ç.a","Ç.","C.a","C.","Ş."],daysMin:["B.","B.e","Ç.a","Ç.","C.a","C.","Ş."],months:["Yanvar","Fevral","Mart","Aprel","May","İyun","İyul","Avqust","Sentyabr","Oktyabr","Noyabr","Dekabr"],monthsShort:["Yan","Fev","Mar","Apr","May","İyun","İyul","Avq","Sen","Okt","Noy","Dek"],today:"Bu gün",weekStart:1}}(jQuery);

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.bg.js

@@ -1,14 +0,0 @@
-/**
- * Bulgarian translation for bootstrap-datepicker
- * Apostol Apostolov <apostol.s.apostolov@gmail.com>
- */
-;(function($){
-	$.fn.datepicker.dates['bg'] = {
-		days: ["Неделя", "Понеделник", "Вторник", "Сряда", "Четвъртък", "Петък", "Събота", "Неделя"],
-		daysShort: ["Нед", "Пон", "Вто", "Сря", "Чет", "Пет", "Съб", "Нед"],
-		daysMin: ["Н", "П", "В", "С", "Ч", "П", "С", "Н"],
-		months: ["Януари", "Февруари", "Март", "Април", "Май", "Юни", "Юли", "Август", "Септември", "Октомври", "Ноември", "Декември"],
-		monthsShort: ["Ян", "Фев", "Мар", "Апр", "Май", "Юни", "Юли", "Авг", "Сеп", "Окт", "Ное", "Дек"],
-		today: "днес"
-	};
-}(jQuery));

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.bg.min.js

@@ -0,0 +1 @@
+!function(a){a.fn.datepicker.dates.bg={days:["Неделя","Понеделник","Вторник","Сряда","Четвъртък","Петък","Събота"],daysShort:["Нед","Пон","Вто","Сря","Чет","Пет","Съб"],daysMin:["Н","П","В","С","Ч","П","С"],months:["Януари","Февруари","Март","Април","Май","Юни","Юли","Август","Септември","Октомври","Ноември","Декември"],monthsShort:["Ян","Фев","Мар","Апр","Май","Юни","Юли","Авг","Сеп","Окт","Ное","Дек"],today:"днес"}}(jQuery);

inst/www/shared/datepicker/js/locales/bootstrap-datepicker.bs.min.js

@@ -0,0 +1 @@
+!function(a){a.fn.datepicker.dates.bs={days:["Nedjelja","Ponedjeljak","Utorak","Srijeda","Četvrtak","Petak","Subota"],daysShort:["Ned","Pon","Uto","Sri","Čet","Pet","Sub"],daysMin:["N","Po","U","Sr","Č","Pe","Su"],months:["Januar","Februar","Mart","April","Maj","Juni","Juli","August","Septembar","Oktobar","Novembar","Decembar"],monthsShort:["Jan","Feb","Mar","Apr","Maj","Jun","Jul","Aug","Sep","Okt","Nov","Dec"],today:"Danas",weekStart:1,format:"dd.mm.yyyy"}}(jQuery);