Bump version to 0.14

Barbara/update old release news

.Rbuildignore

@@ -6,6 +6,7 @@
 ^shiny\.cmd$
 ^run\.R$
 ^\.gitignore$
+^smoketests$
 ^res$
 ^man-roxygen$
 ^\.travis\.yml$
@@ -14,3 +15,6 @@
 ^srcjs$
 ^CONTRIBUTING.md$
 ^cran-comments.md$
+^.*\.o$
+^appveyor\.yml$
+^revdep$

.gitignore

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

.travis.yml

@@ -1,12 +1,17 @@
 language: r
-warnings_are_errors: true
-
-r_binary_packages:
-  - Rcpp
-  - cairo
-  - knitr
+r:
+  - oldrel
+  - release
+  - devel
+sudo: false
+cache: packages
 
 notifications:
   email:
     on_success: change
     on_failure: change
+
+# Set CXX1X for R-devel, as R-devel does not detect CXX1X support for gcc 4.6.3.
+# This was causing dependency sourcetools to fail.
+before_install:
+  - if [[ "$TRAVIS_R_VERSION_STRING" = 'devel' ]]; then mkdir ~/.R && echo 'CXX1X=g++ -std=c++0x -g -O2 -fPIC' > ~/.R/Makevars; fi

DESCRIPTION

@@ -1,8 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.12.0
-Date: 2015-05-18
+Version: 0.14
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -42,6 +41,8 @@ Authors@R: c(
     comment = "es5-shim library"),
     person("Denis", "Ineshin", role = c("ctb", "cph"),
     comment = "ion.rangeSlider library"),
+    person("Sami", "Samhuri", role = c("ctb", "cph"),
+    comment = "Javascript strftime library"),
     person(family = "SpryMedia Limited", role = c("ctb", "cph"),
     comment = "DataTables library"),
     person("John", "Fraser", role = c("ctb", "cph"),
@@ -59,35 +60,42 @@ Description: Makes it incredibly easy to build interactive web
     beautiful, responsive, and powerful applications with minimal effort.
 License: GPL-3 | file LICENSE
 Depends:
-    R (>= 3.0.0)
+    R (>= 3.0.0),
+    methods
 Imports:
     utils,
-    httpuv (>= 1.3.2),
+    httpuv (>= 1.3.3),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.2.6),
-    R6 (>= 2.0)
+    htmltools (>= 0.3.5),
+    R6 (>= 2.0),
+    sourcetools
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
     testthat,
     knitr (>= 1.6),
     markdown,
+    rmarkdown,
     ggplot2
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     'app.R'
+    'bookmark-state-local.R'
+    'stack.R'
+    'bookmark-state.R'
     'bootstrap-layout.R'
+    'conditions.R'
     'map.R'
     'globals.R'
     'utils.R'
     'bootstrap.R'
     'cache.R'
+    'diagnose.R'
     'fileupload.R'
-    'stack.R'
     'graph.R'
     'hooks.R'
     'html-deps.R'
@@ -95,22 +103,45 @@ Collate:
     'image-interact-opts.R'
     'image-interact.R'
     'imageutils.R'
+    'input-action.R'
+    'input-checkbox.R'
+    'input-checkboxgroup.R'
+    'input-date.R'
+    'input-daterange.R'
+    'input-file.R'
+    'input-numeric.R'
+    'input-password.R'
+    'input-radiobuttons.R'
+    'input-select.R'
+    'input-slider.R'
+    'input-submit.R'
+    'input-text.R'
+    'input-textarea.R'
+    'input-utils.R'
+    'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
     'middleware.R'
+    'modal.R'
+    'modules.R'
+    'notifications.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
     'reactive-domains.R'
     'reactives.R'
     'render-plot.R'
+    'render-table.R'
     'run-url.R'
+    'serializers.R'
+    'server-input-handlers.R'
     'server.R'
+    'shiny-options.R'
     'shiny.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
-    'slider.R'
     'tar.R'
     'timer.R'
     'update-input.R'
+RoxygenNote: 5.0.1

LICENSE

@@ -1,7 +1,7 @@
 The shiny package as a whole is distributed under GPL-3 (GNU GENERAL PUBLIC
 LICENSE version 3).
 
-The shiny package inludes other open source software components. The following
+The shiny package includes other open source software components. The following
 is a list of these components (full copies of the license agreements used by
 these components are included below):
 
@@ -15,6 +15,7 @@ these components are included below):
 - selectize.js, https://github.com/brianreavis/selectize.js
 - es5-shim, https://github.com/es-shims/es5-shim
 - ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
+- strftime for Javascript, https://github.com/samsonjs/strftime
 - DataTables, https://github.com/DataTables/DataTables
 - showdown.js, https://github.com/showdownjs/showdown
 - highlight.js, https://github.com/isagalaev/highlight.js
@@ -1051,6 +1052,31 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 SOFTWARE.
 
 
+strftime for Javascript License
+----------------------------------------------------------------------
+
+The MIT License (MIT)
+Copyright © 2015 Sami Samhuri, http://samhuri.net <sami@samhuri.net>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the “Software”), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+
 DataTables License
 ----------------------------------------------------------------------
 

NAMESPACE

@@ -1,14 +1,17 @@
-# Generated by roxygen2 (4.1.1): do not edit by hand
+# Generated by roxygen2: do not edit by hand
 
 S3method("$",reactivevalues)
+S3method("$",session_proxy)
 S3method("$",shinyoutput)
 S3method("$<-",reactivevalues)
+S3method("$<-",session_proxy)
 S3method("$<-",shinyoutput)
 S3method("[",reactivevalues)
 S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
 S3method("[<-",shinyoutput)
 S3method("[[",reactivevalues)
+S3method("[[",session_proxy)
 S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
 S3method("[[<-",shinyoutput)
@@ -23,7 +26,11 @@ S3method(names,reactivevalues)
 S3method(print,reactive)
 S3method(print,shiny.appobj)
 S3method(str,reactivevalues)
+export("conditionStackTrace<-")
+export(..stacktraceoff..)
+export(..stacktraceon..)
 export(HTML)
+export(NS)
 export(Progress)
 export(a)
 export(absolutePanel)
@@ -33,36 +40,51 @@ export(addResourcePath)
 export(animationOptions)
 export(as.shiny.appobj)
 export(basicPage)
+export(bookmarkButton)
+export(bootstrapLib)
 export(bootstrapPage)
 export(br)
+export(browserViewer)
 export(brushOpts)
 export(brushedPoints)
+export(callModule)
+export(captureStackTraces)
 export(checkboxGroupInput)
 export(checkboxInput)
 export(clickOpts)
 export(code)
 export(column)
+export(conditionStackTrace)
 export(conditionalPanel)
 export(createWebDependency)
 export(dataTableOutput)
 export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
+export(dialogViewer)
 export(div)
 export(downloadButton)
 export(downloadHandler)
 export(downloadLink)
 export(em)
+export(enableBookmarking)
 export(eventReactive)
 export(exprToFunction)
+export(extractStackTrace)
 export(fileInput)
+export(fillCol)
+export(fillPage)
+export(fillRow)
 export(fixedPage)
 export(fixedPanel)
 export(fixedRow)
 export(flowLayout)
 export(fluidPage)
 export(fluidRow)
+export(formatStackTrace)
+export(freezeReactiveValue)
 export(getDefaultReactiveDomain)
+export(getShinyOption)
 export(h1)
 export(h2)
 export(h3)
@@ -74,6 +96,7 @@ export(helpText)
 export(hoverOpts)
 export(hr)
 export(htmlOutput)
+export(htmlTemplate)
 export(icon)
 export(imageOutput)
 export(img)
@@ -84,14 +107,17 @@ 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)
 export(knit_print.shiny.appobj)
 export(knit_print.shiny.render.function)
 export(knit_print.shiny.tag)
@@ -100,23 +126,36 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
+export(modalButton)
+export(modalDialog)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
 export(nearPoints)
 export(need)
+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)
+export(paneViewer)
 export(parseQueryString)
 export(passwordInput)
 export(plotOutput)
 export(plotPNG)
 export(pre)
+export(printError)
+export(printStackTrace)
 export(radioButtons)
 export(reactive)
 export(reactiveFileReader)
@@ -131,6 +170,9 @@ export(reactiveValues)
 export(reactiveValuesToList)
 export(registerInputHandler)
 export(removeInputHandler)
+export(removeModal)
+export(removeNotification)
+export(removeUI)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -139,19 +181,29 @@ export(renderTable)
 export(renderText)
 export(renderUI)
 export(repeatable)
+export(req)
+export(restoreInput)
 export(runApp)
 export(runExample)
+export(runGadget)
 export(runGist)
 export(runGitHub)
 export(runUrl)
+export(safeError)
 export(selectInput)
 export(selectizeInput)
 export(serverInfo)
+export(setBookmarkExclude)
 export(setProgress)
 export(shinyApp)
 export(shinyAppDir)
+export(shinyAppFile)
+export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
+export(showBookmarkUrlModal)
+export(showModal)
+export(showNotification)
 export(showReactLog)
 export(sidebarLayout)
 export(sidebarPanel)
@@ -162,6 +214,7 @@ export(splitLayout)
 export(stopApp)
 export(strong)
 export(submitButton)
+export(suppressDependencies)
 export(tabPanel)
 export(tableOutput)
 export(tabsetPanel)
@@ -172,26 +225,34 @@ export(tagAppendChildren)
 export(tagList)
 export(tagSetChildren)
 export(tags)
+export(textAreaInput)
 export(textInput)
 export(textOutput)
 export(titlePanel)
 export(uiOutput)
+export(updateActionButton)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
 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)
 export(verticalLayout)
 export(wellPanel)
+export(withLogErrors)
 export(withMathJax)
 export(withProgress)
 export(withReactiveDomain)
@@ -200,5 +261,6 @@ import(R6)
 import(digest)
 import(htmltools)
 import(httpuv)
+import(methods)
 import(mime)
 import(xtable)

NEWS

@@ -1,828 +0,0 @@
-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!

NEWS.md

@@ -0,0 +1,972 @@
+shiny 0.14
+=================
+
+A new Shiny release is upon us! There are many new exciting features, bug fixes, and library updates. We'll just highlight the most important changes here, but you can browse through the full changelog below for details. This will likely be the last release before shiny 1.0, so get out your party hats!
+
+## Bookmarkable state
+
+Shiny now supports bookmarkable state: users can save the state of an application and get a URL which will restore the application with that state. There are two types of bookmarking: encoding the state in a URL, and saving the state to the server. With an encoded state, the entire state of the application is contained in the URL’s query string. You can see this in action with this app: https://gallery.shinyapps.io/113-bookmarking-url/. An example of a bookmark URL for this app is https://gallery.shinyapps.io/113-bookmarking-url/?_inputs_&n=200. When the state is saved to the server, the URL might look something like: https://gallery.shinyapps.io/bookmark-saved/?_state_id_=d80625dc681e913a (note that this URL is not for an active app).
+
+**_Important note_:**
+> Saved-to-server bookmarking currently works with Shiny Server Open Source. Support on Shiny Server Pro, RStudio Connect, and shinyapps.io is under development and testing. However, URL-encoded bookmarking works on all hosting platforms.
+
+See [this article](http://shiny.rstudio-staging.com/articles/bookmarking-state.html) to get started with bookmarkable state. There is also an [advanced-level article](http://shiny.rstudio-staging.com/articles/advanced-bookmarking.html) (for apps that have a complex state), and [a modules article](http://shiny.rstudio-staging.com/articles/bookmarking-modules.html) that details how to use bookmarking in conjunction with modules.
+
+## Notifications
+
+Shiny can now display notifications on the client browser by using the `showNotification()` function. Use [this demo app](https://gallery.shinyapps.io/116-notifications/) to play around with the notification API. Here's a screenshot of a very simple notification (shown when the button is clicked):
+
+<p align="center">
+<img src="http://shiny.rstudio-staging.com/images/notification.png" alt="notification" width="50%"/>
+</p>
+
+[Here](http://shiny.rstudio-staging.com/articles/notifications.html)'s our article about it, and the [reference documentation](http://shiny.rstudio-staging.com/reference/shiny/latest/showNotification.html).
+
+## Progress indicators
+
+If your Shiny app contains computations that take a long time to complete, a progress bar can improve the user experience by communicating how far along the computation is, and how much is left. Progress bars were added in Shiny 0.10.2. In Shiny 0.14, they were changed to use the notifications system, which gives them a different look.
+
+**_Important note_:**
+> If you were already using progress bars and had customized them with your own CSS, you can add the `style = "old"` argument to your `withProgress()` call (or `Progress$new()`). This will result in the same appearance as before. You can also call `shinyOptions(progress.style = "old")` in your app's server function to make all progress indicators use the old styling.
+
+To see new progress bars in action, see [this app](https://gallery.shinyapps.io/085-progress/) in the gallery. You can also learn more about this in [our article](http://shiny.rstudio-staging.com/articles/progress.html) and in the reference documentation (either for the easier [`withProgress` functional API](http://shiny.rstudio-staging.com/reference/shiny/latest/withProgress.html) or the more complicated, but more powerful, [`Progress` object-oriented API](http://shiny.rstudio-staging.com/reference/shiny/latest/Progress.html).
+
+## Reconnection
+
+Shiny can now automatically reconnect to your Shiny session if you temporarily lose network access.
+
+## Modal windows
+
+Shiny has now built-in support for displaying modal dialogs like the one below ([live app here](https://gallery.shinyapps.io/114-modal-dialog/)):
+
+<p align="center">
+<img src="http://shiny.rstudio-staging.com/images/modal-dialog.png" alt="modal-dialog" width="50%"/>
+</p>
+
+To learn more about this, read [our article](http://shiny.rstudio-staging.com/articles/modal-dialogs.html) and the [reference documentation](http://shiny.rstudio-staging.com/reference/shiny/latest/modalDialog.html).
+
+## `insertUI` and `removeUI`
+
+Sometimes in a Shiny app, arbitrary HTML UI may need to be created on-the-fly in response to user input. The existing `uiOutput` and `renderUI` functions let you continue using reactive logic to call UI functions and make the results appear in a predetermined place in the UI. The `insertUI` and `removeUI` functions, which are used in the server code, allow you to use imperative logic to add and remove arbitrary chunks of HTML (all independent from one another), as many times as you want, whenever you want, wherever you want. This option may be more convenient when you want to, for example, add a new model to your app each time the user selects a different option (and leave previous models unchanged, rather than substitute the previous one for the latest one).
+
+See [this simple demo app](https://gallery.shinyapps.io/111-insert-ui/) of how one could use `insertUI` and `removeUI` to insert and remove text elements using a queue. Also see [this other app](https://gallery.shinyapps.io/insertUI/) that demonstrates how to insert and remove a few common Shiny input objects. Finally, [this app](https://gallery.shinyapps.io/insertUI-modules/) shows how to dynamically insert modules using `insertUI`.
+
+For more, read [our article](http://shiny.rstudio-staging.com/articles/dynamic-ui.html) about dynamic UI generation and the reference documentation about [`insertUI`](http://shiny.rstudio-staging.com/reference/shiny/latest/insertUI.html) and [`removeUI`](http://shiny.rstudio-staging.com/reference/shiny/latest/removeUI.html).
+
+## Documentation for connecting to an external database
+
+Many Shiny users have asked about best practices for accessing external databases from their Shiny applications. Although database access has long been possible using various database connector packages in R, it can be challenging to use them robustly in the dynamic environment that Shiny provides. So far, it has been mostly up to application authors to find the appropriate database drivers and to discover how to manage the database connections within an application. In order to demystify this process, we wrote a series of articles ([first one here](http://shiny.rstudio-staging.com/articles/overview.html)) that covers the basics of connecting to an external database, as well as some security precautions to keep in mind (e.g. [how to avoid SQL injection attacks](http://shiny.rstudio-staging.com/articles/sql-injections.html)).
+
+There are a few packages that you should look at if you're using a relational database in a Shiny app: the `dplyr` and `DBI` packages (both featured in the article linked to above), and the brand new `pool` package, which provides a further layer of abstraction to make it easier and safer to use either `DBI` or `dplyr`. `pool` is not yet on CRAN. In particular, `pool` will take care of managing connections, preventing memory leaks, and ensuring the best performance. See this [`pool` basics article](http://shiny.rstudio-staging.com/articles/pool-basics.html) and the [more advanced-level article](http://shiny.rstudio-staging.com/articles/pool-advanced.html) if you're feeling adventurous! (Both of these articles contain Shiny app examples that use `DBI` to connect to an external MySQL database.) If you are more comfortable with `dplyr` than `DBI`, don't miss the article about the [integration of `pool` and `dplyr`](http://shiny.rstudio-staging.com/articles/pool-dplyr.html).
+
+If you're new to databases in the Shiny world, we recommend using `dplyr` and `pool` if possible. If you need greater control than `dplyr` offers (for example, if you need to modify data in the database or use transactions), then use `DBI` and `pool`. The `pool` package was introduced to make your life easier, but in no way constrains you, so we don't envision any situation in which you'd be better off *not* using it. The only caveat is that `pool` is not yet on CRAN, so you may prefer to wait for that.
+
+## Others
+
+There are many more minor features, small improvements, and bug fixes than we can cover here, so we'll just mention a few of the more noteworthy ones (the full changelog, with links to all the relevant issues and pull requests, is right below this section):
+
+*    **Error Sanitization**: you now have the option to sanitize error messages; in other words, the content of the original error message can be suppressed so that it doesn't leak any sensitive information. To sanitize errors everywhere in your app, just add `options(shiny.sanitize.errors = TRUE)` somewhere in your app. Read [this article](http://shiny.rstudio-staging.com/articles/sanitize-errors.html) for more, or play with the [demo app](https://gallery.shinyapps.io/110-error-sanitization/).
+
+*    **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. ([#1126](https://github.com/rstudio/shiny/pull/1126))
+
+*    **Reactlog visualization**: by default, the [`showReactLog()` function](http://shiny.rstudio-staging.com/reference/shiny/latest/showReactLog.html) (which brings up the reactive graph) also displays the time that each reactive and observer were active for:
+
+      <p align="center">
+      <img src="http://shiny.rstudio-staging.com/images/reactlog.png" alt="modal-dialog" width="75%"/>
+      </p>
+
+      This new feature can be turned off with `showReactLog(time = FALSE)`. This may be convenient if you have a large graph and don't want to have this new information cluttering it up. The elapsed time info shows up above each relevant node's label, and the time is also coded by color: the slowest reactive will be dark red and the fastest will be light red.
+
+      Additionally, to organize the graph, you can now drag any of the nodes to a specific position and leave it there.
+
+*    **Nicer-looking tables**: we've made tables generated with `renderTable()` look cleaner and more modern. While this won't break any older code, the finished look of your table will be quite a bit different, as the following image shows:
+
+      <p align="center">
+      <img src="http://shiny.rstudio-staging.com/images/render-table.png" alt="render-table" width="75%"/>
+      </p>
+
+      For more, read our [short article](http://shiny.rstudio-staging.com/articles/render-table.html) about this update, experiment with all the new features in this [demo app](https://gallery.shinyapps.io/109-render-table/), or check out the [reference documentation](http://shiny.rstudio-staging.com/reference/shiny/latest/renderTable.html).
+
+## Full changelog
+
+### Breaking changes
+
+* Progress indicators can now either use the new notification API, using `style = "notification"` (default), or be displayed with the previous styling, using `style = "old"`. You can also call `shinyOptions(progress.style = "old")` in the server function to make all progress indicators use the old styling. Note that if you had customized your progress indicators with additional CSS, you'll need to use the old style if you want your UI to look the same ([#1160](https://github.com/rstudio/shiny/pull/1160) and [#1329](https://github.com/rstudio/shiny/pull/1329)).
+
+* Closed [#1161](https://github.com/rstudio/shiny/issues/1161): Deprecated the `position` argument to `tabsetPanel()` since Bootstrap 3 stopped supporting this feature.
+
+* The long-deprecated ability to pass a `func` argument to many of the `render` functions has been removed.
+
+### New features
+
+* Added the ability to bookmark and restore application state. (main PR: [#1209](https://github.com/rstudio/shiny/pull/1209))
+
+* Added a new notification API. From R, there are new functions `showNotification` and `hideNotification`. From JavaScript, there is a new `Shiny.notification` object that controls notifications. ([#1141](https://github.com/rstudio/shiny/pull/1141))
+
+* Progress indicators now use the notification API. ([#1160](https://github.com/rstudio/shiny/pull/1160))
+
+* 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](https://github.com/rstudio/shiny/pull/1074))
+
+* Added modal dialogs. ([#1157](https://github.com/rstudio/shiny/pull/1157))
+
+* Added insertUI and removeUI functions to be able to add and remove chunks of UI, standalone, and all independent of one another. ([#1174](https://github.com/rstudio/shiny/pull/1174) and [#1189](https://github.com/rstudio/shiny/pull/1189))
+
+* Improved `renderTable()` function to make the tables look prettier and also provide the user with a lot more parameters to customize their tables with. ([#1129](https://github.com/rstudio/shiny/pull/1129))
+
+* Added support for the `pool` package (use Shiny's timer/scheduler). ([#1226](https://github.com/rstudio/shiny/pull/1226))
+
+### Minor new features and improvements
+
+* Added `cancelOutput` argument to `req()`. This causes the currently executing reactive to cancel its execution, and leave its previous state alone (as opposed to clearing the output). ([#1272](https://github.com/rstudio/shiny/pull/1272))
+
+* `Display: Showcase` now displays the .js, .html and .css files in the `www` directory by default. In order to use showcase mode and not display these, include a new line in your Description file: `IncludeWWW: False`. ([#1185](https://github.com/rstudio/shiny/pull/1185))
+
+* Added an error sanitization option: `options(shiny.sanitize.errors = TRUE)`. By default, this option is `FALSE`. When `TRUE`, normal errors will be sanitized, displaying only a generic error message. This changes the look of an app when errors are printed (but the console log remains the same). ([#1156](https://github.com/rstudio/shiny/pull/1156))
+
+* Added the option of passing arguments to an `xxxOutput()` function through the corresponding `renderXXX()` function via an `outputArgs` parameter to the latter. This is only valid for snippets of Shiny code in an interactive `runtime: shiny` Rmd document (never for full apps, even if embedded in an Rmd). ([#1443](https://github.com/rstudio/shiny/pull/1143))
+
+* Added `updateActionButton()` function, so the user can change an `actionButton`'s (or `actionLink`'s) label and/or icon. It also checks that the icon argument (for both creation and updating of a button) is valid and throws a warning otherwise. ([#1134](https://github.com/rstudio/shiny/pull/1134))
+
+* 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. ([#1126](https://github.com/rstudio/shiny/pull/1126))
+
+* Added support for horizontal dividers in `navbarMenu`. ([#1147](https://github.com/rstudio/shiny/pull/1147))
+
+* Added `placeholder` option to `passwordInput`. ([#1152](https://github.com/rstudio/shiny/pull/1152))
+
+* Added `session$resetBrush(brushId)` (R) and `Shiny.resetBrush(brushId)` (JS) to programatically clear brushes from `imageOutput`/`plotOutput`. ([#1197](https://github.com/rstudio/shiny/pull/1197))
+
+* Added textAreaInput. (thanks, [@nuno-agostinho](https://github.com/nuno-agostinho)! [#1300](https://github.com/rstudio/shiny/pull/1300))
+
+* Added `session$sendBinaryMessage(type, message)` method for sending custom binary data to the client. See `?session`. (thanks, [@daef](https://github.com/daef)! [#1316](https://github.com/rstudio/shiny/pull/1316) and [#1320](https://github.com/rstudio/shiny/pull/1320))
+
+* Almost all code examples now have a runnable example with `shinyApp()`, so that users can run the examples and see them in action. ([#1158](https://github.com/rstudio/shiny/pull/1158))
+
+* When resized, plots are drawn with `replayPlot()`, instead of re-executing all plotting code. This results in faster plot rendering. ([#1112](https://github.com/rstudio/shiny/pull/1112))
+
+* Exported the `isTruthy()` function. (part of PR [#1272](https://github.com/rstudio/shiny/pull/1272))
+
+* Reactive log now shows elapsed time for reactives and observers. ([#1132](https://github.com/rstudio/shiny/pull/1132))
+
+* Nodes in the reactlog visualization are now sticky if the user drags them. ([#1283](https://github.com/rstudio/shiny/pull/1283))
+
+### Bug fixes
+
+* Fixed [#1350](https://github.com/rstudio/shiny/issues/1350): Highlighting of reactives didn't work in showcase mode.
+
+* Fixed [#1331](https://github.com/rstudio/shiny/issues/1331): `renderPlot()` now correctly records and replays plots when `execOnResize = FALSE`.
+
+* `updateDateInput()` and `updateDateRangeInput()` can now clear the date input fields. (thanks, [@gaborcsardi](https://github.com/gaborcsardi)! [#1299](https://github.com/rstudio/shiny/pull/1299), [#1315](https://github.com/rstudio/shiny/pull/1315) and  [#1317](https://github.com/rstudio/shiny/pull/1317))
+
+* Fixed [#561](https://github.com/rstudio/shiny/issues/561): DataTables previously might pop up a warning when the data was updated extremely frequently.
+
+* Fixed [#776](https://github.com/rstudio/shiny/issues/776): In some browsers, plots sometimes flickered when updated.
+
+* Fixed [#543](https://github.com/rstudio/shiny/issues/543) and [#855](https://github.com/rstudio/shiny/issues/855): When `navbarPage()` had a `navbarMenu()` as the first item, it did not automatically select an item.
+
+* Fixed [#970](https://github.com/rstudio/shiny/issues/970): `navbarPage()` previously did not have an option to set the selected tab.
+
+* Fixed [#1253](https://github.com/rstudio/shiny/issues/1253): Memory could leak when an observer was destroyed without first being invalidated.
+
+* Fixed [#931](https://github.com/rstudio/shiny/issues/931): Nested observers could leak memory.
+
+* Fixed [#1144](https://github.com/rstudio/shiny/issues/1144): `updateRadioButton()` and `updateCheckboxGroupInput()` broke controls when used in modules (thanks, [@sipemu](https://github.com/sipemu)!).
+
+* Fixed [#1093](https://github.com/rstudio/shiny/issues/1093): `updateRadioButtons()` and `updateCheckboxGroupInput()` didn't work if `choices` was numeric vector.
+
+* Fixed [#1122](https://github.com/rstudio/shiny/issues/1122): `downloadHandler()` popped up empty browser window if the file wasn't present. It now gives a 404 error code.
+
+* Fixed [#1278](https://github.com/rstudio/shiny/issues/1278): Reactive system was being flushed too often (usually this just means a more-expensive no-op than necessary).
+
+* Fixed [#803](https://github.com/rstudio/shiny/issues/803) and [#1179](https://github.com/rstudio/shiny/issues/1179): handling malformed dates in `dateInput` and `updateDateInput()`.
+
+* Fixed [#1257](https://github.com/rstudio/shiny/issues/1257): `updateSelectInput()` didn't work correctly in IE 11 and Edge.
+
+* Fixed [#971](https://github.com/rstudio/shiny/issues/971): `runApp()` would give confusing error if `port` was not numeric.
+
+* Shiny now avoids using ports that Chrome deems unsafe. ([#1222](https://github.com/rstudio/shiny/pull/1222))
+
+* Added workaround for quartz graphics device resolution bug, where resolution is hard-coded to 72 ppi.
+
+### Library updates
+
+* Updated to ion.RangeSlider 2.1.2.
+
+* Updated to Font Awesome 4.6.3.
+
+* Updated to Bootstrap 3.3.7.
+
+* Updated to jQuery 1.12.4.
+
+
+shiny 0.13.2
+============
+
+* Updated documentation for `htmlTemplate`.
+
+
+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.
+
+* Upgraded to jQuery 1.12.4
+
+* 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
+============
+
+In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps. 
+
+### JSON serialization
+
+In Shiny 0.12.0, we've switched from RJSONIO to jsonlite. For the vast majority of users, this will result in no noticeable changes; however, if you use any packages in your Shiny apps which rely on the [htmlwidgets](http://www.htmlwidgets.org/), you will also need to update htmlwidgets to 0.4.0. Both of these packages will issue a message when loaded, if the other package needs to be upgraded.
+
+POSIXt objects are now serialized to JSON in UTC8601 format (like
+"2015-03-20T20:00:00Z"), instead of as seconds from the epoch. If you have a Shiny app which uses `sendCustomMessage()` to send datetime (POSIXt) objects, then you may need to modify your Javascript code to receive time data in this format.
+
+### A note about Data Tables
+
+Shiny 0.12.0 deprecated Shiny's dataTableOutput and renderDataTable functions and instructed you to migrate to the nascent [DT](https://rstudio.github.io/DT/) package instead. (We'll talk more about DT in a future blog post.) User feedback has indicated this transition was too sudden and abrupt, so we've undeprecated these functions in 0.12.1. We'll continue to support these functions until DT has had more time to mature.
+
+## Full Changelog
+
+* 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
+==========
+
+Shiny 0.11 switches away from the Bootstrap 2 web framework to the next version, Bootstrap 3. This is in part because Bootstrap 2 is no longer being developed, and in part because it allows us to tap into the ecosystem of Bootstrap 3 themes.
+
+
+### Known issues for migration
+
+*    In Bootstrap 3, images in `<img>` tags are no longer automatically scaled to the width of their container. If you use `img()` in your UI code, or `<img>` tags in your raw HTML source, it's possible that they will be too large in the new version of Shiny. To address this you can add the `img-responsive` class:
+    
+    ```r
+    img(src = "picture.png", class = "img-responsive")
+    ```
+    
+    The R code above will generate the following HTML:
+    
+    ```html
+    <img src="picture.png" class="img-responsive">
+    ```
+
+
+*    The sliders have been replaced. Previously, Shiny used the [jslider](https://github.com/egorkhmelev/jslider) library, but now it uses [ion.RangeSlider](https://github.com/IonDen/ion.rangeSlider). The new sliders have an updated appearance, and they have allowed us to fix many long-standing interface issues with the sliders.
+
+  * The `sliderInput()` function no longer uses the `format` or `locale` options. Instead, you can use `pre`, `post`, and `sep` options to control the prefix, postfix, and thousands separator.
+
+
+  * `updateSliderInput()` can now control the min, max, value, and step size of a slider. Previously, only the value could be controlled this way, and if you wanted to change other values, you needed to use Shiny's dynamic UI.
+
+
+*    If in your HTML you are using custom CSS classes that are specific to Bootstrap, you may need to update them for Bootstrap 3. See the Bootstrap [migration guide](http://getbootstrap.com/migration/).
+
+
+If you encounter other migration issues, please let us know on the [shiny-discuss](https://groups.google.com/forum/#!forum/shiny-discuss) mailing list, or on the Shiny [issue tracker](https://github.com/rstudio/shiny/issues).
+
+### Using shinybootstrap2
+
+If you would like to use Shiny 0.11 with Bootstrap 2, you can use the **shinybootstrap2** package. Installation and usage instructions are on available on the [project page](https://github.com/rstudio/shinybootstrap2). We recommend that you do this only as a temporary solution because  future development on Shiny will use Bootstrap 3.
+
+### Installing an older version of Shiny
+
+If you want to install a specific version of Shiny other than the latest CRAN release, you can use the `install_version()` function from devtools:
+
+```r
+# Install devtools if you don't already have it:
+install.package("devtools")
+
+# Install the last version of Shiny prior to 0.11
+devtools::install_version("shiny", "0.10.2.2")
+```
+
+### Themes
+
+Along with the release of Shiny 0.11, we've packaged up some Bootstrap 3 themes in the [shinythemes](http://rstudio.github.io/shinythemes/) package. This package makes it easy to use Bootstrap themes with Shiny.
+
+## Full Changelog
+
+* 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 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"
   )
 }
@@ -91,7 +108,7 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
 #'   file and either ui.R or www/index.html)
 #' @export
 shinyAppDir <- function(appDir, options=list()) {
-  if (!file_test('-d', appDir)) {
+  if (!utils::file_test('-d', appDir)) {
     stop("No Shiny application exists at the path \"", appDir, "\"")
   }
 
@@ -102,12 +119,22 @@ shinyAppDir <- function(appDir, options=list()) {
   if (file.exists.ci(appDir, "server.R")) {
     shinyAppDir_serverR(appDir, options = options)
   } else if (file.exists.ci(appDir, "app.R")) {
-    shinyAppDir_appR(appDir, options = options)
+    shinyAppDir_appR("app.R", appDir, options = options)
   } else {
     stop("App dir must contain either app.R or server.R.")
   }
 }
 
+#' @rdname shinyApp
+#' @param appFile Path to a .R file containing a Shiny application
+#' @export
+shinyAppFile <- function(appFile, options=list()) {
+  appFile <- normalizePath(appFile, mustWork = TRUE)
+  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)
 # present, and returns a shiny.appobj.
 shinyAppDir_serverR <- function(appDir, options=list()) {
@@ -124,7 +151,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
         # If not, then take the last expression that's returned from ui.R.
         .globals$ui <- NULL
         on.exit(.globals$ui <- NULL, add = FALSE)
-        ui <- sourceUTF8(uiR, local = new.env(parent = globalenv()))$value
+        ui <- sourceUTF8(uiR, envir = new.env(parent = globalenv()))
         if (!is.null(.globals$ui)) {
           ui <- .globals$ui[[1]]
         }
@@ -147,7 +174,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       # server.R.
       .globals$server <- NULL
       on.exit(.globals$server <- NULL, add = TRUE)
-      result <- sourceUTF8(serverR, local = new.env(parent = globalenv()))$value
+      result <- sourceUTF8(serverR, envir = new.env(parent = globalenv()))
       if (!is.null(.globals$server)) {
         result <- .globals$server[[1]]
       }
@@ -170,15 +197,21 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     }
   }
 
+  shinyOptions(appDir = appDir)
+
   oldwd <- NULL
+  monitorHandle <- NULL
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
+    monitorHandle <<- initAutoReloadMonitor(appDir)
     if (file.exists(file.path.ci(appDir, "global.R")))
       sourceUTF8(file.path.ci(appDir, "global.R"))
   }
   onEnd <- function() {
     setwd(oldwd)
+    monitorHandle()
+    monitorHandle <<- NULL
   }
 
   structure(
@@ -187,26 +220,76 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       serverFuncSource = serverFuncSource,
       onStart = onStart,
       onEnd = onEnd,
-      options = options),
+      options = options
+    ),
     class = "shiny.appobj"
   )
 }
 
-# This reads in an app dir in the case that there's a app.R present, and returns
-# a shiny.appobj.
-shinyAppDir_appR <- function(appDir, options=list()) {
-  fullpath <- file.path.ci(appDir, "app.R")
+# Start a reactive observer that continually monitors dir for changes to files
+# that have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. Case is
+# 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
+# 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"))
+#
+# The return value is a function that halts monitoring when called.
+initAutoReloadMonitor <- function(dir) {
+  if (!getOption("shiny.autoreload", FALSE)) {
+    return(function(){})
+  }
+
+  filePattern <- getOption("shiny.autoreload.pattern",
+    ".*\\.(r|html?|js|css|png|jpe?g|gif)$")
+
+  lastValue <- NULL
+  obs <- observe({
+    files <- sort(list.files(dir, pattern = filePattern, recursive = TRUE,
+      ignore.case = TRUE))
+    times <- file.info(files)$mtime
+    names(times) <- files
+
+    if (is.null(lastValue)) {
+      # First run
+      lastValue <<- times
+    } else if (!identical(lastValue, times)) {
+      # We've changed!
+      lastValue <<- times
+      for (session in appsByToken$values()) {
+        session$reload()
+      }
+    }
+
+    invalidateLater(getOption("shiny.autoreload.interval", 500))
+  })
+
+  obs$destroy
+}
+
+# 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())
+{
+  fullpath <- file.path.ci(appDir, fileName)
 
   # This sources app.R and caches the content. When appObj() is called but
   # app.R hasn't changed, it won't re-source the file. But if called and
   # app.R has changed, it'll re-source the file and return the result.
-  appObj <- cachedFuncWithFile(appDir, "app.R", case.sensitive = FALSE,
+  appObj <- cachedFuncWithFile(appDir, fileName, case.sensitive = FALSE,
     function(appR) {
-      result <- sourceUTF8(fullpath, local = new.env(parent = globalenv()))$value
+      result <- sourceUTF8(fullpath, envir = new.env(parent = globalenv()))
 
       if (!is.shiny.appobj(result))
         stop("app.R did not return a shiny.appobj object.")
 
+      unconsumeAppOptions(result$appOptions)
+
       return(result)
     }
   )
@@ -225,12 +308,16 @@ shinyAppDir_appR <- function(appDir, options=list()) {
   fallbackWWWDir <- system.file("www-dir", package = "shiny")
 
   oldwd <- NULL
+  monitorHandle <- NULL
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
+    monitorHandle <<- initAutoReloadMonitor(appDir)
   }
   onEnd <- function() {
     setwd(oldwd)
+    monitorHandle()
+    monitorHandle <<- NULL
   }
 
   structure(
@@ -268,7 +355,10 @@ as.shiny.appobj.list <- function(x) {
 #' @rdname shinyApp
 #' @export
 as.shiny.appobj.character <- function(x) {
-  shinyAppDir(x)
+  if (identical(tolower(tools::file_ext(x)), "r"))
+    shinyAppFile(x)
+  else
+    shinyAppDir(x)
 }
 
 #' @rdname shinyApp
@@ -302,7 +392,20 @@ as.tags.shiny.appobj <- function(x, ...) {
   height <- if (is.null(opts$height)) "400" else opts$height
 
   path <- addSubApp(x)
-  tags$iframe(src=path, width=width, height=height, class="shiny-frame")
+  deferredIFrame(path, width, height)
+}
+
+# Generate subapp iframes in such a way that they will not actually load right
+# away. Loading subapps immediately upon app load can result in a storm of
+# connections, all of which are contending for the few concurrent connections
+# that a browser will make to a specific origin. Instead, we load dummy iframes
+# and let the client load them when convenient. (See the initIframes function in
+# init_shiny.js.)
+deferredIFrame <- function(path, width, height) {
+  tags$iframe("data-deferred-src" = path,
+    width = width, height = height,
+    class = "shiny-frame shiny-frame-deferred"
+  )
 }
 
 #' Knitr S3 methods
@@ -353,8 +456,7 @@ knit_print.shiny.appobj <- function(x, ...) {
   }
   else {
     path <- addSubApp(x)
-    output <- tags$iframe(src=path, width=width, height=height,
-                          class="shiny-frame")
+    output <- deferredIFrame(path, width, height)
   }
 
   # If embedded Shiny apps ever have JS/CSS dependencies (like pym.js) we'll
@@ -378,3 +480,14 @@ knit_print.shiny.render.function <- function(x, ..., inline = FALSE) {
                                       shiny_rmd_warning())
   output
 }
+
+# Lets us drop reactive expressions directly into a knitr chunk and have the
+# value printed out! Nice for teaching if nothing else.
+#' @rdname knitr_methods
+#' @export
+knit_print.reactive <- function(x, ..., inline = FALSE) {
+  renderFunc <- if (inline) renderText else renderPrint
+  knitr::knit_print(renderFunc({
+    x()
+  }), inline = inline)
+}

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()) {
 
@@ -417,3 +502,193 @@ splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
     }, SIMPLIFY = FALSE)
   ))
 }
+
+#' Flex Box-based row/column layouts
+#'
+#' Creates row and column layouts with proportionally-sized cells, using the
+#' Flex Box layout model of CSS3. These can be nested to create arbitrary
+#' proportional-grid layouts. \strong{Warning:} Flex Box is not well supported
+#' by Internet Explorer, so these functions should only be used where modern
+#' browsers can be assumed.
+#'
+#' @details If you try to use \code{fillRow} and \code{fillCol} inside of other
+#'   Shiny containers, such as \code{\link{sidebarLayout}},
+#'   \code{\link{navbarPage}}, or even \code{tags$div}, you will probably find
+#'   that they will not appear. This is due to \code{fillRow} and \code{fillCol}
+#'   defaulting to \code{height="100\%"}, which will only work inside of
+#'   containers that have determined their own size (rather than shrinking to
+#'   the size of their contents, as is usually the case in HTML).
+#'
+#'   To avoid this problem, you have two options:
+#'   \itemize{
+#'     \item only use \code{fillRow}/\code{fillCol} inside of \code{fillPage},
+#'       \code{fillRow}, or \code{fillCol}
+#'     \item provide an explicit \code{height} argument to
+#'       \code{fillRow}/\code{fillCol}
+#'   }
+#'
+#' @param ... UI objects to put in each row/column cell; each argument will
+#'   occupy a single cell. (To put multiple items in a single cell, you can use
+#'   \code{\link{tagList}} or \code{\link{div}} to combine them.) Named
+#'   arguments will be used as attributes on the \code{div} element that
+#'   encapsulates the row/column.
+#' @param flex Determines how space should be distributed to the cells. Can be a
+#'   single value like \code{1} or \code{2} to evenly distribute the available
+#'   space; or use a vector of numbers to specify the proportions. For example,
+#'   \code{flex = c(2, 3)} would cause the space to be split 40\%/60\% between
+#'   two cells. NA values will cause the corresponding cell to be sized
+#'   according to its contents (without growing or shrinking).
+#' @param width,height The total amount of width and height to use for the
+#'   entire row/column. For the default height of \code{"100\%"} to be
+#'   effective, the parent must be \code{fillPage}, another
+#'   \code{fillRow}/\code{fillCol}, or some other HTML element whose height is
+#'   not determined by the height of its contents.
+#'
+#' @examples
+#' # Only run this example in interactive R sessions.
+#' if (interactive()) {
+#'
+#' ui <- fillPage(fillRow(
+#'   plotOutput("plotLeft", height = "100%"),
+#'   fillCol(
+#'     plotOutput("plotTopRight", height = "100%"),
+#'     plotOutput("plotBottomRight", height = "100%")
+#'   )
+#' ))
+#'
+#' server <- function(input, output, session) {
+#'   output$plotLeft <- renderPlot(plot(cars))
+#'   output$plotTopRight <- renderPlot(plot(pressure))
+#'   output$plotBottomRight <- renderPlot(plot(AirPassengers))
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
+#' @export
+fillRow <- function(..., flex = 1, width = "100%", height = "100%") {
+  flexfill(..., direction = "row", flex = flex, width = width, height = height)
+}
+
+#' @rdname fillRow
+#' @export
+fillCol <- function(..., flex = 1, width = "100%", height = "100%") {
+  flexfill(..., direction = "column", flex = flex, width = width, height = height)
+}
+
+flexfill <- function(..., direction, flex, width = width, height = height) {
+  children <- list(...)
+  attrs <- list()
+
+  if (!is.null(names(children))) {
+    attrs <- children[names(children) != ""]
+    children <- children[names(children) == ""]
+  }
+
+  if (length(flex) > length(children)) {
+    flex <- flex[1:length(children)]
+  }
+
+  # The dimension along the main axis
+  main <- switch(direction,
+    row = "width",
+    "row-reverse" = "width",
+    column = "height",
+    "column-reverse" = "height",
+    stop("Unexpected direction")
+  )
+  # The dimension along the cross axis
+  cross <- if (main == "width") "height" else "width"
+
+  divArgs <- list(
+    class = sprintf("flexfill-container flexfill-container-%s", direction),
+    style = css(
+      display = "-webkit-flex",
+      display = "-ms-flexbox",
+      display = "flex",
+      .webkit.flex.direction = direction,
+      .ms.flex.direction = direction,
+      flex.direction = direction,
+      width = validateCssUnit(width),
+      height = validateCssUnit(height)
+    ),
+    mapply(children, flex, FUN = function(el, flexValue) {
+      if (is.na(flexValue)) {
+        # If the flex value is NA, then put the element in a simple flex item
+        # that sizes itself (along the main axis) to its contents
+        tags$div(
+          class = "flexfill-item",
+          style = css(
+            position = "relative",
+            "-webkit-flex" = "none",
+            "-ms-flex" = "none",
+            flex = "none"
+          ),
+          style = paste0(main, ":auto;", cross, ":100%;"),
+          el
+        )
+      } else if (is.numeric(flexValue)) {
+        # If the flex value is numeric, we need *two* wrapper divs. The outer is
+        # the flex item, and the inner is an absolute-fill div that is needed to
+        # make percentage-based sizing for el work correctly. I don't understand
+        # why this is needed but the truth is probably in this SO page:
+        # http://stackoverflow.com/questions/15381172/css-flexbox-child-height-100
+        tags$div(
+          class = "flexfill-item",
+          style = css(
+            position = "relative",
+            "-webkit-flex" = flexValue,
+            "-ms-flex" = flexValue,
+            flex = flexValue,
+            width = "100%", height = "100%"
+          ),
+          tags$div(
+            class = "flexfill-item-inner",
+            style = css(
+              position = "absolute",
+              top = 0, left = 0, right = 0, bottom = 0
+            ),
+            el
+          )
+        )
+      } else {
+        stop("Unexpected flex argument: ", flexValue)
+      }
+    }, SIMPLIFY = FALSE, USE.NAMES = FALSE)
+  )
+  do.call(tags$div, c(attrs, divArgs))
+}
+
+css <- function(..., collapse_ = "") {
+  props <- list(...)
+  if (length(props) == 0) {
+    return("")
+  }
+
+  if (is.null(names(props)) || any(names(props) == "")) {
+    stop("cssList expects all arguments to be named")
+  }
+
+  # Necessary to make factors show up as level names, not numbers
+  props[] <- lapply(props, paste, collapse = " ")
+
+  # Drop null args
+  props <- props[!sapply(props, empty)]
+  if (length(props) == 0) {
+    return("")
+  }
+
+  # Replace all '.' and '_' in property names to '-'
+  names(props) <- gsub("[._]", "-", tolower(gsub("([A-Z])", "-\\1", names(props))))
+
+  # Create "!important" suffix for each property whose name ends with !, then
+  # remove the ! from the property name
+  important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "")
+  names(props) <- sub("!$", "", names(props), perl = TRUE)
+
+  paste0(names(props), ":", props, important, ";", collapse = collapse_)
+}
+
+empty <- function(x) {
+  length(x) == 0 || (is.character(x) && !any(nzchar(x)))
+}

R/conditions.R

@@ -0,0 +1,334 @@
+#' Stack trace manipulation functions
+#'
+#' Advanced (borderline internal) functions for capturing, printing, and
+#' manipulating stack traces.
+#'
+#' @return \code{printError} and \code{printStackTrace} return
+#'   \code{invisible()}. The other functions pass through the results of
+#'   \code{expr}.
+#'
+#' @examples
+#' # Keeps tryCatch and withVisible related calls off the
+#' # pretty-printed stack trace
+#'
+#' visibleFunction1 <- function() {
+#'   stop("Kaboom!")
+#' }
+#'
+#' visibleFunction2 <- function() {
+#'   visibleFunction1()
+#' }
+#'
+#' hiddenFunction <- function(expr) {
+#'   expr
+#' }
+#'
+#' # An example without ..stacktraceon/off.. manipulation.
+#' # The outer "try" is just to prevent example() from stopping.
+#' try({
+#'   # The withLogErrors call ensures that stack traces are captured
+#'   # and that errors that bubble up are logged using warning().
+#'   withLogErrors({
+#'     # tryCatch and withVisible are just here to add some noise to
+#'     # the stack trace.
+#'     tryCatch(
+#'       withVisible({
+#'         hiddenFunction(visibleFunction2())
+#'       })
+#'     )
+#'   })
+#' })
+#'
+#' # Now the same example, but with ..stacktraceon/off.. to hide some
+#' # of the less-interesting bits (tryCatch and withVisible).
+#' ..stacktraceoff..({
+#'   try({
+#'     withLogErrors({
+#'       tryCatch(
+#'         withVisible(
+#'           hiddenFunction(
+#'             ..stacktraceon..(visibleFunction2())
+#'           )
+#'         )
+#'       )
+#'     })
+#'   })
+#' })
+#'
+#'
+#' @name stacktrace
+#' @rdname stacktrace
+#' @keywords internal
+NULL
+
+getCallNames <- function(calls) {
+  sapply(calls, function(call) {
+    if (is.function(call[[1]])) {
+      "<Anonymous>"
+    } else if (inherits(call[[1]], "call")) {
+      paste0(format(call[[1]]), collapse = " ")
+    } else if (typeof(call[[1]]) == "promise") {
+      "<Promise>"
+    } else {
+      paste0(as.character(call[[1]]), collapse = " ")
+    }
+  })
+}
+
+getLocs <- function(calls) {
+  sapply(calls, function(call) {
+    srcref <- attr(call, "srcref", exact = TRUE)
+    if (!is.null(srcref)) {
+      srcfile <- attr(srcref, "srcfile", exact = TRUE)
+      if (!is.null(srcfile) && !is.null(srcfile$filename)) {
+        loc <- paste0(srcfile$filename, "#", srcref[[1]])
+        return(paste0(" [", loc, "]"))
+      }
+    }
+    return("")
+  })
+}
+
+#' @details \code{captureStackTraces} runs the given \code{expr} and if any
+#'   \emph{uncaught} errors occur, annotates them with stack trace info for use
+#'   by \code{printError} and \code{printStackTrace}. It is not necessary to use
+#'   \code{captureStackTraces} around the same expression as
+#'   \code{withLogErrors}, as the latter includes a call to the former. Note
+#'   that if \code{expr} contains calls (either directly or indirectly) to
+#'   \code{try}, or \code{tryCatch} with an error handler, stack traces therein
+#'   cannot be captured unless another \code{captureStackTraces} call is
+#'   inserted in the interior of the \code{try} or \code{tryCatch}. This is
+#'   because these calls catch the error and prevent it from traveling up to the
+#'   condition handler installed by \code{captureStackTraces}.
+#'
+#' @param expr The expression to wrap.
+#' @rdname stacktrace
+#' @export
+captureStackTraces <- function(expr) {
+  withCallingHandlers(expr,
+    error = function(e) {
+      if (is.null(attr(e, "stack.trace", exact = TRUE))) {
+        calls <- sys.calls()
+        attr(e, "stack.trace") <- calls
+        stop(e)
+      }
+    }
+  )
+}
+
+#' @details \code{withLogErrors} captures stack traces and logs errors that
+#'   occur in \code{expr}, but does allow errors to propagate beyond this point
+#'   (i.e. it doesn't catch the error). The same caveats that apply to
+#'   \code{captureStackTraces} with regard to \code{try}/\code{tryCatch} apply
+#'   to \code{withLogErrors}.
+#' @rdname stacktrace
+#' @export
+withLogErrors <- function(expr,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  withCallingHandlers(
+    captureStackTraces(expr),
+    error = function(cond) {
+      # Don't print shiny.silent.error (i.e. validation errors)
+      if (inherits(cond, "shiny.silent.error")) return()
+      if (isTRUE(getOption("show.error.messages"))) {
+        printError(cond, full = full, offset = offset)
+      }
+    }
+  )
+}
+
+#' @details \code{printError} prints the error and stack trace (if any) using
+#'   \code{warning(immediate.=TRUE)}. \code{printStackTrace} prints the stack
+#'   trace only.
+#'
+#' @param cond An condition object (generally, an error).
+#' @param full If \code{TRUE}, then every element of \code{sys.calls()} will be
+#'   included in the stack trace. By default (\code{FALSE}), calls that Shiny
+#'   deems uninteresting will be hidden.
+#' @param offset If \code{TRUE} (the default), srcrefs will be reassigned from
+#'   the calls they originated from, to the destinations of those calls. If
+#'   you're used to stack traces from other languages, this feels more
+#'   intuitive, as the definition of the function indicated in the call and the
+#'   location specified by the srcref match up. If \code{FALSE}, srcrefs will be
+#'   left alone (traditional R treatment where the srcref is of the callsite).
+#' @rdname stacktrace
+#' @export
+printError <- function(cond,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s",
+    getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
+  printStackTrace(cond, full = full, offset = offset)
+  invisible()
+}
+
+#' @rdname stacktrace
+#' @export
+printStackTrace <- function(cond,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  stackTrace <- attr(cond, "stack.trace", exact = TRUE)
+  tryCatch(
+    if (!is.null(stackTrace)) {
+      message(paste0(
+        "Stack trace (innermost first):\n",
+        paste0(collapse = "\n",
+          formatStackTrace(stackTrace, full = full, offset = offset,
+            indent = "    ")
+        )
+      ))
+    } else {
+      message("No stack trace available")
+    },
+
+    error = function(cond) {
+      warning("Failed to write stack trace: ", cond)
+    }
+  )
+  invisible()
+}
+
+#' @details \code{extractStackTrace} takes a list of calls (e.g. as returned
+#'   from \code{conditionStackTrace(cond)}) and returns a data frame with one
+#'   row for each stack frame and the columns \code{num} (stack frame number),
+#'   \code{call} (a function name or similar), and \code{loc} (source file path
+#'   and line number, if available).
+#' @rdname stacktrace
+#' @export
+extractStackTrace <- function(calls,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  srcrefs <- getSrcRefs(calls)
+  if (offset) {
+    # Offset calls vs. srcrefs by 1 to make them more intuitive.
+    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
+    # the definition of foo().
+    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
+  }
+  calls <- setSrcRefs(calls, srcrefs)
+
+  callnames <- getCallNames(calls)
+
+  # Hide and show parts of the callstack based on ..stacktrace(on|off)..
+  if (full) {
+    toShow <- rep.int(TRUE, length(calls))
+  } else {
+    # Remove stop(), .handleSimpleError(), and h() calls from the end of
+    # the calls--they don't add any helpful information. But only remove
+    # the last *contiguous* block of them, and then, only if they are the
+    # last thing in the calls list.
+    hideable <- callnames %in% c("stop", ".handleSimpleError", "h")
+    # What's the last that *didn't* match stop/.handleSimpleError/h?
+    lastGoodCall <- max(which(!hideable))
+    toRemove <- length(calls) - lastGoodCall
+    # But don't remove more than 5 levels--that's an indication we might
+    # have gotten it wrong, I guess
+    if (toRemove > 0 && toRemove < 5) {
+      calls <- utils::head(calls, -toRemove)
+      callnames <- utils::head(callnames, -toRemove)
+    }
+
+    # This uses a ref-counting scheme. It might make sense to switch this
+    # to a toggling scheme, so the most recent ..stacktrace(on|off)..
+    # directive wins, regardless of what came before it.
+    # Also explicitly remove ..stacktraceon.. because it can appear with
+    # score > 0 but still should never be shown.
+    score <- rep.int(0, length(callnames))
+    score[callnames == "..stacktraceoff.."] <- -1
+    score[callnames == "..stacktraceon.."] <- 1
+    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff.."))
+  }
+  calls <- calls[toShow]
+
+  calls <- rev(calls) # Show in traceback() order
+  index <- rev(which(toShow))
+  width <- floor(log10(max(index))) + 1
+
+  data.frame(
+    num = index,
+    call = getCallNames(calls),
+    loc = getLocs(calls),
+    stringsAsFactors = FALSE
+  )
+}
+
+#' @details \code{formatStackTrace} is similar to \code{extractStackTrace}, but
+#'   it returns a preformatted character vector instead of a data frame.
+#' @param indent A string to prefix every line of the stack trace.
+#' @rdname stacktrace
+#' @export
+formatStackTrace <- function(calls, indent = "    ",
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  st <- extractStackTrace(calls, full = full, offset = offset)
+  if (nrow(st) == 0) {
+    return(character(0))
+  }
+
+  width <- floor(log10(max(st$num))) + 1
+  paste0(
+    indent,
+    formatC(st$num, width = width),
+    ": ",
+    st$call,
+    st$loc
+  )
+}
+
+getSrcRefs <- function(calls) {
+  lapply(calls, function(call) {
+    attr(call, "srcref", exact = TRUE)
+  })
+}
+
+setSrcRefs <- function(calls, srcrefs) {
+  mapply(function(call, srcref) {
+    structure(call, srcref = srcref)
+  }, calls, srcrefs)
+}
+
+stripStackTrace <- function(cond) {
+  conditionStackTrace(cond) <- NULL
+}
+
+#' @details \code{conditionStackTrace} and \code{conditionStackTrace<-} are
+#'   accessor functions for getting/setting stack traces on conditions.
+#'
+#' @param cond A condition that may have previously been annotated by
+#'   \code{captureStackTraces} (or \code{withLogErrors}).
+#' @rdname stacktrace
+#' @export
+conditionStackTrace <- function(cond) {
+  attr(cond, "stack.trace", exact = TRUE)
+}
+
+#' @param value The stack trace value to assign to the condition.
+#' @rdname stacktrace
+#' @export
+`conditionStackTrace<-` <- function(cond, value) {
+  attr(cond, "stack.trace") <- value
+  invisible(cond)
+}
+
+#' @details The two functions \code{..stacktraceon..} and
+#'   \code{..stacktraceoff..} have no runtime behavior during normal execution;
+#'   they exist only to create artifacts on the stack trace (sys.call()) that
+#'   instruct the stack trace pretty printer what parts of the stack trace are
+#'   interesting or not. The initial state is 1 and we walk from the outermost
+#'   call inwards. Each ..stacktraceoff.. decrements the state by one, and each
+#'   ..stacktraceon.. increments the state by one. Any stack trace frame whose
+#'   value is less than 1 is hidden, and finally, the ..stacktraceon.. and
+#'   ..stacktraceoff.. calls themselves are hidden too.
+#'
+#' @rdname stacktrace
+#' @export
+..stacktraceon.. <- function(expr) expr
+#' @rdname stacktrace
+#' @export
+..stacktraceoff.. <- function(expr) expr

R/diagnose.R

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

R/fileupload.R

@@ -81,33 +81,47 @@ FileUploadOperation <- R6Class(
 #' @include map.R
 FileUploadContext <- R6Class(
   'FileUploadContext',
-  portable = FALSE,
   class = FALSE,
+  private = list(
+    basedir = character(0),
+    operations = 'Map',
+    ids = character(0)  # Keep track of all ids used for file uploads
+  ),
   public = list(
-    .basedir = character(0),
-    .operations = 'Map',
-
     initialize = function(dir=tempdir()) {
-      .basedir <<- dir
-      .operations <<- Map$new()
+      private$basedir <- dir
+      private$operations <- Map$new()
     },
     createUploadOperation = function(fileInfos) {
       while (TRUE) {
         id <- paste(as.raw(p_runif(12, min=0, max=0xFF)), collapse='')
-        dir <- file.path(.basedir, id)
+        private$ids <- c(private$ids, id)
+        dir <- file.path(private$basedir, id)
         if (!dir.create(dir))
           next
 
         op <- FileUploadOperation$new(self, id, dir, fileInfos)
-        .operations$set(id, op)
+        private$operations$set(id, op)
         return(id)
       }
     },
     getUploadOperation = function(jobId) {
-      .operations$get(jobId)
+      private$operations$get(jobId)
     },
     onJobFinished = function(jobId) {
-      .operations$remove(jobId)
+      private$operations$remove(jobId)
+    },
+    # Remove the directories containing file uploads; this is to be called when
+    # a session ends.
+    rmUploadDirs = function() {
+      # Make sure all_paths is underneath the tempdir()
+      if (!grepl(normalizePath(tempdir()), normalizePath(private$basedir), fixed = TRUE)) {
+        stop("Won't remove upload path ", private$basedir,
+          "because it is not under tempdir(): ", tempdir())
+      }
+
+      all_paths <- file.path(private$basedir, private$ids)
+      unlink(all_paths, recursive = TRUE)
     }
   )
 )

R/graph.R

@@ -1,5 +1,11 @@
-writeReactLog <- function(file=stdout()) {
-  cat(toJSON(.graphStack$as_list(), pretty=TRUE), file=file)
+writeReactLog <- function(file=stdout(), sessionToken = NULL) {
+  log <- .graphStack$as_list()
+  if (!is.null(sessionToken)) {
+    log <- Filter(function(x) {
+      is.null(x$session) || identical(x$session, sessionToken)
+    }, log)
+  }
+  cat(toJSON(log, pretty=TRUE), file=file)
 }
 
 #' Reactive Log Visualizer
@@ -35,28 +41,36 @@ writeReactLog <- function(file=stdout()) {
 #' enabled, it's possible for any user of your app to see at least some
 #' of the source code of your reactive expressions and observers.
 #'
+#' @param time A boolean that specifies whether or not to display the
+#' time that each reactive.
 #' @export
-showReactLog <- function() {
-  browseURL(renderReactLog())
+showReactLog <- function(time = TRUE) {
+  utils::browseURL(renderReactLog(time = as.logical(time)))
 }
 
-renderReactLog <- function() {
+renderReactLog <- function(sessionToken = NULL, time = TRUE) {
   templateFile <- system.file('www/reactive-graph.html', package='shiny')
   html <- paste(readLines(templateFile, warn=FALSE), collapse='\r\n')
   tc <- textConnection(NULL, 'w')
   on.exit(close(tc))
-  writeReactLog(tc)
+  writeReactLog(tc, sessionToken)
   cat('\n', file=tc)
   flush(tc)
   html <- sub('__DATA__', paste(textConnectionValue(tc), collapse='\r\n'), html, fixed=TRUE)
+  html <- sub('__TIME__', paste0('"', time, '"'), html, fixed=TRUE)
   file <- tempfile(fileext = '.html')
   writeLines(html, file)
   return(file)
 }
 
 .graphAppend <- function(logEntry, domain = getDefaultReactiveDomain()) {
-  if (isTRUE(getOption('shiny.reactlog')))
-    .graphStack$push(logEntry)
+  if (isTRUE(getOption('shiny.reactlog'))) {
+    sessionToken <- if (is.null(domain)) NULL else domain$token
+    .graphStack$push(c(logEntry, list(
+      session = sessionToken,
+      time = as.numeric(Sys.time())
+    )))
+  }
 
   if (!is.null(domain)) {
     domain$reactlog(logEntry)
@@ -74,7 +88,7 @@ renderReactLog <- function() {
 .graphCreateContext <- function(id, label, type, prevId, domain) {
   .graphAppend(list(
     action='ctx', id=id, label=paste(label, collapse='\n'),
-    srcref=attr(label, "srcref"), srcfile=attr(label, "srcfile"),
+    srcref=as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile"),
     type=type, prevId=prevId
   ), domain = domain)
 }
@@ -91,7 +105,7 @@ renderReactLog <- function() {
   .graphAppend(list(
     action = 'valueChange',
     id = label,
-    value = paste(capture.output(str(value)), collapse='\n')
+    value = paste(utils::capture.output(utils::str(value)), collapse='\n')
   ))
 }
 

R/html-deps.R

@@ -6,7 +6,7 @@
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link{htmlDependency}}. If the \code{src} value is named, then
+#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named, then
 #'   \code{href} and/or \code{file} names must be present.
 #'
 #' @return A single HTML dependency object that has an \code{href}-named element
@@ -27,3 +27,21 @@ createWebDependency <- function(dependency) {
 
   return(dependency)
 }
+
+
+# Given a Shiny tag object, process singletons and dependencies. Returns a list
+# with rendered HTML and dependency objects.
+processDeps <- function(tags, session) {
+  ui <- takeSingletons(tags, session$singletons, desingleton=FALSE)$ui
+  ui <- surroundSingletons(ui)
+  dependencies <- lapply(
+    resolveDependencies(findDependencies(ui)),
+    createWebDependency
+  )
+  names(dependencies) <- NULL
+
+  list(
+    html = doRenderTags(ui),
+    deps = dependencies
+  )
+}

R/htmltools.R

@@ -4,4 +4,5 @@
 #' @export tag tagAppendAttributes tagAppendChild tagAppendChildren tagList tags tagSetChildren withTags
 #' @export validateCssUnit
 #' @export knit_print.html knit_print.shiny.tag knit_print.shiny.tag.list
+#' @export htmlTemplate suppressDependencies
 NULL

R/image-interact-opts.R

@@ -91,7 +91,10 @@ hoverOpts <- function(id = NULL, delay = 300,
 #' \code{\link{plotOutput}}.
 #'
 #' @param id Input value name. For example, if the value is \code{"plot_brush"},
-#'   then the coordinates will be available as \code{input$plot_brush}.
+#'   then the coordinates will be available as \code{input$plot_brush}. Multiple
+#'   \code{imageOutput}/\code{plotOutput} calls may share the same \code{id}
+#'   value; brushing one image or plot will cause any other brushes with the
+#'   same \code{id} to disappear.
 #' @param fill Fill color of the brush.
 #' @param stroke Outline color of the brush.
 #' @param opacity Opacity of the brush

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, ...) {
@@ -33,12 +32,12 @@ plotPNG <- function(func, filename=tempfile(fileext='.png'),
   # Otherwise, if the Cairo package is installed, use CairoPNG().
   # Finally, if neither quartz nor Cairo, use png().
   if (capabilities("aqua")) {
-    pngfun <- png
+    pngfun <- grDevices::png
   } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
              nchar(system.file(package = "Cairo"))) {
     pngfun <- Cairo::CairoPNG
   } else {
-    pngfun <- png
+    pngfun <- grDevices::png
   }
 
   pngfun(filename=filename, width=width, height=height, res=res, ...)
@@ -49,10 +48,15 @@ plotPNG <- function(func, filename=tempfile(fileext='.png'),
   # by plot.new() with the default (large) margin. However, this does not
   # guarantee user's code in func() will not trigger the error -- they may have
   # to set par(mar = smaller_value) before they draw base graphics.
-  op <- par(mar = rep(0, 4))
-  tryCatch(plot.new(), finally = par(op))
-  dv <- dev.cur()
-  tryCatch(shinyCallingHandlers(func()), finally = dev.off(dv))
+  op <- graphics::par(mar = rep(0, 4))
+  tryCatch(
+    graphics::plot.new(),
+    finally = graphics::par(op)
+  )
+
+  dv <- grDevices::dev.cur()
+  on.exit(grDevices::dev.off(dv), add = TRUE)
+  func()
 
   filename
 }

R/input-action.R

@@ -0,0 +1,86 @@
+#' Action button/link
+#'
+#' Creates an action button or link whose value is initially zero, and increments by one
+#' each time it is pressed.
+#'
+#' @inheritParams textInput
+#' @param label The contents of the button or link--usually a text label, but
+#'   you could also use any other HTML, like an image.
+#' @param icon An optional \code{\link{icon}} to appear on the button.
+#' @param ... Named attributes to be applied to the button or link.
+#'
+#' @family input elements
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' 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)
+#'
+#' }
+#'
+#' @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),
+    ...
+  )
+}
+
+#' @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),
+    ...
+  )
+}
+
+
+# Check that the icon parameter is valid:
+# 1) Check  if the user wants to actually add an icon:
+#    -- if icon=NULL, it means leave the icon unchanged
+#    -- if icon=character(0), it means don't add an icon or, more usefully,
+#       remove the previous icon
+# 2) If so, check that the icon has the right format (this does not check whether
+# it is a *real* icon - currently that would require a massive cross reference
+# with the "font-awesome" and the "glyphicon" libraries)
+validateIcon <- function(icon) {
+  if (is.null(icon) || identical(icon, character(0))) {
+    return(icon)
+  } else if (inherits(icon, "shiny.tag") && icon$name == "i") {
+    return(icon)
+  } else {
+    stop("Invalid icon. Use Shiny's 'icon()' function to generate a valid icon")
+  }
+}

R/input-checkbox.R

@@ -0,0 +1,40 @@
+#' Checkbox Input Control
+#'
+#' Create a checkbox that can be used to specify logical values.
+#'
+#' @inheritParams textInput
+#' @param value Initial value (\code{TRUE} or \code{FALSE}).
+#' @return A checkbox control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{checkboxGroupInput}}, \code{\link{updateCheckboxInput}}
+#'
+#' @examples
+#' ## 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"
+
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    div(class = "checkbox",
+      tags$label(inputTag, tags$span(label))
+    )
+  )
+}

R/input-checkboxgroup.R

@@ -0,0 +1,61 @@
+#' Checkbox Group Input Control
+#'
+#' Create a group of checkboxes that can be used to toggle multiple choices
+#' independently. The server will receive the input as a character vector of the
+#' selected values.
+#'
+#' @inheritParams textInput
+#' @param choices List of values to show checkboxes for. If elements of the list
+#'   are named then that name rather than the value is displayed to the user.
+#' @param selected The values that should be initially selected, if any.
+#' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
+#' @return A list of HTML elements that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{checkboxInput}}, \code{\link{updateCheckboxGroupInput}}
+#'
+#' @examples
+#' ## 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))
+    selected <- validateSelected(selected, choices, inputId)
+
+  options <- generateOptions(inputId, choices, selected, inline)
+
+  divClass <- "form-group shiny-input-checkboxgroup shiny-input-container"
+  if (inline)
+    divClass <- paste(divClass, "shiny-input-container-inline")
+
+  # return label and select tag
+  tags$div(id = inputId,
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    class = divClass,
+    controlLabel(inputId, label),
+    options
+  )
+}

R/input-date.R

@@ -0,0 +1,111 @@
+#' Create date input
+#'
+#' Creates a text input which, when clicked on, brings up a calendar that
+#' the user can click on to select dates.
+#'
+#' The date \code{format} string specifies how the date will be displayed in
+#' the browser. It allows the following values:
+#'
+#' \itemize{
+#'   \item \code{yy} Year without century (12)
+#'   \item \code{yyyy} Year with century (2012)
+#'   \item \code{mm} Month number, with leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (01-12)
+#'   \item \code{M} Abbreviated month name
+#'   \item \code{MM} Full month name
+#'   \item \code{dd} Day of month with leading zero
+#'   \item \code{d} Day of month without leading zero
+#'   \item \code{D} Abbreviated weekday name
+#'   \item \code{DD} Full weekday name
+#' }
+#'
+#' @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.
+#' @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 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".
+#'
+#' @family input elements
+#' @seealso \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   dateInput("date1", "Date:", value = "2012-02-29"),
+#'
+#'   # Default value is the date in client's time zone
+#'   dateInput("date2", "Date:"),
+#'
+#'   # value is always yyyy-mm-dd, even if the display format is different
+#'   dateInput("date3", "Date:", value = "2012-02-29", format = "mm/dd/yy"),
+#'
+#'   # Pass in a Date object
+#'   dateInput("date4", "Date:", value = Sys.Date()-10),
+#'
+#'   # Use different language and different first day of week
+#'   dateInput("date5", "Date:",
+#'           language = "de",
+#'           weekstart = 1),
+#'
+#'   # 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",
+  width = 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")
+
+  value <- restoreInput(id = inputId, default = value)
+
+  attachDependencies(
+    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",
+                 # 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
+      )
+    ),
+    datePickerDependency
+  )
+}
+
+datePickerDependency <- htmlDependency(
+  "bootstrap-datepicker", "1.0.2", c(href = "shared/datepicker"),
+  script = "js/bootstrap-datepicker.min.js",
+  stylesheet = "css/datepicker.css")

R/input-daterange.R

@@ -0,0 +1,124 @@
+#' Create date range input
+#'
+#' Creates a pair of text inputs which, when clicked on, bring up calendars that
+#' the user can click on to select dates.
+#'
+#' The date \code{format} string specifies how the date will be displayed in
+#' the browser. It allows the following values:
+#'
+#' \itemize{
+#'   \item \code{yy} Year without century (12)
+#'   \item \code{yyyy} Year with century (2012)
+#'   \item \code{mm} Month number, with leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (01-12)
+#'   \item \code{M} Abbreviated month name
+#'   \item \code{MM} Full month name
+#'   \item \code{dd} Day of month with leading zero
+#'   \item \code{d} Day of month without leading zero
+#'   \item \code{D} Abbreviated weekday name
+#'   \item \code{DD} Full weekday name
+#' }
+#'
+#' @inheritParams dateInput
+#' @param start The initial start 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.
+#' @param end The initial end 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.
+#' @param separator String to display between the start and end input boxes.
+#'
+#' @family input elements
+#' @seealso \code{\link{dateInput}}, \code{\link{updateDateRangeInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   dateRangeInput("daterange1", "Date range:",
+#'                  start = "2001-01-01",
+#'                  end   = "2010-12-31"),
+#'
+#'   # Default start and end is the current date in the client's time zone
+#'   dateRangeInput("daterange2", "Date range:"),
+#'
+#'   # 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 = " - "),
+#'
+#'   # Pass in Date objects
+#'   dateRangeInput("daterange4", "Date range:",
+#'                  start = Sys.Date()-10,
+#'                  end = Sys.Date()+10),
+#'
+#'   # 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",
+    weekstart = 0, language = "en", separator = " to ", width = NULL) {
+
+  # If start and end are date objects, convert to a string with yyyy-mm-dd format
+  # Same for min and max
+  if (inherits(start, "Date"))  start <- format(start, "%Y-%m-%d")
+  if (inherits(end,   "Date"))  end   <- format(end,   "%Y-%m-%d")
+  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",
+      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+
+      controlLabel(inputId, label),
+      # input-daterange class is needed for dropdown behavior
+      div(class = "input-daterange input-group",
+        tags$input(
+          class = "input-sm form-control",
+          type = "text",
+          `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` = start
+        ),
+        span(class = "input-group-addon", separator),
+        tags$input(
+          class = "input-sm form-control",
+          type = "text",
+          `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` = end
+        )
+      )
+    ),
+    datePickerDependency
+  )
+}

R/input-file.R

@@ -0,0 +1,123 @@
+#' File Upload Control
+#'
+#' Create a file upload control that can be used to upload one or more files.
+#'
+#' Whenever a file upload completes, the corresponding input variable is set
+#' to a dataframe. This dataframe contains one row for each selected file, and
+#' the following columns:
+#' \describe{
+#'   \item{\code{name}}{The filename provided by the web browser. This is
+#'   \strong{not} the path to read to get at the actual data that was uploaded
+#'   (see
+#'   \code{datapath} column).}
+#'   \item{\code{size}}{The size of the uploaded data, in
+#'   bytes.}
+#'   \item{\code{type}}{The MIME type reported by the browser (for example,
+#'   \code{text/plain}), or empty string if the browser didn't know.}
+#'   \item{\code{datapath}}{The path to a temp file that contains the data that was
+#'   uploaded. This file may be deleted if the user performs another upload
+#'   operation.}
+#' }
+#'
+#' @family input elements
+#'
+#' @inheritParams textInput
+#' @param multiple Whether the user should be allowed to select and upload
+#'   multiple files at once. \bold{Does not work on older browsers, including
+#'   Internet Explorer 9 and earlier.}
+#' @param accept A character vector of MIME types; gives the browser a hint of
+#'   what kind of files the server is expecting.
+#'
+#' @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) {
+
+  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),
+
+    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",
+      tags$div(class="progress-bar")
+    )
+  )
+}

R/input-numeric.R

@@ -0,0 +1,48 @@
+#' Create a numeric input control
+#'
+#' Create an input control for entry of numeric values
+#'
+#' @inheritParams textInput
+#' @param min Minimum allowed value
+#' @param max Maximum allowed value
+#' @param step Interval to use when stepping between min and max
+#' @return A numeric input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateNumericInput}}
+#'
+#' @examples
+#' ## 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))
+  if (!is.na(min))
+    inputTag$attribs$min = min
+  if (!is.na(max))
+    inputTag$attribs$max = max
+  if (!is.na(step))
+    inputTag$attribs$step = step
+
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    label %AND% tags$label(label, `for` = inputId),
+    inputTag
+  )
+}

R/input-password.R

@@ -0,0 +1,37 @@
+#' Create a password input control
+#'
+#' Create an password control for entry of passwords.
+#'
+#' @inheritParams textInput
+#' @return A text input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateTextInput}}
+#'
+#' @examples
+#' ## 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,
+                          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,
+               placeholder = placeholder)
+  )
+}

R/input-radiobuttons.R

@@ -0,0 +1,78 @@
+#' Create radio buttons
+#'
+#' Create a set of radio buttons used to select an item from a list.
+#'
+#' If you need to represent a "None selected" state, it's possible to default
+#' the radio buttons to have no options selected by using
+#' \code{selected = character(0)}. However, this is not recommended, as it gives
+#' the user no way to return to that state once they've made a selection.
+#' Instead, consider having the first of your choices be \code{c("None selected"
+#' = "")}.
+#'
+#' @inheritParams textInput
+#' @param choices List of values to select from (if elements of the list are
+#' named then that name rather than the value is displayed to the user)
+#' @param selected The initially selected value (if not specified then
+#' defaults to the first value)
+#' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
+#' @return A set of radio buttons that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateRadioButtons}}
+#'
+#' @examples
+#' ## 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) {
+
+  # 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)
+  }
+  if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
+
+  options <- generateOptions(inputId, choices, selected, inline, type = 'radio')
+
+  divClass <- "form-group shiny-input-radiogroup shiny-input-container"
+  if (inline)
+    divClass <- paste(divClass, "shiny-input-container-inline")
+
+  tags$div(id = inputId,
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    class = divClass,
+    controlLabel(inputId, label),
+    options
+  )
+}

R/input-select.R

@@ -0,0 +1,192 @@
+#' Create a select list input control
+#'
+#' Create a select list that can be used to choose a single or multiple items
+#' from a list of values.
+#'
+#' By default, \code{selectInput()} and \code{selectizeInput()} use the
+#' JavaScript library \pkg{selectize.js}
+#' (\url{https://github.com/brianreavis/selectize.js}) to instead of the basic
+#' select input element. To use the standard HTML select input element, use
+#' \code{selectInput()} with \code{selectize=FALSE}.
+#'
+#' In selectize mode, if the first element in \code{choices} has a value of
+#' \code{""}, its name will be treated as a placeholder prompt. For example:
+#' \code{selectInput("letter", "Letter", c("Choose one" = "", LETTERS))}
+#'
+#' @inheritParams textInput
+#' @param choices List of values to select from. If elements of the list are
+#'   named then that name rather than the value is displayed to the user.
+#' @param selected The initially selected value (or multiple values if
+#'   \code{multiple = TRUE}). If not specified then defaults to the first value
+#'   for single-select lists and no values for multiple select lists.
+#' @param multiple Is selection of multiple items allowed?
+#' @param selectize Whether to use \pkg{selectize.js} or not.
+#' @param size Number of items to show in the selection box; a larger number
+#'   will result in a taller box. Not compatible with \code{selectize=TRUE}.
+#'   Normally, when \code{multiple=FALSE}, a select input will be a drop-down
+#'   list, but when \code{size} is set, it will be a box instead.
+#' @return A select list control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateSelectInput}}
+#'
+#' @examples
+#' ## 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)
+
+  # default value if it's not specified
+  if (is.null(selected)) {
+    if (!multiple) selected <- firstChoice(choices)
+  } else selected <- validateSelected(selected, choices, inputId)
+
+  if (!is.null(size) && selectize) {
+    stop("'size' argument is incompatible with 'selectize=TRUE'.")
+  }
+
+  # create select tag and add options
+  selectTag <- tags$select(
+    id = inputId,
+    class = if (!selectize) "form-control",
+    size = size,
+    selectOptions(choices, selected)
+  )
+  if (multiple)
+    selectTag$attribs$multiple <- "multiple"
+
+  # return label and select tag
+  res <- div(
+    class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    controlLabel(inputId, label),
+    div(selectTag)
+  )
+
+  if (!selectize) return(res)
+
+  selectizeIt(inputId, res, NULL, nonempty = !multiple && !("" %in% choices))
+}
+
+firstChoice <- function(choices) {
+  if (length(choices) == 0L) return()
+  choice <- choices[[1]]
+  if (is.list(choice)) firstChoice(choice) else choice
+}
+
+# Create tags for each of the options; use <optgroup> if necessary.
+# This returns a HTML string instead of tags, because of the 'selected'
+# attribute.
+selectOptions <- function(choices, selected = NULL) {
+  html <- mapply(choices, names(choices), FUN = function(choice, label) {
+    if (is.list(choice)) {
+      # If sub-list, create an optgroup and recurse into the sublist
+      sprintf(
+        '<optgroup label="%s">\n%s\n</optgroup>',
+        htmlEscape(label, TRUE),
+        selectOptions(choice, selected)
+      )
+
+    } else {
+      # If single item, just return option string
+      sprintf(
+        '<option value="%s"%s>%s</option>',
+        htmlEscape(choice, TRUE),
+        if (choice %in% selected) ' selected' else '',
+        htmlEscape(label)
+      )
+    }
+  })
+
+  HTML(paste(html, collapse = '\n'))
+}
+
+# need <optgroup> when choices contains sub-lists
+needOptgroup <- function(choices) {
+  any(vapply(choices, is.list, logical(1)))
+}
+
+#' @rdname selectInput
+#' @param ... Arguments passed to \code{selectInput()}.
+#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#'   for possible options (character option values inside \code{\link{I}()} will
+#'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
+#'   for details).
+#' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @note The selectize input created from \code{selectizeInput()} allows
+#'   deletion of the selected option even in a single select input, which will
+#'   return an empty string as its value. This is the default behavior of
+#'   \pkg{selectize.js}. However, the selectize input created from
+#'   \code{selectInput(..., selectize = TRUE)} will ignore the empty string
+#'   value when it is a single choice input and the empty string is not in the
+#'   \code{choices} argument. This is to keep compatibility with
+#'   \code{selectInput(..., selectize = FALSE)}.
+#' @export
+selectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
+  selectizeIt(
+    inputId,
+    selectInput(inputId, ..., selectize = FALSE, width = width),
+    options
+  )
+}
+
+# given a select input and its id, selectize it
+selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
+  res <- checkAsIs(options)
+
+  selectizeDep <- htmlDependency(
+    "selectize", "0.11.2", c(href = "shared/selectize"),
+    stylesheet = "css/selectize.bootstrap3.css",
+    head = format(tagList(
+      HTML('<!--[if lt IE 9]>'),
+      tags$script(src = 'shared/selectize/js/es5-shim.min.js'),
+      HTML('<![endif]-->'),
+      tags$script(src = 'shared/selectize/js/selectize.min.js')
+    ))
+  )
+
+  if ('drag_drop' %in% options$plugins) {
+    selectizeDep <- list(selectizeDep, htmlDependency(
+      'jqueryui', '1.11.4', c(href = 'shared/jqueryui'),
+      script = 'jquery-ui.min.js'
+    ))
+  }
+
+  # Insert script on same level as <select> tag
+  select$children[[2]] <- tagAppendChild(
+    select$children[[2]],
+    tags$script(
+      type = 'application/json',
+      `data-for` = inputId, `data-nonempty` = if (nonempty) '',
+      `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
+      if (length(res$options)) HTML(toJSON(res$options)) else '{}'
+    )
+  )
+
+  attachDependencies(select, selectizeDep)
+}

R/input-slider.R

@@ -0,0 +1,256 @@
+#' Slider Input Widget
+#'
+#' Constructs a slider widget to select a numeric value from a range.
+#'
+#' @inheritParams textInput
+#' @param min The minimum value (inclusive) that can be selected.
+#' @param max The maximum value (inclusive) that can be selected.
+#' @param value The initial value of the slider. A numeric vector of length one
+#'   will create a regular slider; a numeric vector of length two will create a
+#'   double-ended range slider. A warning will be issued if the value doesn't
+#'   fit between \code{min} and \code{max}.
+#' @param step Specifies the interval between each selectable value on the
+#'   slider (if \code{NULL}, a heuristic is used to determine the step size). If
+#'   the values are dates, \code{step} is in days; if the values are times
+#'   (POSIXt), \code{step} is in seconds.
+#' @param round \code{TRUE} to round all values to the nearest integer;
+#'   \code{FALSE} if no rounding is desired; or an integer to round to that
+#'   number of digits (for example, 1 will round to the nearest 10, and -2 will
+#'   round to the nearest .01). Any rounding will be applied after snapping to
+#'   the nearest step.
+#' @param format Deprecated.
+#' @param locale Deprecated.
+#' @param ticks \code{FALSE} to hide tick marks, \code{TRUE} to show them
+#'   according to some simple heuristics.
+#' @param animate \code{TRUE} to show simple animation controls with default
+#'   settings; \code{FALSE} not to; or a custom settings list, such as those
+#'   created using \code{\link{animationOptions}}.
+#' @param sep Separator between thousands places in numbers.
+#' @param pre A prefix string to put in front of the value.
+#' @param post A suffix string to put after the value.
+#' @param dragRange This option is used only if it is a range slider (with two
+#'   values). If \code{TRUE} (the default), the range can be dragged. In other
+#'   words, the min and max can be dragged together. If \code{FALSE}, the range
+#'   cannot be dragged.
+#' @param timeFormat Only used if the values are Date or POSIXt objects. A time
+#'   format string, to be passed to the Javascript strftime library. See
+#'   \url{https://github.com/samsonjs/strftime} for more details. The allowed
+#'   format specifications are very similar, but not identical, to those for R's
+#'   \code{\link{strftime}} function. For Dates, the default is \code{"\%F"}
+#'   (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"}
+#'   (like \code{"2015-07-01 15:32:10"}).
+#' @param timezone Only used if the values are POSIXt objects. A string
+#'   specifying the time zone offset for the displayed times, in the format
+#'   \code{"+HHMM"} or \code{"-HHMM"}. If \code{NULL} (the default), times will
+#'   be displayed in the browser's time zone. The value \code{"+0000"} will
+#'   result in UTC time.
+#' @inheritParams selectizeInput
+#' @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,
+                        ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
+                        pre = NULL, post = NULL, timeFormat = NULL,
+                        timezone = NULL, dragRange = TRUE)
+{
+  if (!missing(format)) {
+    shinyDeprecated(msg = "The `format` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
+                    version = "0.10.2.2")
+  }
+  if (!missing(locale)) {
+    shinyDeprecated(msg = "The `locale` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
+                    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)
+
+    range <- max - min
+    # If short range or decimals, use continuous decimal with ~100 points
+    if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
+      step <- pretty(c(min, max), n = 100)
+      step[2] - step[1]
+    } else {
+      1
+    }
+  }
+
+  if (inherits(min, "Date")) {
+    if (!inherits(max, "Date") || !inherits(value, "Date"))
+      stop("`min`, `max`, and `value must all be Date or non-Date objects")
+    dataType <- "date"
+
+    if (is.null(timeFormat))
+      timeFormat <- "%F"
+
+  } else if (inherits(min, "POSIXt")) {
+    if (!inherits(max, "POSIXt") || !inherits(value, "POSIXt"))
+      stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
+    dataType <- "datetime"
+
+    if (is.null(timeFormat))
+      timeFormat <- "%F %T"
+
+  } else {
+    dataType <- "number"
+  }
+
+  step <- findStepSize(min, max, step)
+
+  if (dataType %in% c("date", "datetime")) {
+    # For Dates, this conversion uses midnight on that date in UTC
+    to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
+
+    # Convert values to milliseconds since epoch (this is the value JS uses)
+    # Find step size in ms
+    step  <- to_ms(max) - to_ms(max - step)
+    min   <- to_ms(min)
+    max   <- to_ms(max)
+    value <- to_ms(value)
+  }
+
+  range <- max - min
+
+  # Try to get a sane number of tick marks
+  if (ticks) {
+    n_steps <- range / step
+
+    # Make sure there are <= 10 steps.
+    # n_ticks can be a noninteger, which is good when the range is not an
+    # integer multiple of the step size, e.g., min=1, max=10, step=4
+    scale_factor <- ceiling(n_steps / 10)
+    n_ticks <- n_steps / scale_factor
+
+  } else {
+    n_ticks <- NULL
+  }
+
+  sliderProps <- dropNulls(list(
+    class = "js-range-slider",
+    id = inputId,
+    `data-type` = if (length(value) > 1) "double",
+    `data-min` = formatNoSci(min),
+    `data-max` = formatNoSci(max),
+    `data-from` = formatNoSci(value[1]),
+    `data-to` = if (length(value) > 1) formatNoSci(value[2]),
+    `data-step` = formatNoSci(step),
+    `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,
+    `data-keyboard-step` = step / (max - min) * 100,
+    `data-drag-interval` = dragRange,
+    # The following are ignored by the ion.rangeSlider, but are used by Shiny.
+    `data-data-type` = dataType,
+    `data-time-format` = timeFormat,
+    `data-timezone` = timezone
+  ))
+
+  # Replace any TRUE and FALSE with "true" and "false"
+  sliderProps <- lapply(sliderProps, function(x) {
+    if (identical(x, TRUE)) "true"
+    else if (identical(x, FALSE)) "false"
+    else x
+  })
+
+  sliderTag <- div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    if (!is.null(label)) controlLabel(inputId, label),
+    do.call(tags$input, sliderProps)
+  )
+
+  # Add animation buttons
+  if (identical(animate, TRUE))
+    animate <- animationOptions()
+
+  if (!is.null(animate) && !identical(animate, FALSE)) {
+    if (is.null(animate$playButton))
+      animate$playButton <- icon('play', lib = 'glyphicon')
+    if (is.null(animate$pauseButton))
+      animate$pauseButton <- icon('pause', lib = 'glyphicon')
+
+    sliderTag <- tagAppendChild(
+      sliderTag,
+      tags$div(class='slider-animate-container',
+        tags$a(href='#',
+          class='slider-animate-button',
+          'data-target-id'=inputId,
+          'data-interval'=animate$interval,
+          'data-loop'=animate$loop,
+          span(class = 'play', animate$playButton),
+          span(class = 'pause', animate$pauseButton)
+        )
+      )
+    )
+  }
+
+  dep <- list(
+    htmlDependency("ionrangeslider", "2.1.2", c(href="shared/ionrangeslider"),
+      script = "js/ion.rangeSlider.min.js",
+      # ion.rangeSlider also needs normalize.css, which is already included in
+      # Bootstrap.
+      stylesheet = c("css/ion.rangeSlider.css",
+                     "css/ion.rangeSlider.skinShiny.css")
+    ),
+    htmlDependency("strftime", "0.9.2", c(href="shared/strftime"),
+      script = "strftime-min.js"
+    )
+  )
+
+  attachDependencies(sliderTag, dep)
+}
+
+hasDecimals <- function(value) {
+  truncatedValue <- round(value)
+  return (!identical(value, truncatedValue))
+}
+
+#' @rdname sliderInput
+#'
+#' @param interval The interval, in milliseconds, between each animation step.
+#' @param loop \code{TRUE} to automatically restart the animation when it
+#'   reaches the end.
+#' @param playButton Specifies the appearance of the play button. Valid values
+#'   are a one-element character vector (for a simple text label), an HTML tag
+#'   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,
+                             playButton=NULL,
+                             pauseButton=NULL) {
+  list(interval=interval,
+       loop=loop,
+       playButton=playButton,
+       pauseButton=pauseButton)
+}

R/input-submit.R

@@ -0,0 +1,28 @@
+#' Create a submit button
+#'
+#' Create a submit button for an input form. Forms that include a submit
+#' button do not automatically update their outputs when inputs change,
+#' rather they wait until the user explicitly clicks the submit button.
+#'
+#' @param text Button caption
+#' @param icon Optional \code{\link{icon}} to appear on the button
+#' @param width The width of the button, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @return A submit button that can be added to a UI definition.
+#'
+#' @family input elements
+#'
+#' @examples
+#' submitButton("Update View")
+#' submitButton("Update View", icon("refresh"))
+#' @export
+submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
+  div(
+    tags$button(
+      type="submit",
+      class="btn btn-primary",
+      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+      list(icon, text)
+    )
+  )
+}

R/input-text.R

@@ -0,0 +1,43 @@
+#' Create a text input control
+#'
+#' Create an input control for entry of unstructured text values
+#'
+#' @param inputId The \code{input} slot that will be used to access the value.
+#' @param label Display label for the control, or \code{NULL} for no label.
+#' @param value Initial value.
+#' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @param placeholder A character string giving the user a hint as to what can
+#'   be entered into the control. Internet Explorer 8 and 9 do not support this
+#'   option.
+#' @return A text input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateTextInput}}
+#'
+#' @examples
+#' ## 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),
+    tags$input(id = inputId, type="text", class="form-control", value=value,
+      placeholder = placeholder)
+  )
+}

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

@@ -0,0 +1,105 @@
+controlLabel <- function(controlName, label) {
+  label %AND% tags$label(class = "control-label", `for` = controlName, label)
+}
+
+
+# Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
+# refers to values. Below is a function for backward compatibility.
+validateSelected <- function(selected, choices, inputId) {
+  # drop names, otherwise toJSON() keeps them too
+  selected <- unname(selected)
+  # if you are using optgroups, you're using shiny > 0.10.0, and you should
+  # already know that `selected` must be a value instead of a label
+  if (needOptgroup(choices)) return(selected)
+
+  if (is.list(choices)) choices <- unlist(choices)
+
+  nms <- names(choices)
+  # labels and values are identical, no need to validate
+  if (identical(nms, unname(choices))) return(selected)
+  # when selected labels instead of values
+  i <- (selected %in% nms) & !(selected %in% choices)
+  if (any(i)) {
+    warnFun <- if (all(i)) {
+      # replace names with values
+      selected <- unname(choices[selected])
+      warning
+    } else stop  # stop when it is ambiguous (some labels == values)
+    warnFun("'selected' must be the values instead of names of 'choices' ",
+            "for the input '", inputId, "'")
+  }
+  selected
+}
+
+
+# generate options for radio buttons and checkbox groups (type = 'checkbox' or
+# 'radio')
+generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox') {
+  # generate a list of <input type=? [checked] />
+  options <- mapply(
+    choices, names(choices),
+    FUN = function(value, name) {
+      inputTag <- tags$input(
+        type = type, name = inputId, value = value
+      )
+      if (value %in% selected)
+        inputTag$attribs$checked <- "checked"
+
+      # 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))
+      } else {
+        tags$div(class = type,
+          tags$label(inputTag, tags$span(name))
+        )
+      }
+    },
+    SIMPLIFY = FALSE, USE.NAMES = FALSE
+  )
+
+  div(class = "shiny-options-group", options)
+}
+
+
+# Takes a vector or list, and adds names (same as the value) to any entries
+# without names.
+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,
+  # convert it to a named list with blank names.
+  listify <- function(obj) {
+    # If a list/vector is unnamed, give it blank names
+    makeNamed <- function(x) {
+      if (is.null(names(x))) names(x) <- character(length(x))
+      x
+    }
+
+    res <- lapply(obj, function(val) {
+      if (is.list(val))
+        listify(val)
+      else if (length(val) == 1 && is.null(names(val)))
+        val
+      else
+        makeNamed(as.list(val))
+    })
+
+    makeNamed(res)
+  }
+
+  choices <- listify(choices)
+  if (length(choices) == 0) return(choices)
+
+  # Recurse into any subgroups
+  choices <- mapply(choices, names(choices), FUN = function(choice, name) {
+    if (!is.list(choice)) return(choice)
+    if (name == "") stop('All sub-lists in "choices" must be named.')
+    choicesWithNames(choice)
+  }, SIMPLIFY = FALSE)
+
+  # default missing names to choice values
+  missing <- names(choices) == ""
+  names(choices)[missing] <- as.character(choices)[missing]
+
+  choices
+}

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,
@@ -82,7 +81,7 @@ absolutePanel <- function(...,
     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/1.10.4/jquery-ui.min.js'))),
+      singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
       divTag,
       tags$script('$(".draggable").draggable();')
     ))

R/map.R

@@ -23,6 +23,9 @@ Map <- R6Class(
       env[[key]] <- value
       value
     },
+    mget = function(keys) {
+      base::mget(keys, env)
+    },
     mset = function(...) {
       args <- list(...)
       if (length(args) == 0)

R/middleware-shiny.R

@@ -9,9 +9,11 @@ reactLogHandler <- function(req) {
     return(NULL)
   }
 
+  sessionToken <- parseQueryString(req$QUERY_STRING)$s
+
   return(httpResponse(
     status=200,
-    content=list(file=renderReactLog(), owned=TRUE)
+    content=list(file=renderReactLog(sessionToken), owned=TRUE)
   ))
 }
 
@@ -39,35 +41,3 @@ sessionHandler <- function(req) {
     shinysession$handleRequest(subreq)
   })
 }
-
-dynamicHandler <- function(filePath, dependencyFiles=filePath) {
-  lastKnownTimestamps <- NA
-  metaHandler <- function(req) NULL
-
-  if (!file.exists(filePath))
-    return(metaHandler)
-
-  cacheContext <- CacheContext$new()
-
-  return (function(req) {
-    # Check if we need to rebuild
-    if (cacheContext$isDirty()) {
-      cacheContext$reset()
-      for (dep in dependencyFiles)
-        cacheContext$addDependencyFile(dep)
-
-      clearClients()
-      if (file.exists(filePath)) {
-        local({
-          cacheContext$with(function() {
-            sys.source(filePath, envir=new.env(parent=globalenv()), keep.source=TRUE)
-          })
-        })
-      }
-      metaHandler <<- joinHandlers(.globals$clients)
-      clearClients()
-    }
-
-    return(metaHandler(req))
-  })
-}

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) {
-            return(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')
         ),
@@ -332,6 +341,15 @@ HandlerManager <- R6Class("HandlerManager",
             headers=list('Content-Type' = 'text/html')))
         }
 
+        # Catch HEAD requests. For the purposes of handler functions, they
+        # 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")) {
+          head_request <- TRUE
+          req$REQUEST_METHOD <- "GET"
+        }
+
         response <- handler(req)
         if (is.null(response))
           response <- httpResponse(404, content="<h1>Not Found</h1>")
@@ -341,9 +359,21 @@ HandlerManager <- R6Class("HandlerManager",
           headers$'Content-Type' <- response$content_type
 
           response <- filter(req, response)
-          return(list(status=response$status,
-            body=response$content,
-            headers=headers))
+          if (head_request) {
+            headers$`Content-Length` <- nchar(response$content, type = "bytes")
+            return(list(
+              status = response$status,
+              body = "",
+              headers = headers
+            ))
+          } else {
+            return(list(
+              status = response$status,
+              body = response$content,
+              headers = headers
+            ))
+          }
+
         } else {
           # Assume it's a Rook-compatible response
           return(response)

R/modal.R

@@ -0,0 +1,180 @@
+#' 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.
+#'
+#' @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) {
+
+  size <- match.arg(size)
+
+  div(id = "shiny-modal", class = "modal fade", 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

@@ -0,0 +1,62 @@
+# 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, ...) {
+  e <- new.env(parent = emptyenv())
+  e$parent <- parentSession
+  e$overrides <- list(...)
+
+  structure(
+    e,
+    class = "session_proxy"
+  )
+}
+
+#' @export
+`$.session_proxy` <- function(x, name) {
+  if (name %in% names(.subset2(x, "overrides")))
+    .subset2(x, "overrides")[[name]]
+  else
+    .subset2(x, "parent")[[name]]
+}
+
+#' @export
+`[[.session_proxy` <- `$.session_proxy`
+
+
+#' @export
+`$<-.session_proxy` <- function(x, name, value) {
+  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
+#' smaller, self-contained pieces. Compared to large monolithic Shiny apps,
+#' modules are easier to reuse and easier to reason about. See the article at
+#' \url{http://shiny.rstudio.com/articles/modules.html} to learn more.
+#'
+#' @param module A Shiny module server function
+#' @param id An ID string that corresponds with the ID used to call the module's
+#'   UI function
+#' @param ... Additional parameters to pass to module server function
+#' @param session Session from which to make a child scope (the default should
+#'   almost always be used)
+#'
+#' @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)
+
+  withReactiveDomain(childScope, {
+    if (!is.function(module)) {
+      stop("module argument must be a function")
+    }
+
+    module(childScope$input, childScope$output, childScope, ...)
+  })
+}

R/notifications.R

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

R/progress.R

@@ -12,6 +12,14 @@
 #' method is called. Calling \code{close} will cause the progress panel
 #' to be removed.
 #'
+#' As of version 0.14, the progress indicators use Shiny's new notification API.
+#' If you want to use the old styling (for example, you may have used customized
+#' CSS), you can use \code{style="old"} each time you call
+#' \code{Progress$new()}. If you don't want to set the style each time
+#' \code{Progress$new} is called, you can instead call
+#' \code{\link{shinyOptions}(progress.style="old")} just once, inside the server
+#' function.
+#'
 #' \strong{Methods}
 #'   \describe{
 #'     \item{\code{initialize(session, min = 0, max = 1)}}{
@@ -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) {
-      if (!inherits(session, "ShinySession"))
+    initialize = function(session = getDefaultReactiveDomain(),
+      min = 0, max = 1,
+      style = getShinyOption("progress.style", default = "notification"))
+    {
+      if (is.null(session$progressStack))
         stop("'session' is not a ShinySession object.")
 
       private$session <- session
-      private$id <- paste(as.character(as.raw(runif(8, min=0, max=255))), collapse='')
+      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,24 +261,30 @@ 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)
 
-  if (!inherits(session, "ShinySession"))
+  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({
@@ -252,7 +302,7 @@ withProgress <- function(expr, min = 0, max = 1,
 setProgress <- function(value = NULL, message = NULL, detail = NULL,
                         session = getDefaultReactiveDomain()) {
 
-  if (!inherits(session, "ShinySession"))
+  if (is.null(session$progressStack))
     stop("'session' is not a ShinySession object.")
 
   if (session$progressStack$size() == 0) {
@@ -269,7 +319,7 @@ setProgress <- function(value = NULL, message = NULL, detail = NULL,
 incProgress <- function(amount = 0.1, message = NULL, detail = NULL,
                         session = getDefaultReactiveDomain()) {
 
-  if (!inherits(session, "ShinySession"))
+  if (is.null(session$progressStack))
     stop("'session' is not a ShinySession object.")
 
   if (session$progressStack$size() == 0) {

R/react.R

@@ -21,10 +21,8 @@ Context <- R6Class(
       withReactiveDomain(.domain, {
         env <- .getReactiveEnvironment()
         .graphEnterContext(id)
-        tryCatch(
-          env$runWith(self, func),
-          finally = .graphExitContext(id)
-        )
+        on.exit(.graphExitContext(id), add = TRUE)
+        env$runWith(self, func)
       })
     },
     invalidate = function() {
@@ -54,6 +52,9 @@ Context <- R6Class(
     addPendingFlush = function(priority) {
       "Tell the reactive environment that this context should be flushed the
         next time flushReact() called."
+      if (!is.null(.domain)) {
+        .domain$incrementBusyCount()
+      }
       .getReactiveEnvironment()$addPendingFlush(self, priority)
     },
     onFlush = function(func) {
@@ -62,8 +63,15 @@ Context <- R6Class(
     },
     executeFlushCallbacks = function() {
       "For internal use only."
-      lapply(.flushCallbacks, function(func) {
-        func()
+
+      on.exit({
+        if (!is.null(.domain)) {
+          .domain$decrementBusyCount()
+        }
+      }, add = TRUE)
+
+      lapply(.flushCallbacks, function(flushCallback) {
+        flushCallback()
       })
     }
   )
@@ -98,22 +106,25 @@ ReactiveEnvironment <- R6Class(
       }
       return(.currentContext)
     },
-    runWith = function(ctx, func) {
+    runWith = function(ctx, contextFunc) {
       old.ctx <- .currentContext
       .currentContext <<- ctx
       on.exit(.currentContext <<- old.ctx)
-      shinyCallingHandlers(func())
+      contextFunc()
     },
     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,10 +55,12 @@ createMockDomain <- function() {
   domain$end <- function() {
     if (!ended) {
       ended <<- TRUE
-      lapply(callbacks, do.call, list())
+      callbacks$invoke()
     }
     invisible()
   }
+  domain$incrementBusyCount <- function() NULL
+  domain$decrementBusyCount <- function() NULL
   return(domain)
 }
 

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(...)
@@ -200,12 +245,28 @@ reactiveValues <- function(...) {
   values
 }
 
+checkName <- function(x) {
+  if (!is.character(x) || length(x) != 1) {
+    stop("Must use single string to index into reactivevalues")
+  }
+}
+
 # Create a reactivevalues object
 #
 # @param values A ReactiveValues object
 # @param readonly Should this object be read-only?
-.createReactiveValues <- function(values = NULL, readonly = FALSE) {
-  structure(list(impl=values), class='reactivevalues', readonly=readonly)
+# @param ns A namespace function (either `identity` or `NS(namespace)`)
+.createReactiveValues <- function(values = NULL, readonly = FALSE,
+  ns = identity) {
+
+  structure(
+    list(
+      impl = values,
+      readonly = readonly,
+      ns = ns
+    ),
+    class='reactivevalues'
+  )
 }
 
 #' Checks whether an object is a reactivevalues object
@@ -219,7 +280,8 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 
 #' @export
 `$.reactivevalues` <- function(x, name) {
-  .subset2(x, 'impl')$get(name)
+  checkName(name)
+  .subset2(x, 'impl')$get(.subset2(x, 'ns')(name))
 }
 
 #' @export
@@ -227,14 +289,12 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 
 #' @export
 `$<-.reactivevalues` <- function(x, name, value) {
-  if (attr(x, 'readonly')) {
+  if (.subset2(x, 'readonly')) {
     stop("Attempted to assign value to a read-only reactivevalues object")
-  } else if (length(name) != 1 || !is.character(name)) {
-    stop("Must use single string to index into reactivevalues")
-  } else {
-    .subset2(x, 'impl')$set(name, value)
-    x
   }
+  checkName(name)
+  .subset2(x, 'impl')$set(.subset2(x, 'ns')(name), value)
+  x
 }
 
 #' @export
@@ -252,7 +312,13 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 
 #' @export
 names.reactivevalues <- function(x) {
-  .subset2(x, 'impl')$names()
+  prefix <- .subset2(x, 'ns')("")
+  results <- .subset2(x, 'impl')$names()
+  if (nzchar(prefix)) {
+    results <- results[substring(results, 1, nchar(prefix)) == prefix]
+    results <- substring(results, nchar(prefix) + 1)
+  }
+  results
 }
 
 #' @export
@@ -296,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
@@ -307,12 +388,73 @@ reactiveValuesToList <- function(x, all.names=FALSE) {
 # x[['impl']].
 #' @export
 str.reactivevalues <- function(object, indent.str = " ", ...) {
-  str(unclass(object), indent.str = indent.str, ...)
+  utils::str(unclass(object), indent.str = indent.str, ...)
   # Need to manually print out the class field,
   cat(indent.str, '- attr(*, "class")=', sep = "")
-  str(class(object))
+  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(
@@ -326,17 +468,30 @@ Observable <- R6Class(
     .invalidated = logical(0),
     .running = logical(0),
     .value = NULL,
+    .error = FALSE,
     .visible = logical(0),
     .execCount = integer(0),
     .mostRecentCtxId = character(0),
 
     initialize = function(func, label = deparse(substitute(func)),
-                          domain = getDefaultReactiveDomain()) {
+                          domain = getDefaultReactiveDomain(),
+                          ..stacktraceon = TRUE) {
       if (length(formals(func)) > 0)
         stop("Can't make a reactive expression from a function that takes one ",
              "or more parameters; only functions without parameters can be ",
              "reactive.")
-      .func <<- func
+
+      # 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
       .dependents <<- Dependents$new()
@@ -349,13 +504,16 @@ Observable <- R6Class(
       .dependents$register()
 
       if (.invalidated || .running) {
-        self$.updateValue()
+        ..stacktraceoff..(
+          self$.updateValue()
+        )
       }
 
       .graphDependsOnId(getCurrentContext()$id, .mostRecentCtxId)
 
-      if (identical(class(.value), 'try-error'))
-        stop(attr(.value, 'condition'))
+      if (.error) {
+        stop(.value)
+      }
 
       if (.visible)
         .value
@@ -379,9 +537,36 @@ Observable <- R6Class(
       on.exit(.running <<- wasRunning)
 
       ctx$run(function() {
-        result <- withVisible(try(shinyCallingHandlers(.func()), silent=TRUE))
-        .visible <<- result$visible
+        result <- withCallingHandlers(
+
+          {
+            .error <<- FALSE
+            withVisible(.func())
+          },
+
+          error = function(cond) {
+            # If an error occurs, we want to propagate the error, but we also
+            # want to save a copy of it, so future callers of this reactive will
+            # get the same error (i.e. the error is cached).
+
+            # We stripStackTrace in the next line, just in case someone
+            # downstream of us (i.e. deeper into the call stack) used
+            # captureStackTraces; otherwise the entire stack would always be the
+            # same (i.e. you'd always see the whole stack trace of the *first*
+            # time the code was run and the condition raised; there'd be no way
+            # to see the stack trace of the call site that caused the cached
+            # exception to be re-raised, and you need that information to figure
+            # out what's triggering the re-raise).
+            #
+            # We use try(stop()) as an easy way to generate a try-error object
+            # out of this condition.
+            .value <<- cond
+            .error <<- TRUE
+            .visible <<- FALSE
+          }
+        )
         .value <<- result$value
+        .visible <<- result$visible
       })
     }
   )
@@ -413,6 +598,8 @@ Observable <- R6Class(
 #'   variable; to do so, it must be quoted with \code{quote()}.
 #' @param label A label for the reactive expression, useful for debugging.
 #' @param domain See \link{domains}.
+#' @param ..stacktraceon Advanced use only. For stack manipulation purposes; see
+#'   \code{\link{stacktrace}}.
 #' @return a function, wrapped in a S3 class "reactive"
 #'
 #' @examples
@@ -433,25 +620,69 @@ Observable <- R6Class(
 #' isolate(reactiveB())
 #' isolate(reactiveC())
 #' isolate(reactiveD())
-#'
 #' @export
 reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
-                     domain = getDefaultReactiveDomain()) {
+                     domain = getDefaultReactiveDomain(),
+                     ..stacktraceon = TRUE) {
   fun <- exprToFunction(x, env, quoted)
   # Attach a label and a reference to the original user source for debugging
-  if (is.null(label))
-    label <- sprintf('reactive(%s)', paste(deparse(body(fun)), collapse='\n'))
-  srcref <- attr(substitute(x), "srcref")
+  srcref <- attr(substitute(x), "srcref", exact = TRUE)
+  if (is.null(label)) {
+    label <- srcrefToLabel(srcref[[1]],
+      sprintf('reactive(%s)', paste(deparse(body(fun)), collapse='\n')))
+  }
   if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
   attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
-  o <- Observable$new(fun, label, domain)
-  registerDebugHook(".func", o, "Reactive")
+  o <- Observable$new(fun, label, domain, ..stacktraceon = ..stacktraceon)
   structure(o$getValue, observable = o, class = "reactive")
 }
 
+# Given the srcref to a reactive expression, attempts to figure out what the
+# name of the reactive expression is. This isn't foolproof, as it literally
+# scans the line of code that started the reactive block and looks for something
+# that looks like assignment. If we fail, fall back to a default value (likely
+# the block of code in the body of the reactive).
+srcrefToLabel <- function(srcref, defaultLabel) {
+  if (is.null(srcref))
+    return(defaultLabel)
+
+  srcfile <- attr(srcref, "srcfile", exact = TRUE)
+  if (is.null(srcfile))
+    return(defaultLabel)
+
+  if (is.null(srcfile$lines))
+    return(defaultLabel)
+
+  lines <- srcfile$lines
+  # When pasting at the Console, srcfile$lines is not split
+  if (length(lines) == 1) {
+    lines <- strsplit(lines, "\n")[[1]]
+  }
+
+  if (length(lines) < srcref[1]) {
+    return(defaultLabel)
+  }
+
+  firstLine <- substring(lines[srcref[1]], 1, srcref[2] - 1)
+
+  m <- regexec("(.*)(<-|=)\\s*reactive\\s*\\($", firstLine)
+  if (m[[1]][1] == -1) {
+    return(defaultLabel)
+  }
+  sym <- regmatches(firstLine, m)[[1]][2]
+  res <- try(parse(text = sym), silent = TRUE)
+  if (inherits(res, "try-error"))
+    return(defaultLabel)
+
+  if (length(res) != 1)
+    return(defaultLabel)
+
+  return(as.character(res))
+}
+
 #' @export
 print.reactive <- function(x, ...) {
-  label <- attr(x, "observable")$.label
+  label <- attr(x, "observable", exact = TRUE)$.label
   cat(label, "\n")
 }
 
@@ -462,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
@@ -480,32 +711,40 @@ 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(func, label, suspended = FALSE, priority = 0,
+    initialize = function(observerFunc, label, suspended = FALSE, priority = 0,
                           domain = getDefaultReactiveDomain(),
-                          autoDestroy = TRUE) {
-      if (length(formals(func)) > 0)
+                          autoDestroy = TRUE, ..stacktraceon = TRUE) {
+      if (length(formals(observerFunc)) > 0)
         stop("Can't make an observer from a function that takes parameters; ",
              "only functions without parameters can be reactive.")
-
+registerDebugHook("observerFunc", environment(), label)
       .func <<- function() {
         tryCatch(
-          func(),
-          validation = function(e) {
-            # It's OK for a validation error to cause an observer to stop
-            # running
-          }
+          if (..stacktraceon)
+            ..stacktraceon..(observerFunc())
+          else
+            observerFunc(),
+          # 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
@@ -513,7 +752,9 @@ Observer <- R6Class(
       .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()
@@ -522,9 +763,25 @@ Observer <- R6Class(
       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() {
-        lapply(.invalidateCallbacks, function(func) {
-          func()
+        # Context is invalidated, so we don't need to store a reference to it
+        # anymore.
+        .ctx <<- NULL
+
+        lapply(.invalidateCallbacks, function(invalidateCallback) {
+          invalidateCallback()
           NULL
         })
 
@@ -541,24 +798,13 @@ Observer <- R6Class(
       ctx$onFlush(function() {
         tryCatch({
           if (!.destroyed)
-            run()
+            shinyCallingHandlers(run())
 
         }, error = function(e) {
-          # A function to handle errors that occur during a flush
-          flushErrorHandler <- getOption('shiny.observer.error')
-
-          # Default handler function, if not available from global option
-          if (is.null(flushErrorHandler)) {
-            flushErrorHandler <- function(e, label, domain) {
-              warning("Unhandled error in observer: ",
-                e$message, "\n", label, immediate. = TRUE, call. = FALSE)
-              if (!is.null(domain)) {
-                domain$unhandledError(e)
-              }
-            }
+          printError(e)
+          if (!is.null(.domain)) {
+            .domain$unhandledError(e)
           }
-
-          flushErrorHandler(e, .label, .domain)
         })
       })
 
@@ -586,11 +832,28 @@ Observer <- R6Class(
       "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() {
@@ -616,8 +879,21 @@ Observer <- R6Class(
       "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)) {
@@ -646,8 +922,8 @@ Observer <- R6Class(
 #' 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.
@@ -658,15 +934,18 @@ Observer <- R6Class(
 #'   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.
+#' @param ..stacktraceon Advanced use only. For stack manipulation purposes; see
+#'   \code{\link{stacktrace}}.
 #' @return An observer reference class object. This object has the following
 #'   methods:
 #'   \describe{
@@ -720,19 +999,19 @@ Observer <- R6Class(
 #' # 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,
-                    domain=getDefaultReactiveDomain(), autoDestroy = TRUE) {
+                    domain=getDefaultReactiveDomain(), autoDestroy = TRUE,
+                    ..stacktraceon = TRUE) {
 
   fun <- exprToFunction(x, env, quoted)
   if (is.null(label))
     label <- sprintf('observe(%s)', paste(deparse(body(fun)), collapse='\n'))
 
   o <- Observer$new(fun, label=label, suspended=suspended, priority=priority,
-                    domain=domain, autoDestroy=autoDestroy)
-  registerDebugHook(".func", o, "Observer")
+                    domain=domain, autoDestroy=autoDestroy,
+                    ..stacktraceon=..stacktraceon)
   invisible(o)
 }
 
@@ -759,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
@@ -834,12 +1113,19 @@ 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.
-#'   autoInvalidate <- reactiveTimer(2000, session)
+#'   autoInvalidate <- reactiveTimer(2000)
 #'
 #'   observe({
 #'     # Invalidate and re-execute this reactive expression every time the
@@ -856,18 +1142,14 @@ 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) {
-  if (missing(session)) {
-    warning("reactiveTimer should be passed a session object or NULL")
-    session <- NULL
-  }
-
+reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain()) {
   dependents <- Map$new()
   timerCallbacks$schedule(intervalMs, function() {
     # Quit if the session is closed
@@ -917,8 +1199,15 @@ reactiveTimer <- function(intervalMs=1000, session) {
 #' @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
@@ -934,19 +1223,15 @@ reactiveTimer <- function(intervalMs=1000, session) {
 #'   # input$n changes.
 #'   output$plot <- renderPlot({
 #'     # Re-execute this reactive expression after 2000 milliseconds
-#'     invalidateLater(2000, session)
-#'     hist(isolate(input$n))
+#'     invalidateLater(2000)
+#'     hist(rnorm(isolate(input$n)))
 #'   })
-#' })
 #' }
 #'
+#' shinyApp(ui, server)
+#' }
 #' @export
-invalidateLater <- function(millis, session) {
-  if (missing(session)) {
-    warning("invalidateLater should be passed a session object or NULL")
-    session <- NULL
-  }
-
+invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
   ctx <- .getReactiveEnvironment()$currentContext()
   timerCallbacks$schedule(millis, function() {
     # Quit if the session is closed
@@ -1014,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)
@@ -1083,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({
@@ -1095,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)
@@ -1189,14 +1470,14 @@ 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')
   on.exit(ctx$invalidate())
-  ctx$run(function() {
-    expr
-  })
+  # Matching ..stacktraceon../..stacktraceoff.. pair
+  ..stacktraceoff..(ctx$run(function() {
+    ..stacktraceon..(expr)
+  }))
 }
 
 #' Evaluate an expression without a reactive context
@@ -1210,7 +1491,6 @@ isolate <- function(expr) {
 #' @return The value of \code{expr}.
 #'
 #' @seealso \code{\link{isolate}}
-#'
 #' @export
 maskReactiveContext <- function(expr) {
   .getReactiveEnvironment()$runWith(NULL, function() {
@@ -1337,7 +1617,6 @@ maskReactiveContext <- function(expr) {
 #'   }
 #'   shinyApp(ui=ui, server=server)
 #' }
-#'
 #' @export
 observeEvent <- function(eventExpr, handlerExpr,
   event.env = parent.frame(), event.quoted = FALSE,
@@ -1348,8 +1627,10 @@ observeEvent <- function(eventExpr, handlerExpr,
   eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
   if (is.null(label))
     label <- sprintf('observeEvent(%s)', paste(deparse(body(eventFunc)), collapse='\n'))
+  eventFunc <- wrapFunctionLabel(eventFunc, "observeEventExpr", ..stacktraceon = TRUE)
 
   handlerFunc <- exprToFunction(handlerExpr, handler.env, handler.quoted)
+  handlerFunc <- wrapFunctionLabel(handlerFunc, "observeEventHandler", ..stacktraceon = TRUE)
 
   invisible(observe({
     e <- eventFunc()
@@ -1360,7 +1641,7 @@ observeEvent <- function(eventExpr, handlerExpr,
 
     isolate(handlerFunc())
   }, label = label, suspended = suspended, priority = priority, domain = domain,
-    autoDestroy = TRUE))
+    autoDestroy = TRUE, ..stacktraceon = FALSE))
 }
 
 #' @rdname observeEvent
@@ -1374,8 +1655,10 @@ eventReactive <- function(eventExpr, valueExpr,
   eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
   if (is.null(label))
     label <- sprintf('eventReactive(%s)', paste(deparse(body(eventFunc)), collapse='\n'))
+  eventFunc <- wrapFunctionLabel(eventFunc, "eventReactiveExpr", ..stacktraceon = TRUE)
 
   handlerFunc <- exprToFunction(valueExpr, value.env, value.quoted)
+  handlerFunc <- wrapFunctionLabel(handlerFunc, "eventReactiveHandler", ..stacktraceon = TRUE)
 
   invisible(reactive({
     e <- eventFunc()
@@ -1386,7 +1669,7 @@ eventReactive <- function(eventExpr, valueExpr,
     ))
 
     isolate(handlerFunc())
-  }, label = label, domain = domain))
+  }, label = label, domain = domain, ..stacktraceon = FALSE))
 }
 
 isNullEvent <- function(value) {

R/render-plot.R

@@ -6,6 +6,15 @@
 #' The corresponding HTML output tag should be \code{div} or \code{img} and have
 #' the CSS class name \code{shiny-plot-output}.
 #'
+#' @section Interactive plots:
+#'
+#'   With ggplot2 graphics, the code in \code{renderPlot} should return a ggplot
+#'   object; if instead the code prints the ggplot2 object with something like
+#'   \code{print(p)}, then the coordinates for interactive graphics will not be
+#'   properly scaled to the data space.
+#'
+#'   See \code{\link{plotOutput}} for more information about interactive plots.
+#'
 #' @seealso For the corresponding client-side output function, and example
 #'   usage, see \code{\link{plotOutput}}. For more details on how the plots are
 #'   generated, and how to control the output, see \code{\link{plotPNG}}.
@@ -26,29 +35,226 @@
 #' @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) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderPlot: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+                       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)
 
   args <- list(...)
 
   if (is.function(width))
     widthWrapper <- reactive({ width() })
   else
-    widthWrapper <- NULL
+    widthWrapper <- function() { width }
 
   if (is.function(height))
     heightWrapper <- reactive({ height() })
   else
-    heightWrapper <- NULL
+    heightWrapper <- function() { height }
+
+  # A modified version of print.ggplot which returns the built ggplot object
+  # as well as the gtable grob. This overrides the ggplot::print.ggplot
+  # method, but only within the context of renderPlot. The reason this needs
+  # to be a (pseudo) S3 method is so that, if an object has a class in
+  # addition to ggplot, and there's a print method for that class, that we
+  # won't override that method. https://github.com/rstudio/shiny/issues/841
+  print.ggplot <- function(x) {
+    grid::grid.newpage()
+
+    build <- ggplot2::ggplot_build(x)
+
+    gtable <- ggplot2::ggplot_gtable(build)
+    grid::grid.draw(gtable)
+
+    structure(list(
+      build = build,
+      gtable = gtable
+    ), class = "ggplot_build_gtable")
+  }
+
+
+  getDims <- function() {
+    width <- widthWrapper()
+    height <- heightWrapper()
+
+    # Note that these are reactive calls. A change to the width and height
+    # will inherently cause a reactive plot to redraw (unless width and
+    # height were explicitly specified).
+    if (width == 'auto')
+      width <- session$clientData[[paste0('output_', outputName, '_width')]]
+    if (height == 'auto')
+      height <- session$clientData[[paste0('output_', outputName, '_height')]]
+
+    list(width = width, height = height)
+  }
+
+  # Vars to store session and output, so that they can be accessed from
+  # the plotObj() reactive.
+  session <- NULL
+  outputName <- NULL
+
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned. The expression
+  # passed to renderPlot() is actually run in plotObj(); this function can only
+  # replay a plot if the width/height changes.
+  renderFunc <- function(shinysession, name, ...) {
+    session <<- shinysession
+    outputName <<- name
+
+    dims <- getDims()
+
+    if (is.null(dims$width) || is.null(dims$height) ||
+        dims$width <= 0 || dims$height <= 0) {
+      return(NULL)
+    }
+
+    # The reactive that runs the expr in renderPlot()
+    plotData <- plotObj()
+
+    img <- plotData$img
+
+    # If only the width/height have changed, simply replay the plot and make a
+    # new img.
+    if (dims$width != img$width || dims$height != img$height) {
+      pixelratio <- session$clientData$pixelratio %OR% 1
+
+      coordmap <- NULL
+      plotFunc <- function() {
+        ..stacktraceon..(grDevices::replayPlot(plotData$recordedPlot))
+
+        # Coordmap must be recalculated after replaying plot, because pixel
+        # dimensions will have changed.
+        if (inherits(plotData$plotResult, "ggplot_build_gtable")) {
+          coordmap <<- getGgplotCoordmap(plotData$plotResult, pixelratio, res)
+        } else {
+          coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
+        }
+      }
+      outfile <- ..stacktraceoff..(
+        plotPNG(plotFunc, width = dims$width*pixelratio, height = dims$height*pixelratio,
+                res = res*pixelratio)
+      )
+      on.exit(unlink(outfile))
+
+      img <- dropNulls(list(
+        src = session$fileUrl(name, outfile, contentType='image/png'),
+        width = dims$width,
+        height = dims$height,
+        coordmap = coordmap,
+        # Get coordmap error message if present
+        error = attr(coordmap, "error", exact = TRUE)
+      ))
+    }
+
+    img
+  }
+
+
+  plotObj <- reactive(label = "plotObj", {
+    if (execOnResize) {
+      dims <- getDims()
+    } else {
+      isolate({ dims <- getDims() })
+    }
+
+    if (is.null(dims$width) || is.null(dims$height) ||
+        dims$width <= 0 || dims$height <= 0) {
+      return(NULL)
+    }
+
+    # Resolution multiplier
+    pixelratio <- session$clientData$pixelratio %OR% 1
+
+    plotResult <- NULL
+    recordedPlot <- NULL
+    coordmap <- NULL
+    plotFunc <- function() {
+      success <-FALSE
+      tryCatch(
+        {
+          # This is necessary to enable displaylist recording
+          grDevices::dev.control(displaylist = "enable")
+
+          # Actually perform the plotting
+          result <- withVisible(func())
+          success <- TRUE
+        },
+        finally = {
+          if (!success) {
+            # If there was an error in making the plot, there's a good chance
+            # it's "Error in plot.new: figure margins too large". We need to
+            # take a reactive dependency on the width and height, so that the
+            # user's plotting code will re-execute when the plot is resized,
+            # instead of just replaying the previous plot (which errored).
+            getDims()
+          }
+        }
+      )
+
+      if (result$visible) {
+        # Use capture.output to squelch printing to the actual console; we
+        # are only interested in plot output
+        utils::capture.output({
+          # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
+          # the call to plotFunc. The value needs to be printed just in case
+          # it's an object that requires printing to generate plot output,
+          # similar to ggplot2. But for base graphics, it would already have
+          # been rendered when func was called above, and the print should
+          # have no effect.
+          plotResult <<- ..stacktraceon..(print(result$value))
+        })
+      }
+
+      recordedPlot <<- grDevices::recordPlot()
+
+      if (inherits(plotResult, "ggplot_build_gtable")) {
+        coordmap <<- getGgplotCoordmap(plotResult, pixelratio, res)
+      } else {
+        coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
+      }
+    }
+
+    # This ..stacktraceoff.. is matched by the `func` function's
+    # wrapFunctionLabel(..stacktraceon=TRUE) call near the beginning of
+    # renderPlot, and by the ..stacktraceon.. in plotFunc where ggplot objects
+    # are printed
+    outfile <- ..stacktraceoff..(
+      do.call(plotPNG, c(plotFunc, width=dims$width*pixelratio,
+        height=dims$height*pixelratio, res=res*pixelratio, args))
+    )
+    on.exit(unlink(outfile))
+
+    list(
+      # img is the content that gets sent to the client.
+      img = dropNulls(list(
+        src = session$fileUrl(outputName, outfile, contentType='image/png'),
+        width = dims$width,
+        height = dims$height,
+        coordmap = coordmap,
+        # Get coordmap error message if present.
+        error = attr(coordmap, "error", exact = TRUE)
+      )),
+      # Returned value from expression in renderPlot() -- may be a printable
+      # object like ggplot2. Needed just in case we replayPlot and need to get
+      # a coordmap again.
+      plotResult = plotResult,
+      recordedPlot = recordedPlot
+    )
+  })
+
 
   # If renderPlot isn't going to adapt to the height of the div, then the
   # div needs to adapt to the height of renderPlot. By default, plotOutput
@@ -57,71 +263,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   outputFunc <- plotOutput
   if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
 
-  return(markRenderFunction(outputFunc, function(shinysession, name, ...) {
-    if (!is.null(widthWrapper))
-      width <- widthWrapper()
-    if (!is.null(heightWrapper))
-      height <- heightWrapper()
-
-    # Note that these are reactive calls. A change to the width and height
-    # will inherently cause a reactive plot to redraw (unless width and
-    # height were explicitly specified).
-    prefix <- 'output_'
-    if (width == 'auto')
-      width <- shinysession$clientData[[paste(prefix, name, '_width', sep='')]];
-    if (height == 'auto')
-      height <- shinysession$clientData[[paste(prefix, name, '_height', sep='')]];
-
-    if (is.null(width) || is.null(height) || width <= 0 || height <= 0)
-      return(NULL)
-
-    # Resolution multiplier
-    pixelratio <- shinysession$clientData$pixelratio
-    if (is.null(pixelratio))
-      pixelratio <- 1
-
-    coordmap <- NULL
-    plotFunc <- function() {
-      # Actually perform the plotting
-      result <- withVisible(func())
-
-      coordmap <<- NULL
-
-      if (result$visible) {
-        # Use capture.output to squelch printing to the actual console; we
-        # are only interested in plot output
-
-        # Special case for ggplot objects - need to capture coordmap
-        if (inherits(result$value, "ggplot")) {
-          capture.output(coordmap <<- getGgplotCoordmap(result$value, pixelratio))
-        } else {
-          capture.output(print(result$value))
-        }
-      }
-
-      if (is.null(coordmap)) {
-        coordmap <<- getPrevPlotCoordmap(width, height)
-      }
-    }
-
-    outfile <- do.call(plotPNG, c(plotFunc, width=width*pixelratio,
-                                  height=height*pixelratio, res=res*pixelratio, args))
-    on.exit(unlink(outfile))
-
-    # A list of attributes for the img
-    res <- list(
-      src=shinysession$fileUrl(name, outfile, contentType='image/png'),
-      width=width, height=height, coordmap=coordmap
-    )
-
-    # Get error message if present (from attribute on the coordmap)
-    error <- attr(coordmap, "error", exact = TRUE)
-    if (!is.null(error)) {
-      res$error <- error
-    }
-
-    res
-  }))
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
 }
 
 # The coordmap extraction functions below return something like the examples
@@ -237,12 +379,12 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 # Requires width and height of output image, in pixels.
 # Must be called before the graphics device is closed.
 getPrevPlotCoordmap <- function(width, height) {
-  usrCoords <- par('usr')
+  usrCoords <- graphics::par('usr')
   usrBounds <- usrCoords
-  if (par('xlog')) {
+  if (graphics::par('xlog')) {
     usrBounds[c(1,2)] <- 10 ^ usrBounds[c(1,2)]
   }
-  if (par('ylog')) {
+  if (graphics::par('ylog')) {
     usrBounds[c(3,4)] <- 10 ^ usrBounds[c(3,4)]
   }
 
@@ -257,14 +399,14 @@ getPrevPlotCoordmap <- function(width, height) {
     ),
     # The bounds of the plot area, in DOM pixels
     range = list(
-      left = grconvertX(usrBounds[1], 'user', 'nfc') * width,
-      right = grconvertX(usrBounds[2], 'user', 'nfc') * width,
-      bottom = (1-grconvertY(usrBounds[3], 'user', 'nfc')) * height - 1,
-      top = (1-grconvertY(usrBounds[4], 'user', 'nfc')) * height - 1
+      left = graphics::grconvertX(usrBounds[1], 'user', 'nfc') * width,
+      right = graphics::grconvertX(usrBounds[2], 'user', 'nfc') * width,
+      bottom = (1-graphics::grconvertY(usrBounds[3], 'user', 'nfc')) * height - 1,
+      top = (1-graphics::grconvertY(usrBounds[4], 'user', 'nfc')) * height - 1
     ),
     log = list(
-      x = if (par('xlog')) 10 else NULL,
-      y = if (par('ylog')) 10 else NULL
+      x = if (graphics::par('xlog')) 10 else NULL,
+      y = if (graphics::par('ylog')) 10 else NULL
     ),
     # We can't extract the original variable names from a base graphic.
     # `mapping` is an empty _named_ list, so that it is converted to an object
@@ -273,27 +415,12 @@ getPrevPlotCoordmap <- function(width, height) {
   ))
 }
 
-# Print a ggplot object and return a coordmap for it.
-getGgplotCoordmap <- function(p, pixelratio) {
-  if (!inherits(p, "ggplot"))
+
+# Given a ggplot_build_gtable object, return a coordmap for it.
+getGgplotCoordmap <- function(p, pixelratio, res) {
+  if (!inherits(p, "ggplot_build_gtable"))
     return(NULL)
 
-  # A modified version of print.ggplot which returns the built ggplot object
-  # as well as the gtable grob.
-  print_ggplot <- function(x) {
-    grid::grid.newpage()
-
-    build <- ggplot2::ggplot_build(x)
-
-    gtable <- ggplot2::ggplot_gtable(build)
-    grid::grid.draw(gtable)
-
-    list(
-      build = build,
-      gtable = gtable
-    )
-  }
-
   # Given a built ggplot object, return x and y domains (data space coords) for
   # each panel.
   find_panel_info <- function(b) {
@@ -350,7 +477,7 @@ getGgplotCoordmap <- function(p, pixelratio) {
   # ggplot object, return the domain.
   find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
     range <- b$panel$ranges[[panel_num]]
-    res <- list(
+    domain <- list(
       left   = range$x.range[1],
       right  = range$x.range[2],
       bottom = range$y.range[1],
@@ -362,15 +489,15 @@ getGgplotCoordmap <- function(p, pixelratio) {
     yscale <- b$panel$y_scales[[scaley_num]]
 
     if (!is.null(xscale$trans) && xscale$trans$name == "reverse") {
-      res$left  <- -res$left
-      res$right <- -res$right
+      domain$left  <- -domain$left
+      domain$right <- -domain$right
     }
     if (!is.null(yscale$trans) && yscale$trans$name == "reverse") {
-      res$top    <- -res$top
-      res$bottom <- -res$bottom
+      domain$top    <- -domain$top
+      domain$bottom <- -domain$bottom
     }
 
-    res
+    domain
   }
 
   # Given built ggplot object, return object with the log base for x and y if
@@ -462,14 +589,38 @@ getGgplotCoordmap <- function(p, pixelratio) {
     # are "null" units. These units use the remaining available width/height --
     # that is, the space not occupied by elements that have an absolute size.
     is_null_unit <- function(x) {
-      vapply(x, FUN.VALUE = logical(1), function(u) {
-        isTRUE(attr(u, "unit", exact = TRUE) == "null")
-      })
+      # A vector of units can be either a list of individual units (a unit.list
+      # object), each with their own set of attributes, or an atomic vector with
+      # one set of attributes. ggplot2 switched from the former (in version
+      # 1.0.1) to the latter. We need to make sure that we get the correct
+      # result in both cases.
+      if (inherits(x, "unit.list")) {
+        # For ggplot2 <= 1.0.1
+        vapply(x, FUN.VALUE = logical(1), function(u) {
+          isTRUE(attr(u, "unit", exact = TRUE) == "null")
+        })
+      } else {
+        # For later versions of ggplot2
+        attr(x, "unit", exact = TRUE) == "null"
+      }
+    }
+
+    # Workaround for a bug in the quartz device. If you have a 400x400 image and
+    # run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
+    # res setting of the device. If res=72, then it returns 400 (as expected),
+    # but if, e.g., res=96, it will return 300, which is incorrect.
+    devScaleFactor <- 1
+    if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
+      devScaleFactor <- res / 72
     }
 
     # Convert a unit (or vector of units) to a numeric vector of pixel sizes
-    h_px <- function(x) as.numeric(grid::convertHeight(x, "native"))
-    w_px <- function(x) as.numeric(grid::convertWidth(x, "native"))
+    h_px <- function(x) {
+      devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
+    }
+    w_px <- function(x) {
+      devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
+    }
 
     # Given a vector of relative sizes (in grid units), and a function for
     # converting grid units to numeric pixels, return a numeric vector of
@@ -519,7 +670,7 @@ getGgplotCoordmap <- function(p, pixelratio) {
     # the image has double size. In the latter case we don't have to scale the
     # numbers down.
     pix_ratio <- 1
-    if (!grepl("^quartz", names(dev.cur()))) {
+    if (!grepl("^quartz", names(grDevices::dev.cur()))) {
       pix_ratio <- pixelratio
     }
 
@@ -537,16 +688,14 @@ getGgplotCoordmap <- function(p, pixelratio) {
   }
 
 
-  res <- print_ggplot(p)
-
   tryCatch({
     # Get info from built ggplot object
-    info <- find_panel_info(res$build)
+    info <- find_panel_info(p$build)
 
     # Get ranges from gtable - it's possible for this to return more elements than
     # info, because it calculates positions even for panels that aren't present.
     # This can happen with facet_wrap.
-    ranges <- find_panel_ranges(res$gtable, pixelratio)
+    ranges <- find_panel_ranges(p$gtable, pixelratio)
 
     for (i in seq_along(info)) {
       info[[i]]$range <- ranges[[i]]

R/render-table.R

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

R/run-url.R

@@ -22,7 +22,7 @@
 #' @export
 #' @examples
 #' ## Only run this example in interactive R sessions
-#'   if (interactive()) {
+#' if (interactive()) {
 #'   runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
 #'
 #'   # Can run an app from a subdirectory in the archive
@@ -71,8 +71,8 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
     untar2(filePath, exdir = fileDir)
 
   } else if (fileext == ".zip") {
-    first <- as.character(unzip(filePath, list=TRUE)$Name)[1]
-    unzip(filePath, exdir = fileDir)
+    first <- as.character(utils::unzip(filePath, list=TRUE)$Name)[1]
+    utils::unzip(filePath, exdir = fileDir)
   }
 
   if(is.null(destdir)){
@@ -80,7 +80,7 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
   }
 
   appdir <- file.path(fileDir, first)
-  if (!file_test('-d', appdir)) appdir <- dirname(appdir)
+  if (!utils::file_test('-d', appdir)) appdir <- dirname(appdir)
 
   if (!is.null(subdir)) appdir <- file.path(appdir, subdir)
   runApp(appdir, ...)
@@ -112,7 +112,7 @@ runGist <- function(gist, destdir = NULL, ...) {
     stop('Unrecognized gist identifier format')
   }
 
-  runUrl(gistUrl, filetype = ".tar.gz", destdir = destdir, ...)
+  runUrl(gistUrl, filetype = ".zip", destdir = destdir, ...)
 }
 
 

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

@@ -0,0 +1,152 @@
+# Create a map for input handlers and register the defaults.
+inputHandlers <- Map$new()
+
+#' Register an Input Handler
+#'
+#' Adds an input handler for data of this type. When called, Shiny will use the
+#' function provided to refine the data passed back from the client (after being
+#' deserialized by jsonlite) before making it available in the \code{input}
+#' variable of the \code{server.R} file.
+#'
+#' This function will register the handler for the duration of the R process
+#' (unless Shiny is explicitly reloaded). For that reason, the \code{type} used
+#' should be very specific to this package to minimize the risk of colliding
+#' with another Shiny package which might use this data type name. We recommend
+#' the format of "packageName.widgetName".
+#'
+#' Currently Shiny registers the following handlers: \code{shiny.matrix},
+#' \code{shiny.number}, and \code{shiny.date}.
+#'
+#' The \code{type} of a custom Shiny Input widget will be deduced using the
+#' \code{getType()} JavaScript function on the registered Shiny inputBinding.
+#' @param type The type for which the handler should be added -- should be a
+#' single-element character vector.
+#' @param fun The handler function. This is the function that will be used to
+#'   parse the data delivered from the client before it is available in the
+#'   \code{input} variable. The function will be called with the following three
+#'   parameters:
+#'    \enumerate{
+#'      \item{The value of this input as provided by the client, deserialized
+#'      using jsonlite.}
+#'      \item{The \code{shinysession} in which the input exists.}
+#'      \item{The name of the input.}
+#'    }
+#' @param force If \code{TRUE}, will overwrite any existing handler without
+#' warning. If \code{FALSE}, will throw an error if this class already has
+#' a handler defined.
+#' @examples
+#' \dontrun{
+#' # Register an input handler which rounds a input number to the nearest integer
+#' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
+#'   if (is.null(x)) return(NA)
+#'   round(x)
+#' })
+#'
+#' ## On the Javascript side, the associated input binding must have a corresponding getType method:
+#' getType: function(el) {
+#'   return "mypackage.validint";
+#' }
+#'
+#' }
+#' @seealso \code{\link{removeInputHandler}}
+#' @export
+registerInputHandler <- function(type, fun, force=FALSE){
+  if (inputHandlers$containsKey(type) && !force){
+    stop("There is already an input handler for type: ", type)
+  }
+  inputHandlers$set(type, fun)
+}
+
+#' Deregister an Input Handler
+#'
+#' Removes an Input Handler. Rather than using the previously specified handler
+#' for data of this type, the default jsonlite serialization will be used.
+#'
+#' @param type The type for which handlers should be removed.
+#' @return The handler previously associated with this \code{type}, if one
+#'   existed. Otherwise, \code{NULL}.
+#' @seealso \code{\link{registerInputHandler}}
+#' @export
+removeInputHandler <- function(type){
+  inputHandlers$remove(type)
+}
+
+# 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, ...) {
+  if (length(data) == 0)
+    return(matrix(nrow=0, ncol=0))
+
+  m <- matrix(unlist(lapply(data, function(x) {
+    sapply(x, function(y) {
+      ifelse(is.null(y), NA, y)
+    })
+  })), nrow = length(data[[1]]), ncol = length(data))
+  return(m)
+})
+
+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)
+
+  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, ...){
+  # First replace NULLs with NA, then convert to POSIXct vector
+  times <- lapply(val, function(x) {
+    if (is.null(x)) NA
+    else x
+  })
+  as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
+})
+
+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)
+
+  # Make sure that the paths don't go up the directory tree, for security
+  # reasons.
+  if (any(grepl("..", val$datapath, fixed = TRUE))) {
+    stop("Invalid '..' found in file input path.")
+  }
+
+  # Prepend the persistent dir
+  val$datapath <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+
+  val
+})

R/server.R

@@ -1,110 +1,7 @@
-#' @include globals.R
+#' @include server-input-handlers.R
 
 appsByToken <- Map$new()
 
-# Create a map for input handlers and register the defaults.
-inputHandlers <- Map$new()
-
-#' Register an Input Handler
-#'
-#' Adds an input handler for data of this type. When called, Shiny will use the
-#' function provided to refine the data passed back from the client (after being
-#' deserialized by jsonlite) before making it available in the \code{input}
-#' variable of the \code{server.R} file.
-#'
-#' This function will register the handler for the duration of the R process
-#' (unless Shiny is explicitly reloaded). For that reason, the \code{type} used
-#' should be very specific to this package to minimize the risk of colliding
-#' with another Shiny package which might use this data type name. We recommend
-#' the format of "packageName.widgetName".
-#'
-#' Currently Shiny registers the following handlers: \code{shiny.matrix},
-#' \code{shiny.number}, and \code{shiny.date}.
-#'
-#' The \code{type} of a custom Shiny Input widget will be deduced using the
-#' \code{getType()} JavaScript function on the registered Shiny inputBinding.
-#' @param type The type for which the handler should be added -- should be a
-#' single-element character vector.
-#' @param fun The handler function. This is the function that will be used to
-#'   parse the data delivered from the client before it is available in the
-#'   \code{input} variable. The function will be called with the following three
-#'   parameters:
-#'    \enumerate{
-#'      \item{The value of this input as provided by the client, deserialized
-#'      using jsonlite.}
-#'      \item{The \code{shinysession} in which the input exists.}
-#'      \item{The name of the input.}
-#'    }
-#' @param force If \code{TRUE}, will overwrite any existing handler without
-#' warning. If \code{FALSE}, will throw an error if this class already has
-#' a handler defined.
-#' @examples
-#' \dontrun{
-#' # Register an input handler which rounds a input number to the nearest integer
-#' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
-#'   if (is.null(x)) return(NA)
-#'   round(x)
-#' })
-#'
-#' ## On the Javascript side, the associated input binding must have a corresponding getType method:
-#' getType: function(el) {
-#'   return "mypackage.validint";
-#' }
-#'
-#' }
-#' @seealso \code{\link{removeInputHandler}}
-#' @export
-registerInputHandler <- function(type, fun, force=FALSE){
-  if (inputHandlers$containsKey(type) && !force){
-    stop("There is already an input handler for type: ", type)
-  }
-  inputHandlers$set(type, fun)
-}
-
-#' Deregister an Input Handler
-#'
-#' Removes an Input Handler. Rather than using the previously specified handler
-#' for data of this type, the default jsonlite serialization will be used.
-#'
-#' @param type The type for which handlers should be removed.
-#' @return The handler previously associated with this \code{type}, if one
-#'   existed. Otherwise, \code{NULL}.
-#' @seealso \code{\link{registerInputHandler}}
-#' @export
-removeInputHandler <- function(type){
-  inputHandlers$remove(type)
-}
-
-# 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, ...) {
-  if (length(data) == 0)
-    return(matrix(nrow=0, ncol=0))
-
-  m <- matrix(unlist(lapply(data, function(x) {
-    sapply(x, function(y) {
-      ifelse(is.null(y), NA, y)
-    })
-  })), nrow = length(data[[1]]), ncol = length(data))
-  return(m)
-})
-
-registerInputHandler("shiny.number", function(val, ...){
-  ifelse(is.null(val), NA, 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))
-})
-
-registerInputHandler("shiny.action", function(val, ...) {
-  # mark up the action button value with a special class so we can recognize it later
-  class(val) <- c(class(val), "shinyActionButtonValue")
-  val
-})
-
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
 wsToKey <- function(WS) {
@@ -152,7 +49,6 @@ registerClient <- function(client) {
 #'
 #' @examples
 #' addResourcePath('datasets', system.file('data', package='datasets'))
-#'
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
@@ -244,7 +140,6 @@ resourcePathHandler <- function(req) {
 #'   })
 #' }
 #' }
-#'
 #' @export
 shinyServer <- function(func) {
   .globals$server <- list(func)
@@ -305,146 +200,172 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
         return(TRUE)
       }
 
+      if (!is.null(getOption("shiny.observer.error", NULL))) {
+        warning(
+          call. = FALSE,
+          "options(shiny.observer.error) is no longer supported; please unset it!"
+        )
+        stopApp()
+      }
+
       shinysession <- ShinySession$new(ws)
       appsByToken$set(shinysession$token, shinysession)
       shinysession$setShowcase(.globals$showcaseDefault)
 
-      ws$onMessage(function(binary, msg) {
-        # To ease transition from websockets-based code. Should remove once we're stable.
-        if (is.character(msg))
-          msg <- charToRaw(msg)
+      messageHandler <- function(binary, msg) {
+        withReactiveDomain(shinysession, {
+          # To ease transition from websockets-based code. Should remove once we're stable.
+          if (is.character(msg))
+            msg <- charToRaw(msg)
 
-        if (isTRUE(getOption('shiny.trace'))) {
-          if (binary)
-            message("RECV ", '$$binary data$$')
-          else
-            message("RECV ", rawToChar(msg))
-        }
+          if (isTRUE(getOption('shiny.trace'))) {
+            if (binary)
+              message("RECV ", '$$binary data$$')
+            else
+              message("RECV ", rawToChar(msg))
+          }
 
-        if (identical(charToRaw("\003\xe9"), msg))
-          return()
+          if (identical(charToRaw("\003\xe9"), msg))
+            return()
 
-        msg <- decodeMessage(msg)
+          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 <- 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")
+            unpackInput <- 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)
               }
             }
 
-            # 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)
+            msg$data <- mapply(unpackInput, names(msg$data), msg$data,
+                               SIMPLIFY = FALSE)
+
+            # Convert names like "button1:shiny.action" to "button1"
+            names(msg$data) <- vapply(
+              names(msg$data),
+              function(name) { strsplit(name, ":")[[1]][1] },
+              FUN.VALUE = character(1)
+            )
+
+
+            switch(
+              msg$method,
+              init = {
+
+                serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+                if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+                  appvars$server <- serverFunc
+                  if (!is.null(appvars$server))
+                  {
+                    # Tag this function as the Shiny server function. A debugger may use this
+                    # tag to give this function special treatment.
+                    # It's very important that it's appvars$server itself and NOT a copy that
+                    # is invoked, otherwise new breakpoints won't be picked up.
+                    attr(appvars$server, "shinyServerFunction") <- TRUE
+                    registerDebugHook("server", appvars, "Server Function")
+                  }
+                }
+
+                # Check for switching into/out of showcase mode
+                if (.globals$showcaseOverride &&
+                    exists(".clientdata_url_search", where = msg$data)) {
+                  mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+                  if (!is.null(mode))
+                    shinysession$setShowcase(mode)
+                }
+
+                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]]
+                }
+
+                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
+                    )
+                  })
+                })
+              },
+              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())
+
+              # 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()
+
+              # 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()
             }
 
-            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]]
-            }
-
-            local({
-              args <- list(
-                input=shinysession$input,
-                output=.createOutputWriter(shinysession))
-
-              # The clientData and session arguments are optional; check if
-              # each exists
-              if ('clientData' %in% names(formals(serverFunc)))
-                args$clientData <- shinysession$clientData
-
-              if ('session' %in% names(formals(serverFunc)))
-                args$session <- shinysession
-
-              withReactiveDomain(shinysession, {
-                do.call(appvars$server, args)
-              })
-            })
-          },
-          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())
-
-          # 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()
-
-          # 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
+            flushAllSessions()
+          })
         })
+      }
+      ws$onMessage(function(binary, msg) {
+        # If unhandled errors occur, make sure they get properly logged
+        withLogErrors(messageHandler(binary, msg))
       })
 
       ws$onClose(function() {
@@ -458,6 +379,26 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
   return(appHandlers)
 }
 
+# Determine what arguments should be passed to this serverFunc. All server funcs
+# must take input and output, but clientData (obsolete) and session are
+# optional.
+argsForServerFunc <- function(serverFunc, session) {
+  args <- list(input = session$input, output = .createOutputWriter(session))
+
+  paramNames <- names(formals(serverFunc))
+
+  # The clientData and session arguments are optional; check if
+  # each exists
+
+  if ("clientData" %in% paramNames)
+    args$clientData <- session$clientData
+
+  if ("session" %in% paramNames)
+    args$session <- session
+
+  args
+}
+
 getEffectiveBody <- function(func) {
   # Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
   # returns NULL.
@@ -519,6 +460,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()))
   }
 }
@@ -532,10 +479,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
@@ -559,13 +503,16 @@ serviceApp <- function() {
 #' clients to connect, use the value \code{"0.0.0.0"} instead (which was the
 #' value that was hard-coded into Shiny in 0.8.0 and earlier).
 #'
-#' @param appDir The directory of the application. Should contain
-#'   \code{server.R}, plus, either \code{ui.R} or a \code{www} directory that
-#'   contains the file \code{index.html}. Alternately, instead of
-#'   \code{server.R} and \code{ui.R}, the directory may contain just
-#'   \code{app.R}. Defaults to the working directory. Instead of a directory,
-#'   this could be a list with \code{ui} and \code{server} components, or a
-#'   Shiny app object created by \code{\link{shinyApp}}.
+#' @param appDir The application to run. Should be one of the following:
+#'   \itemize{
+#'   \item A directory containing \code{server.R}, plus, either \code{ui.R} or
+#'    a \code{www} directory that contains the file \code{index.html}.
+#'   \item A directory containing \code{app.R}.
+#'   \item An \code{.R} file containing a Shiny application, ending with an
+#'    expression that produces a Shiny app object.
+#'   \item A list with \code{ui} and \code{server} components.
+#'   \item A Shiny app object created by \code{\link{shinyApp}}.
+#'   }
 #' @param port The TCP port that the application should listen on. If the
 #'   \code{port} is not specified, and the \code{shiny.port} option is set (with
 #'   \code{options(shiny.port = XX)}), then that port will be used. Otherwise,
@@ -634,23 +581,29 @@ 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
     # any valid version.
     ver <- Sys.getenv('SHINY_SERVER_VERSION')
-    if (compareVersion(ver, .shinyServerMinVersion) < 0) {
+    if (utils::compareVersion(ver, .shinyServerMinVersion) < 0) {
       warning('Shiny Server v', .shinyServerMinVersion,
               ' or later is required; please upgrade!')
     }
@@ -664,27 +617,50 @@ runApp <- function(appDir=getwd(),
   # If appDir specifies a path, and display mode is specified in the
   # DESCRIPTION file at that path, apply it here.
   if (is.character(appDir)) {
-    desc <- file.path.ci(appDir, "DESCRIPTION")
+    # if appDir specifies a .R file (single-file Shiny app), look for the
+    # DESCRIPTION in the parent directory
+    desc <- file.path.ci(
+      if (tolower(tools::file_ext(appDir)) == "r")
+        dirname(appDir)
+      else
+        appDir, "DESCRIPTION")
     if (file.exists(desc)) {
       con <- file(desc, encoding = checkEncoding(desc))
       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)
 
@@ -705,7 +681,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
@@ -719,6 +702,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))
@@ -751,16 +740,27 @@ runApp <- function(appDir=getwd(),
     callAppHook("onAppStop", appUrl)
   }, add = TRUE)
 
+  .globals$reterror <- NULL
   .globals$retval <- NULL
   .globals$stopped <- FALSE
-  shinyCallingHandlers(
-    while (!.globals$stopped) {
-      serviceApp()
-      Sys.sleep(0.001)
-    }
+  # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
+  # reactive(), Callbacks$invoke(), and others
+  ..stacktraceoff..(
+    captureStackTraces(
+      while (!.globals$stopped) {
+        serviceApp()
+        Sys.sleep(0.001)
+      }
+    )
   )
 
-  return(.globals$retval)
+  if (isTRUE(.globals$reterror)) {
+    stop(.globals$retval)
+  }
+  else if (.globals$retval$visible)
+    .globals$retval$value
+  else
+    invisible(.globals$retval$value)
 }
 
 #' Stop the currently running Shiny app
@@ -770,10 +770,26 @@ runApp <- function(appDir=getwd(),
 #'
 #' @param returnValue The value that should be returned from
 #'   \code{\link{runApp}}.
-#'
 #' @export
-stopApp <- function(returnValue = NULL) {
-  .globals$retval <- returnValue
+stopApp <- function(returnValue = invisible()) {
+  # reterror will indicate whether retval is an error (i.e. it should be passed
+  # to stop() when the serviceApp loop stops) or a regular value (in which case
+  # it should simply be returned with the appropriate visibility).
+  .globals$reterror <- FALSE
+  ..stacktraceoff..(
+    tryCatch(
+      {
+        captureStackTraces(
+          .globals$retval <- withVisible(..stacktraceon..(force(returnValue)))
+        )
+      },
+      error = function(e) {
+        .globals$retval <- e
+        .globals$reterror <- TRUE
+      }
+    )
+  )
+
   .globals$stopped <- TRUE
   httpuv::interrupt()
 }
@@ -836,3 +852,140 @@ runExample <- function(example=NA,
            display.mode = display.mode)
   }
 }
+
+#' Run a gadget
+#'
+#' Similar to \code{runApp}, but handles \code{input$cancel} automatically, and
+#' if running in RStudio, defaults to viewing the app in the Viewer pane.
+#'
+#' @param app Either a Shiny app object as created by
+#'   \code{\link[=shiny]{shinyApp}} et al, or, a UI object.
+#' @param server Ignored if \code{app} is a Shiny app object; otherwise, passed
+#'   along to \code{shinyApp} (i.e. \code{shinyApp(ui = app, server = server)}).
+#' @param port See \code{\link[=shiny]{runApp}}.
+#' @param viewer Specify where the gadget should be displayed--viewer pane,
+#'   dialog window, or external browser--by passing in a call to one of the
+#'   \code{\link{viewer}} functions.
+#' @param stopOnCancel If \code{TRUE} (the default), then an \code{observeEvent}
+#'   is automatically created that handles \code{input$cancel} by calling
+#'   \code{stopApp()} with an error. Pass \code{FALSE} if you want to handle
+#'   \code{input$cancel} yourself.
+#' @return The value returned by the gadget.
+#'
+#' @examples
+#' \dontrun{
+#' library(shiny)
+#'
+#' ui <- fillPage(...)
+#'
+#' server <- function(input, output, session) {
+#'   ...
+#' }
+#'
+#' # Either pass ui/server as separate arguments...
+#' runGadget(ui, server)
+#'
+#' # ...or as a single app object
+#' runGadget(shinyApp(ui, server))
+#' }
+#' @export
+runGadget <- function(app, server = NULL, port = getOption("shiny.port"),
+  viewer = paneViewer(), stopOnCancel = TRUE) {
+
+  if (!is.shiny.appobj(app)) {
+    app <- shinyApp(app, server)
+  }
+
+  if (isTRUE(stopOnCancel)) {
+    app <- decorateServerFunc(app, function(input, output, session) {
+      observeEvent(input$cancel, {
+        stopApp(stop("User cancel", call. = FALSE))
+      })
+    })
+  }
+
+  if (is.null(viewer)) {
+    viewer <- utils::browseURL
+  }
+
+  shiny::runApp(app, port = port, launch.browser = viewer)
+}
+
+# Add custom functionality to a Shiny app object's server func
+decorateServerFunc <- function(appobj, serverFunc) {
+  origServerFuncSource <- appobj$serverFuncSource
+  appobj$serverFuncSource <- function() {
+    origServerFunc <- origServerFuncSource()
+    function(input, output, session) {
+      serverFunc(input, output, session)
+
+      # The clientData and session arguments are optional; check if
+      # each exists
+      args <- argsForServerFunc(origServerFunc, session)
+      do.call(origServerFunc, args)
+    }
+  }
+  appobj
+}
+
+#' Viewer options
+#'
+#' Use these functions to control where the gadget is displayed in RStudio (or
+#' other R environments that emulate RStudio's viewer pane/dialog APIs). If
+#' viewer APIs are not available in the current R environment, then the gadget
+#' will be displayed in the system's default web browser (see
+#' \code{\link[utils]{browseURL}}).
+#'
+#' @return A function that takes a single \code{url} parameter, suitable for
+#'   passing as the \code{viewer} argument of \code{\link{runGadget}}.
+#'
+#' @rdname viewer
+#' @name viewer
+NULL
+
+#' @param minHeight The minimum height (in pixels) desired to show the gadget in
+#'   the viewer pane. If a positive number, resize the pane if necessary to show
+#'   at least that many pixels. If \code{NULL}, use the existing viewer pane
+#'   size. If \code{"maximize"}, use the maximum available vertical space.
+#' @rdname viewer
+#' @export
+paneViewer <- function(minHeight = NULL) {
+  viewer <- getOption("viewer")
+  if (is.null(viewer)) {
+    utils::browseURL
+  } else {
+    function(url) {
+      viewer(url, minHeight)
+    }
+  }
+}
+
+#' @param dialogName The window title to display for the dialog.
+#' @param width,height The desired dialog width/height, in pixels.
+#' @rdname viewer
+#' @export
+dialogViewer <- function(dialogName, width = 600, height = 600) {
+  viewer <- getOption("shinygadgets.showdialog")
+  if (is.null(viewer)) {
+    utils::browseURL
+  } else {
+    function(url) {
+      viewer(dialogName, url, width = width, height = height)
+    }
+  }
+}
+
+#' @param browser See \code{\link[utils]{browseURL}}.
+#' @rdname viewer
+#' @export
+browserViewer <- function(browser = getOption("browser")) {
+  function(url) {
+    utils::browseURL(url, browser = browser)
+  }
+}
+
+# Returns TRUE if we're running in Shiny Server or other hosting environment,
+# otherwise returns FALSE.
+inShinyServer <- function() {
+  nzchar(Sys.getenv('SHINY_PORT'))
+}

R/shiny-options.R

@@ -0,0 +1,83 @@
+.globals$options <- list()
+
+#' @param name Name of an option to get.
+#' @param default Value to be returned if the option is not currently set.
+#' @rdname shinyOptions
+#' @export
+getShinyOption <- function(name, default = NULL) {
+  # Make sure to use named (not numeric) indexing
+  name <- as.character(name)
+
+  if (name %in% names(.globals$options))
+    .globals$options[[name]]
+  else
+    default
+}
+
+#' Get or set Shiny options
+#'
+#' \code{getShinyOption} retrieves the value of a Shiny option.
+#' \code{shinyOptions} sets the value of Shiny options; it can also be used to
+#' return a list of all currently-set Shiny options.
+#'
+#' There is a global option set, which is available by default. When a Shiny
+#' application is run with \code{\link{runApp}}, that option set is duplicated
+#' and the new option set is available for getting or setting values. If options
+#' are set from global.R, app.R, ui.R, or server.R, or if they are set from
+#' inside the server function, then the options will be scoped to the
+#' application. When the application exits, the new option set is discarded and
+#' the global option set is restored.
+#'
+#' @param ... Options to set, with the form \code{name = value}.
+#'
+#' @examples
+#' \dontrun{
+#' shinyOptions(myOption = 10)
+#' getShinyOption("myOption")
+#' }
+#' @export
+shinyOptions <- function(...) {
+  newOpts <- list(...)
+
+  if (length(newOpts) > 0) {
+    .globals$options <- dropNulls(mergeVectors(.globals$options, newOpts))
+    invisible(.globals$options)
+  } else {
+    .globals$options
+  }
+}
+
+
+# Eval an expression with a new option set
+withLocalOptions <- function(expr) {
+  oldOptionSet <- .globals$options
+  on.exit(.globals$options <- oldOptionSet)
+
+  expr
+}
+
+
+# Get specific shiny options and put them in a list, reset those shiny options,
+# and then return the options list. This should be during the creation of a
+# shiny app object, which happens before another option frame is added to the
+# options stack (the new option frame is added when the app is run). This
+# function "consumes" the options when the shinyApp object is created, so the
+# options won't affect another app that is created later.
+consumeAppOptions <- function() {
+  options <- list(
+    appDir = getwd(),
+    bookmarkStore = getShinyOption("bookmarkStore")
+  )
+
+  shinyOptions(appDir = NULL, bookmarkStore = NULL)
+
+  options
+}
+
+# Do the inverse of consumeAppOptions. This should be called once the app is
+# started.
+unconsumeAppOptions <- function(options) {
+  if (!is.null(options)) {
+    do.call(shinyOptions, options)
+  }
+}

R/shinyui.R

@@ -20,61 +20,38 @@ withMathJax <- function(...) {
       singleton(tags$script(src = path, type = 'text/javascript'))
     ),
     ...,
-    tags$script(HTML('MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
+    tags$script(HTML('if (window.MathJax) MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
   )
 }
 
 renderPage <- function(ui, connection, showcase=0) {
+  # If the ui is a NOT complete document (created by htmlTemplate()), then do some
+  # preprocessing and make sure it's a complete document.
+  if (!inherits(ui, "html_document")) {
+    if (showcase > 0)
+      ui <- showcaseUI(ui)
 
-  if (showcase > 0)
-    ui <- showcaseUI(ui)
+    # Wrap ui in body tag if it doesn't already have a single top-level body tag.
+    if (!(inherits(ui, "shiny.tag") && ui$name == "body"))
+      ui <- tags$body(ui)
 
-  # Wrap ui in body tag if it doesn't already have a single top-level body tag.
-  if (!(inherits(ui, "shiny.tag") && ui$name == "body"))
-    ui <- tags$body(ui)
+    # Put the body into the default template
+    ui <- htmlTemplate(
+      system.file("template", "default.html", package = "shiny"),
+      body = ui
+    )
+  }
 
-  result <- renderTags(ui)
-
-  deps <- c(
-    list(
-      htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
-      htmlDependency("jquery", "1.11.0", c(href="shared"), script = "jquery.min.js"),
-      htmlDependency("shiny", packageVersion("shiny"), c(href="shared"),
-        script = "shiny.min.js", stylesheet = "shiny.css")
-    ),
-    result$dependencies
+  shiny_deps <- list(
+    htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-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",
+      stylesheet = "shiny.css")
   )
-  deps <- resolveDependencies(deps)
-  deps <- lapply(deps, createWebDependency)
-  depStr <- paste(sapply(deps, function(dep) {
-    sprintf("%s[%s]", dep$name, dep$version)
-  }), collapse = ";")
-  depHtml <- renderDependencies(deps, "href")
-
-  # write preamble
-  writeLines(c('<!DOCTYPE html>',
-               '<html>',
-               '<head>',
-               '  <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>',
-               sprintf('  <script type="application/shiny-singletons">%s</script>',
-                       paste(result$singletons, collapse = ',')
-               ),
-               sprintf('  <script type="application/html-dependencies">%s</script>',
-                       depStr
-               ),
-               depHtml
-              ),
-              con = connection)
-  writeLines(c(result$head,
-               '</head>',
-               recursive=TRUE),
-             con = connection)
-
-  writeLines(result$html, con = connection)
-
-  # write end document
-  writeLines('</html>',
-             con = connection)
+  html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
+  writeUTF8(html, con = connection)
 }
 
 #' Create a Shiny UI handler
@@ -87,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)
@@ -105,7 +81,7 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
     if (!isTRUE(grepl(uiPattern, req$PATH_INFO)))
       return(NULL)
 
-    textConn <- textConnection(NULL, "w")
+    textConn <- file(open = "w+")
     on.exit(close(textConn))
 
     showcaseMode <- .globals$showcaseDefault
@@ -114,19 +90,39 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
       if (!is.null(mode))
         showcaseMode <- mode
     }
-    uiValue <- if (is.function(ui)) {
-      if (length(formals(ui)) > 0)
-        ui(req)
-      else
-        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)
 
     renderPage(uiValue, textConn, showcaseMode)
-    html <- paste(textConnectionValue(textConn), collapse='\n')
+    html <- paste(readLines(textConn, encoding = 'UTF-8'), collapse='\n')
     return(httpResponse(200, content=enc2utf8(html)))
   }
 }

R/shinywrappers.R

@@ -12,24 +12,74 @@ globalVariables('func')
 #'   an output ID.
 #' @param renderFunc A function that is suitable for assigning to a Shiny output
 #'   slot.
+#' @param outputArgs A list of arguments to pass to the \code{uiFunc}. Render
+#'   functions should include \code{outputArgs = list()} in their own parameter
+#'   list, and pass through the value to \code{markRenderFunction}, to allow
+#'   app authors to customize outputs. (Currently, this is only supported for
+#'   dynamically generated UIs, such as those created by Shiny code snippets
+#'   embedded in R Markdown documents).
 #' @return The \code{renderFunc} function, with annotations.
-#'
 #' @export
-markRenderFunction <- function(uiFunc, renderFunc) {
+markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
+  # a mutable object that keeps track of whether `useRenderFunction` has been
+  # executed (this usually only happens when rendering Shiny code snippets in
+  # an interactive R Markdown document); its initial value is FALSE
+  hasExecuted <- Mutable$new()
+  hasExecuted$set(FALSE)
+
+  origRenderFunc <- renderFunc
+  renderFunc <- function(...) {
+    # if the user provided something through `outputArgs` BUT the
+    # `useRenderFunction` was not executed, then outputArgs will be ignored,
+    # so throw a warning to let user know the correct usage
+    if (length(outputArgs) != 0 && !hasExecuted$get()) {
+      warning("Unused argument: outputArgs. The argument outputArgs is only ",
+              "meant to be used when embedding snippets of Shiny code in an ",
+              "R Markdown code chunk (using runtime: shiny). When running a ",
+              "full Shiny app, please set the output arguments directly in ",
+              "the corresponding output function of your UI code.")
+      # stop warning from happening again for the same object
+      hasExecuted$set(TRUE)
+    }
+    if (is.null(formals(origRenderFunc))) origRenderFunc()
+    else origRenderFunc(...)
+  }
+
   structure(renderFunc,
-            class      = c("shiny.render.function", "function"),
-            outputFunc = uiFunc)
+            class       = c("shiny.render.function", "function"),
+            outputFunc  = uiFunc,
+            outputArgs  = outputArgs,
+            hasExecuted = hasExecuted)
 }
 
 useRenderFunction <- function(renderFunc, inline = FALSE) {
   outputFunction <- attr(renderFunc, "outputFunc")
+  outputArgs <- attr(renderFunc, "outputArgs")
+  hasExecuted <- attr(renderFunc, "hasExecuted")
+  hasExecuted$set(TRUE)
+
+  for (arg in names(outputArgs)) {
+    if (!arg %in% names(formals(outputFunction))) {
+      stop(paste0("Unused argument: in 'outputArgs', '",
+                  arg, "' is not an valid argument for ",
+                  "the output function"))
+      outputArgs[[arg]] <- NULL
+    }
+  }
+
   id <- createUniqueId(8, "out")
+  # Make the id the first positional argument
+  outputArgs <- c(list(id), outputArgs)
+
   o <- getDefaultReactiveDomain()$output
   if (!is.null(o))
     o[[id]] <- renderFunc
-  if (is.logical(formals(outputFunction)[["inline"]])) {
-    outputFunction(id, inline = inline)
-  } else outputFunction(id)
+
+  if (is.logical(formals(outputFunction)[["inline"]]) && !("inline" %in% names(outputArgs))) {
+    outputArgs[["inline"]] <- inline
+  }
+
+  do.call(outputFunction, outputArgs)
 }
 
 #' @export
@@ -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,55 +210,12 @@ 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)
-  }))
-}
-
-
-#' Table Output
-#'
-#' Creates a reactive table that is suitable for assigning to an \code{output}
-#' slot.
-#'
-#' The corresponding HTML output tag should be \code{div} and have the CSS class
-#' name \code{shiny-html-output}.
-#'
-#' @param expr An expression that returns an R object that can be used with
-#'   \code{\link[xtable]{xtable}}.
-#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}} and
-#'   \code{\link[xtable]{print.xtable}}.
-#' @param 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).
-#'
-#' @export
-renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderTable: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
   }
 
-  markRenderFunction(tableOutput, function() {
-    classNames <- getOption('shiny.table.class') %OR% 'data table table-bordered table-condensed'
-    data <- func()
-
-    if (is.null(data) || identical(data, data.frame()))
-      return("")
-
-    return(paste(
-      capture.output(
-        print(xtable(data, ...),
-              type='html',
-              html.table.attributes=paste('class="',
-                                          htmlEscape(classNames, TRUE),
-                                          '"',
-                                          sep=''), ...)),
-      collapse="\n"))
-  })
+  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
 }
 
+
 #' Printable Output
 #'
 #' Makes a reactive version of the given function that captures any printed
@@ -218,28 +238,27 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
 #'   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(capture.output(func()), collapse = "\n")
-  })
+    paste(utils::capture.output(func()), collapse = "\n")
+  }
+
+  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' Text Output
@@ -260,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)
+
+  renderFunc <- function(shinysession, name, ...) {
+    value <- func()
+    return(paste(utils::capture.output(cat(value)), collapse="\n"))
   }
 
-  markRenderFunction(textOutput, function() {
-    value <- func()
-    return(paste(capture.output(cat(value)), collapse="\n"))
-  })
+  markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' UI Output
@@ -295,46 +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)
 
-    result <- takeSingletons(result, shinysession$singletons, desingleton=FALSE)$ui
-    result <- surroundSingletons(result)
-    dependencies <- lapply(resolveDependencies(findDependencies(result)),
-      createWebDependency)
-    names(dependencies) <- NULL
+    processDeps(result, shinysession)
+  }
 
-    # renderTags returns a list with head, singletons, and html
-    output <- list(
-      html = doRenderTags(result),
-      deps = dependencies
-    )
-
-    return(output)
-  })
+  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
 }
 
 #' File Downloads
@@ -360,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
@@ -412,14 +440,17 @@ 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
 #'   separate package \pkg{DT} (\url{https://github.com/rstudio/DT}) that allows
-#'   you to create both server-side and client-side DataTables. The functions
-#'   \code{renderDataTable()} and \code{dataTableOutput()} in \pkg{shiny} have
-#'   been deprecated since v0.11.1. Please use \code{DT::renderDataTable()} and
-#'   \code{DT::dataTableOutput()} (see
+#'   you to create both server-side and client-side DataTables, and supports
+#'   additional DataTables features. Consider using \code{DT::renderDataTable()}
+#'   and \code{DT::dataTableOutput()} (see
 #'   \url{http://rstudio.github.io/DT/shiny.html} for more information).
 #' @export
 #' @inheritParams renderPlot
@@ -447,13 +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) {
-  shinyDeprecated(
-    'DT::renderDataTable', old = 'shiny::renderDataTable', version = '0.11.1'
-  )
+                            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)
@@ -464,7 +493,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     colnames <- colnames(data)
     # if escape is column names, turn names to numeric indices
     if (is.character(escape)) {
-      escape <- setNames(seq_len(ncol(data)), colnames)[escape]
+      escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
       if (any(is.na(escape)))
         stop("Some column names in the 'escape' argument not found in data")
     }
@@ -479,14 +508,18 @@ 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
 DT10Names <- function() {
   rbind(
-    read.table(system.file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
-               stringsAsFactors = FALSE),
+    utils::read.table(
+      system.file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
+      stringsAsFactors = FALSE
+    ),
     c('aoColumns', 'Removed')  # looks like an omission on the upgrade guide
   )
 }
@@ -504,7 +537,7 @@ checkDT9 <- function(options) {
     'and DataTables 1.10.x uses different parameter names with 1.9.x. ',
     'Please follow the upgrade guide https://datatables.net/upgrade/1.10-convert',
     ' to change your DataTables parameter names:\n\n',
-    paste(formatUL(nms[i]), collapse = '\n'), '\n', sep = ''
+    paste(utils::formatUL(nms[i]), collapse = '\n'), '\n', sep = ''
   )
   j <- gsub('[.].*', '', DT10[, 1]) %in% nms
   # I cannot help you upgrade automatically in these cases, so I have to stop
@@ -513,7 +546,7 @@ checkDT9 <- function(options) {
   nms10 <- DT10[match(nms[i], DT10[, 1]), 2]
   if (any(nms10 == 'Removed')) stop(
     "These parameters have been removed in DataTables 1.10.x:\n\n",
-    paste(formatUL(nms[i][nms10 == 'Removed']), collapse = '\n'),
+    paste(utils::formatUL(nms[i][nms10 == 'Removed']), collapse = '\n'),
     "\n\n", msg
   )
   names(options)[i] <- nms10

R/showcase.R

@@ -31,7 +31,7 @@ licenseLink <- function(licenseName) {
 showcaseHead <- function() {
 
   deps  <- list(
-    htmlDependency("jqueryui", "1.10.4", c(href="shared/jqueryui/1.10.4"),
+    htmlDependency("jqueryui", "1.11.4", 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/slider.R

@@ -1,26 +0,0 @@
-hasDecimals <- function(value) {
-  truncatedValue <- round(value)
-  return (!identical(value, truncatedValue))
-}
-
-#' @rdname sliderInput
-#'
-#' @param interval The interval, in milliseconds, between each animation step.
-#' @param loop \code{TRUE} to automatically restart the animation when it
-#'   reaches the end.
-#' @param playButton Specifies the appearance of the play button. Valid values
-#'   are a one-element character vector (for a simple text label), an HTML tag
-#'   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,
-                             playButton=NULL,
-                             pauseButton=NULL) {
-  list(interval=interval,
-       loop=loop,
-       playButton=playButton,
-       pauseButton=pauseButton)
-}

R/tar.R

@@ -46,7 +46,7 @@ untar2 <- function(tarfile, files = NULL, list = FALSE, exdir = ".")
     mydir.create <- function(path, ...) {
         ## for Windows' sake
         path <- sub("[\\/]$", "", path)
-        if(file_test("-d", path)) return()
+        if(utils::file_test("-d", path)) return()
         if(!dir.create(path, showWarnings = TRUE, recursive = TRUE, ...))
            stop(gettextf("failed to create directory %s", sQuote(path)),
                 domain = NA)

R/timer.R

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

R/update-input.R

@@ -6,9 +6,16 @@
 #' @seealso \code{\link{textInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   textInput("inText", "Input text"),
+#'   textInput("inText2", "Input text 2")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
@@ -22,7 +29,9 @@
 #'       label = paste("New label", x),
 #'       value = paste("New text", x))
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
@@ -30,6 +39,44 @@ updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
   session$sendInputMessage(inputId, message)
 }
 
+#' Change the value of a textarea input on the client
+#'
+#' @template update-input
+#' @param value The value to set for the input object.
+#'
+#' @seealso \code{\link{textAreaInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   textAreaInput("inText", "Input textarea"),
+#'   textAreaInput("inText2", "Input textarea 2")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     # This will change the value of input$inText, based on x
+#'     updateTextAreaInput(session, "inText", value = paste("New text", x))
+#'
+#'     # Can also set the label, this time for input$inText2
+#'     updateTextAreaInput(session, "inText2",
+#'       label = paste("New label", x),
+#'       value = paste("New text", x))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+updateTextAreaInput <- updateTextInput
+
 
 #' Change the value of a checkbox input on the client
 #'
@@ -39,26 +86,87 @@ updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
 #' @seealso \code{\link{checkboxInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 1, 0, step = 1),
+#'   checkboxInput("inCheckbox", "Input checkbox")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # TRUE if input$controller is even, FALSE otherwise.
-#'     x_even <- input$controller %% 2 == 0
+#'     # TRUE if input$controller is odd, FALSE if even.
+#'     x_even <- input$controller %% 2 == 1
 #'
 #'     updateCheckboxInput(session, "inCheckbox", value = x_even)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateCheckboxInput <- updateTextInput
 
 
+#' Change the label or icon of an action button on the client
+#'
+#' @template update-input
+#' @param icon The icon to set for the input object. To remove the
+#' current icon, use \code{icon=character(0)}.
+#'
+#' @seealso \code{\link{actionButton}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   actionButton("update", "Update other buttons"),
+#'   br(),
+#'   actionButton("goButton", "Go"),
+#'   br(),
+#'   actionButton("goButton2", "Go 2", icon = icon("area-chart")),
+#'   br(),
+#'   actionButton("goButton3", "Go 3")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observe({
+#'     req(input$update)
+#'
+#'     # Updates goButton's label and icon
+#'     updateActionButton(session, "goButton",
+#'       label = "New label",
+#'       icon = icon("calendar"))
+#'
+#'     # Leaves goButton2's label unchaged and
+#'     # removes its icon
+#'     updateActionButton(session, "goButton2",
+#'       icon = character(0))
+#'
+#'     # Leaves goButton3's icon, if it exists,
+#'     # unchaged and changes its label
+#'     updateActionButton(session, "goButton3",
+#'       label = "New label 3")
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
+  if (!is.null(icon)) icon <- as.character(validateIcon(icon))
+  message <- dropNulls(list(label=label, icon=icon))
+  session$sendInputMessage(inputId, message)
+}
+
+
 #' Change the value of a date input on the client
 #'
 #' @template update-input
 #' @param value The desired date value. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supply \code{NA} to clear the date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -67,9 +175,15 @@ updateCheckboxInput <- updateTextInput
 #' @seealso \code{\link{dateInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   dateInput("inDate", "Input date")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
@@ -82,17 +196,26 @@ updateCheckboxInput <- updateTextInput
 #'       max   = paste("2013-04-", x+1, sep="")
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
                             min = NULL, max = NULL) {
 
-  # If value is a date object, convert it to a string with yyyy-mm-dd format
-  # Same for min and max
-  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
-  if (inherits(min, "Date"))    min   <- format(min,   "%Y-%m-%d")
-  if (inherits(max, "Date"))    max   <- format(max,   "%Y-%m-%d")
+  # Make sure values are NULL or Date objects. This is so we can ensure that
+  # they will be formatted correctly. For example, the string "2016-08-9" is not
+  # correctly formatted, but the conversion to Date and back to string will fix
+  # it.
+  formatDate <- function(x) {
+    if (is.null(x))
+      return(NULL)
+    format(as.Date(x), "%Y-%m-%d")
+  }
+  value <- formatDate(value)
+  min   <- formatDate(min)
+  max   <- formatDate(max)
 
   message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
@@ -103,9 +226,9 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #'
 #' @template update-input
 #' @param start The start date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the start date.
 #' @param end The end date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the end date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -114,9 +237,15 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #' @seealso \code{\link{dateRangeInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   dateRangeInput("inDateRange", "Input date range")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
@@ -124,10 +253,13 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #'
 #'     updateDateRangeInput(session, "inDateRange",
 #'       label = paste("Date range label", x),
-#'       start = paste("2013-01-", x, sep=""))
-#'       end = paste("2013-12-", x, sep=""))
+#'       start = paste("2013-01-", x, sep=""),
+#'       end = paste("2013-12-", x, sep="")
+#'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateRangeInput <- function(session, inputId, label = NULL,
@@ -142,7 +274,7 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 
   message <- dropNulls(list(
     label = label,
-    value = c(start, end),
+    value = dropNulls(list(start = start, end = end)),
     min = min,
     max = max
   ))
@@ -162,22 +294,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) {
@@ -185,6 +326,13 @@ updateTabsetPanel <- function(session, inputId, selected = NULL) {
   session$sendInputMessage(inputId, message)
 }
 
+#' @rdname updateTabsetPanel
+#' @export
+updateNavbarPage <- updateTabsetPanel
+
+#' @rdname updateTabsetPanel
+#' @export
+updateNavlistPanel <- updateTabsetPanel
 
 #' Change the value of a number input on the client
 #'
@@ -197,10 +345,18 @@ updateTabsetPanel <- function(session, inputId, selected = NULL) {
 #' @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
@@ -211,7 +367,9 @@ updateTabsetPanel <- function(session, inputId, selected = NULL) {
 #'       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,
@@ -242,9 +400,9 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #'       sidebarLayout(
 #'         sidebarPanel(
 #'           p("The first slider controls the second"),
-#'           slider2Input("control", "Controller:", min=0, max=20, value=10,
+#'           sliderInput("control", "Controller:", min=0, max=20, value=10,
 #'                        step=1),
-#'           slider2Input("receive", "Receiver:", min=0, max=20, value=10,
+#'           sliderInput("receive", "Receiver:", min=0, max=20, value=10,
 #'                        step=1)
 #'         ),
 #'         mainPanel()
@@ -262,20 +420,53 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #'   )
 #' }
 #' @export
-updateSliderInput <- updateNumericInput
+updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
+  min = NULL, max = NULL, step = NULL)
+{
+  # Make sure that value, min, max all have the same type, because we need
+  # special handling for dates and datetimes.
+  vals <- dropNulls(list(value, min, max))
+
+  type <- unique(lapply(vals, function(x) {
+    if      (inherits(x, "Date"))   "date"
+    else if (inherits(x, "POSIXt")) "datetime"
+    else                            "number"
+  }))
+  if (length(type) > 1) {
+    stop("Type mismatch for value, min, and max")
+  }
+
+  if ((length(type) == 1) && (type == "date" || type == "datetime")) {
+    to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
+    if (!is.null(min))   min   <- to_ms(min)
+    if (!is.null(max))   max   <- to_ms(max)
+    if (!is.null(value)) value <- to_ms(value)
+  }
+
+  message <- dropNulls(list(
+    label = label,
+    value = formatNoSci(value),
+    min = formatNoSci(min),
+    max = formatNoSci(max),
+    step = formatNoSci(step)
+  ))
+  session$sendInputMessage(inputId, message)
+}
+
 
 updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
                                selected = NULL, inline = FALSE,
                                type = 'checkbox') {
-
-  choices <- choicesWithNames(choices)
+  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 (length(choices))
+  options <- if (!is.null(choices)) {
     format(tagList(
-      generateOptions(inputId, choices, selected, inline, type = type)
+      generateOptions(session$ns(inputId), choices, selected, inline, type = type)
     ))
+  }
 
   message <- dropNulls(list(label = label, options = options, value = selected))
 
@@ -290,31 +481,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,
@@ -332,33 +527,38 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' @seealso \code{\link{radioButtons}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The first radio button group controls the second"),
+#'   radioButtons("inRadioButtons", "Input radio buttons",
+#'     c("Item A", "Item B", "Item C")),
+#'   radioButtons("inRadioButtons2", "Input radio buttons 2",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inRadioButtons
 #'
-#'     r_options <- list()
-#'     r_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     r_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
-#'
-#'     # Change values for input$inRadio
-#'     updateRadioButtons(session, "inRadio", choices = r_options)
-#'
-#'     # Can also set the label and select an item
-#'     updateRadioButtons(session, "inRadio2",
-#'       label = paste("Radio label", x),
-#'       choices = r_options,
-#'       selected = sprintf("option-%d-2", x)
+#'     # Can also set the label and select items
+#'     updateRadioButtons(session, "inRadioButtons2",
+#'       label = paste("radioButtons label", x),
+#'       choices = x,
+#'       selected = x
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
                                selected = NULL, inline = FALSE) {
+  if (!is.null(choices)) choices <- as.character(choices)
+  if (!is.null(selected)) selected <- as.character(selected)
+
   # you must select at least one radio button
   if (is.null(selected) && !is.null(choices)) selected <- choices[[1]]
   updateInputOptions(session, inputId, label, choices, selected, inline, type = 'radio')
@@ -373,32 +573,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,
@@ -435,13 +638,10 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
   value <- unname(selected)
-  selected <- choicesWithNames(selected)
+  attr(choices, 'selected_value') <- value
   message <- dropNulls(list(
     label = label,
     value = value,
-    selected = if (length(selected)) {
-      columnToRowData(list(label = names(selected), value = selected))
-    },
     url = session$registerDataObj(inputId, choices, selectizeJSON)
   ))
   session$sendInputMessage(inputId, message)
@@ -450,12 +650,14 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
 selectizeJSON <- function(data, req) {
   query <- parseQueryString(req$QUERY_STRING)
   # extract the query variables, conjunction (and/or), search string, maximum options
-  var <- unlist(jsonlite::fromJSON(query$field))
+  var <- c(jsonlite::fromJSON(query$field))
   cjn <- if (query$conju == 'and') all else any
   # all keywords in lower-case, for case-insensitive matching
   key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
   if (identical(key, '')) key <- character(0)
-  mop <- query$maxop
+  mop <- as.numeric(query$maxop)
+  vfd <- query$value  # the value field name
+  sel <- attr(data, 'selected_value', exact = TRUE)
 
   # convert a single vector to a data frame so it returns {label: , value: }
   # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
@@ -478,7 +680,12 @@ selectizeJSON <- function(data, req) {
     idx <- idx | apply(matches, 1, cjn)
   }
   # only return the first n rows (n = maximum options in configuration)
-  idx <- head(if (length(key)) which(idx) else seq_along(idx), mop)
+  idx <- utils::head(if (length(key)) which(idx) else seq_along(idx), mop)
+  # make sure the selected value is in the data
+  if (length(sel)) {
+    i <- stats::na.omit(match(sel, data[, vfd]))
+    if (length(i)) idx <- sort(utils::head(unique(c(i, idx)), mop))
+  }
   data <- data[idx, ]
 
   res <- toJSON(columnToRowData(data))

R/utils.R

@@ -23,9 +23,8 @@ 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 = runif(1, 0, .Machine$integer.max)) {
+repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max)) {
   force(seed)
 
   function(...) {
@@ -95,7 +94,7 @@ reinitializeSeed <- if (getRversion() >= '3.0.0') {
 
 # Version of runif that runs with private seed
 p_runif <- function(...) {
-  withPrivateSeed(runif(...))
+  withPrivateSeed(stats::runif(...))
 }
 
 # Version of sample that runs with private seed
@@ -155,6 +154,20 @@ dropNullsOrEmpty <- function(x) {
   x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
 }
 
+# Given a vector/list, return TRUE if any elements are named, FALSE otherwise.
+anyNamed <- function(x) {
+  # Zero-length vector
+  if (length(x) == 0) return(FALSE)
+
+  nms <- names(x)
+
+  # List with no name attribute
+  if (is.null(nms)) return(FALSE)
+
+  # List with name attribute; check for any ""
+  any(nzchar(nms))
+}
+
 # Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
 anyUnnamed <- function(x) {
   # Zero-length vector
@@ -169,6 +182,21 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
+# Given two named vectors, join them together, and keep only the last element
+# with a given name in the resulting vector. If b has any elements with the same
+# name as elements in a, the element in a is dropped. Also, if there are any
+# duplicated names in a or b, only the last one with that name is kept.
+mergeVectors <- function(a, b) {
+  if (anyUnnamed(a) || anyUnnamed(b)) {
+    stop("Vectors must be either NULL or have names for all elements")
+  }
+
+  x <- c(a, b)
+  drop_idx <- duplicated(names(x), fromLast = TRUE)
+  x[!drop_idx]
+}
+
+
 # Combine dir and (file)name into a file path. If a file already exists with a
 # name differing only by case, then use it instead.
 file.path.ci <- function(...) {
@@ -211,6 +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.
@@ -248,23 +282,49 @@ download <- function(url, ...) {
   # First, check protocol. If http or https, check platform:
   if (grepl('^https?://', url)) {
 
-    # If Windows, call setInternet2, then use download.file with defaults.
-    if (isWindows()) {
-      # If we directly use setInternet2, R CMD CHECK gives a Note on Mac/Linux
-      mySI2 <- `::`(utils, 'setInternet2')
-      # Store initial settings
-      internet2_start <- mySI2(NA)
-      on.exit(mySI2(internet2_start))
+    # Check whether we are running R 3.2
+    isR32 <- getRversion() >= "3.2"
 
-      # Needed for https
-      mySI2(TRUE)
-      download.file(url, ...)
+    # Windows
+    if (.Platform$OS.type == "windows") {
+
+      if (isR32) {
+        method <- "wininet"
+      } else {
+
+        # If we directly use setInternet2, R CMD CHECK gives a Note on Mac/Linux
+        seti2 <- `::`(utils, 'setInternet2')
+
+        # Check whether we are already using internet2 for internal
+        internet2_start <- seti2(NA)
+
+        # If not then temporarily set it
+        if (!internet2_start) {
+          # Store initial settings, and restore on exit
+          on.exit(suppressWarnings(seti2(internet2_start)))
+
+          # Needed for https. Will get warning if setInternet2(FALSE) already run
+          # and internet routines are used. But the warnings don't seem to matter.
+          suppressWarnings(seti2(TRUE))
+        }
+
+        method <- "internal"
+      }
+
+      # download.file will complain about file size with something like:
+      #       Warning message:
+      #         In download.file(url, ...) : downloaded length 19457 != reported length 200
+      # because apparently it compares the length with the status code returned (?)
+      # so we supress that
+      suppressWarnings(utils::download.file(url, method = method, ...))
 
     } else {
-      # If non-Windows, check for curl/wget/lynx, then call download.file with
+      # If non-Windows, check for libcurl/curl/wget/lynx, then call download.file with
       # appropriate method.
 
-      if (nzchar(Sys.which("wget")[1])) {
+      if (isR32 && capabilities("libcurl")) {
+        method <- "libcurl"
+      } else if (nzchar(Sys.which("wget")[1])) {
         method <- "wget"
       } else if (nzchar(Sys.which("curl")[1])) {
         method <- "curl"
@@ -282,11 +342,11 @@ download <- function(url, ...) {
         stop("no download method found")
       }
 
-      download.file(url, method = method, ...)
+      utils::download.file(url, method = method, ...)
     }
 
   } else {
-    download.file(url, ...)
+    utils::download.file(url, ...)
   }
 }
 
@@ -317,8 +377,6 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #' @param env The desired environment for the function. Defaults to the
 #'   calling environment two steps back.
 #' @param quoted Is the expression quoted?
-#' @param caller_offset If specified, the offset in the callstack of the
-#'   functiont to be treated as the caller.
 #'
 #' @examples
 #' # Example of a new renderer, similar to renderText
@@ -352,35 +410,14 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #'
 #' isolate(tripleA())
 #' # "text, text, text"
-#'
 #' @export
-exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE,
-                           caller_offset=1) {
-  # Get the quoted expr from two calls back
-  expr_sub <- eval(substitute(substitute(expr)), parent.frame(caller_offset))
-
-  # Check if expr is a function, making sure not to evaluate expr, in case it
-  # is actually an unquoted expression.
-  # If expr is a single token, then indexing with [[ will error; if it has multiple
-  # tokens, then [[ works. In the former case it will be a name object; in the
-  # latter, it will be a language object.
-  if (!is.null(expr_sub) && !is.name(expr_sub) && expr_sub[[1]] == as.name('function')) {
-    # Get name of function that called this function
-    called_fun <- sys.call(-1 * caller_offset)[[1]]
-
-    shinyDeprecated(msg = paste("Passing functions to '", called_fun,
-      "' is deprecated. Please use expressions instead. See ?", called_fun,
-      " for more information.", sep=""))
-    return(expr)
+exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
+  if (!quoted) {
+    expr <- eval(substitute(substitute(expr)), parent.frame())
   }
 
-  if (quoted) {
-    # expr is a quoted expression
-    makeFunction(body=expr, env=env)
-  } else {
-    # expr is an unquoted expression
-    makeFunction(body=expr_sub, env=env)
-  }
+  # expr is a quoted expression
+  makeFunction(body=expr, env=env)
 }
 
 #' Install an expression as a function
@@ -404,15 +441,32 @@ exprToFunction <- function(expr, env=parent.frame(2), quoted=FALSE,
 #' @param assign.env The environment in which the function should be assigned.
 #' @param label A label for the object to be shown in the debugger. Defaults to
 #'   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,
                                 assign.env = parent.frame(1),
-                                label = as.character(sys.call(-1)[[1]])) {
-  func <- exprToFunction(expr, eval.env, quoted, 2)
+                                label = deparse(sys.call(-1)[[1]]),
+                                wrappedWithLabel = TRUE,
+                                ..stacktraceon = FALSE) {
+  if (!quoted) {
+    quoted <- TRUE
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+
+  func <- exprToFunction(expr, eval.env, quoted)
+  if (length(label) > 1) {
+    # Just in case the deparsed code is more complicated than we imagine. If we
+    # have a label with length > 1 it causes warnings in wrapFunctionLabel.
+    label <- paste0(label, collapse = "\n")
+  }
+  if (wrappedWithLabel) {
+    func <- wrapFunctionLabel(func, label, ..stacktraceon = ..stacktraceon)
+  } else {
+    registerDebugHook(name, assign.env, label)
+  }
   assign(name, func, envir = assign.env)
-  registerDebugHook(name, assign.env, label)
 }
 
 #' Parse a GET query string from a URL
@@ -432,10 +486,10 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
 #'
 #' \dontrun{
 #' # Example of usage within a Shiny app
-#' shinyServer(function(input, output, clientData) {
+#' function(input, output, session) {
 #'
 #'   output$queryText <- renderText({
-#'     query <- parseQueryString(clientData$url_search)
+#'     query <- parseQueryString(session$clientData$url_search)
 #'
 #'     # Ways of accessing the values
 #'     if (as.numeric(query$foo) == 1) {
@@ -448,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) {
@@ -460,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))
@@ -474,7 +530,7 @@ parseQueryString <- function(str, nested = FALSE) {
   keys   <- URLdecode(keys)
   values <- URLdecode(values)
 
-  res <- setNames(as.list(values), keys)
+  res <- stats::setNames(as.list(values), keys)
   if (!nested) return(res)
 
   # Make a nested list from a query of the form ?a[1][1]=x11&a[1][2]=x12&...
@@ -498,11 +554,18 @@ assignNestedList <- function(x = list(), idx, value) {
 
 # decide what to do in case of errors; it is customizable using the shiny.error
 # option (e.g. we can set options(shiny.error = recover))
+#' @include conditions.R
 shinyCallingHandlers <- function(expr) {
-  withCallingHandlers(expr, error = function(e) {
-    handle <- getOption('shiny.error')
-    if (is.function(handle)) handle()
-  })
+  withCallingHandlers(captureStackTraces(expr),
+    error = function(e) {
+      # Don't intercept shiny.silent.error (i.e. validation errors)
+      if (inherits(e, "shiny.silent.error"))
+        return()
+
+      handle <- getOption('shiny.error')
+      if (is.function(handle)) handle()
+    }
+  )
 }
 
 #' Print message for deprecated functions in Shiny
@@ -568,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) {
@@ -579,12 +645,28 @@ Callbacks <- R6Class(
         .callbacks$remove(id)
       })
     },
-    invoke = function(..., onError=NULL) {
-      for (callback in .callbacks$values()) {
+    invoke = function(..., onError=NULL, ..stacktraceon = FALSE) {
+      # Ensure that calls are invoked in the order that they were registered
+      keys <- as.character(sort(as.integer(.callbacks$keys()), decreasing = TRUE))
+      callbacks <- .callbacks$mget(keys)
+
+      for (callback in callbacks) {
         if (is.null(onError)) {
-          callback(...)
+          if (..stacktraceon) {
+            ..stacktraceon..(callback(...))
+          } else {
+            callback(...)
+          }
         } else {
-          tryCatch(callback(...), error = onError)
+          tryCatch(
+            captureStackTraces(
+              if (..stacktraceon)
+                ..stacktraceon..(callback(...))
+              else
+                callback(...)
+            ),
+            error = onError
+          )
         }
       }
     },
@@ -602,9 +684,24 @@ dataTablesJSON <- function(data, req) {
   q <- parseQueryString(params, nested = TRUE)
   ci <- q$search[['caseInsensitive']] == 'true'
 
+  # data may have been replaced/updated in the new table while the Ajax request
+  # from the previous table is still on its way, so it is possible that the old
+  # request asks for more columns than the current data, in which case we should
+  # discard this request and return empty data; the next Ajax request from the
+  # new table will retrieve the correct number of columns of data
+  if (length(q$columns) != ncol(data)) {
+    res <- toJSON(list(
+      draw = as.integer(q$draw),
+      recordsTotal = n,
+      recordsFiltered = 0,
+      data = NULL
+    ))
+    return(httpResponse(200, 'application/json', enc2utf8(res)))
+  }
+
   # global searching
   i <- seq_len(n)
-  if (q$search[['value']] != '') {
+  if (length(q$search[['value']]) && q$search[['value']] != '') {
     i0 <- apply(data, 2, function(x) {
       grep2(q$search[['value']], as.character(x),
             fixed = q$search[['regex']] == 'false', ignore.case = ci)
@@ -802,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
@@ -858,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!'),
@@ -875,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
@@ -888,15 +1127,14 @@ validate <- function(..., errorClass = character(0)) {
       stop("Unexpected validation result: ", as.character(x))
   })
 
-  results <- na.omit(results)
+  results <- stats::na.omit(results)
   if (length(results) == 0)
     return(invisible())
 
   # 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
@@ -919,6 +1157,202 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
     return(invisible(NULL))
 }
 
+#' Check for required values
+#'
+#' Ensure that values are available ("truthy"--see Details) before proceeding
+#' with a calculation or action. If any of the given values is not truthy, the
+#' operation is stopped by raising a "silent" exception (not logged by Shiny,
+#' nor displayed in the Shiny app's UI).
+#'
+#' The \code{req} function was designed to be used in one of two ways. The first
+#' is to call it like a statement (ignoring its return value) before attempting
+#' operations using the required values:
+#'
+#' \preformatted{rv <- reactiveValues(state = FALSE)
+#' r <- reactive({
+#'   req(input$a, input$b, rv$state)
+#'   # Code that uses input$a, input$b, and/or rv$state...
+#' })}
+#'
+#' In this example, if \code{r()} is called and any of \code{input$a},
+#' \code{input$b}, and \code{rv$state} are \code{NULL}, \code{FALSE}, \code{""},
+#' etc., then the \code{req} call will trigger an error that propagates all the
+#' way up to whatever render block or observer is executing.
+#'
+#' The second is to use it to wrap an expression that must be truthy:
+#'
+#' \preformatted{output$plot <- renderPlot({
+#'   if (req(input$plotType) == "histogram") {
+#'     hist(dataset())
+#'   } else if (input$plotType == "scatter") {
+#'     qplot(dataset(), aes(x = x, y = y))
+#'   }
+#' })}
+#'
+#' In this example, \code{req(input$plotType)} first checks that
+#' \code{input$plotType} is truthy, and if so, returns it. This is a convenient
+#' way to check for a value "inline" with its first use.
+#'
+#' \strong{Truthy and falsy values}
+#'
+#' The terms "truthy" and "falsy" generally indicate whether a value, when
+#' coerced to a \code{\link{logical}}, is \code{TRUE} or \code{FALSE}. We use
+#' the term a little loosely here; our usage tries to match the intuitive
+#' notions of "Is this value missing or available?", or "Has the user provided
+#' an answer?", or in the case of action buttons, "Has the button been
+#' clicked?".
+#'
+#' For example, a \code{textInput} that has not been filled out by the user has
+#' a value of \code{""}, so that is considered a falsy value.
+#'
+#' To be precise, \code{req} considers a value truthy \emph{unless} it is one
+#' of:
+#'
+#' \itemize{
+#'   \item{\code{FALSE}}
+#'   \item{\code{NULL}}
+#'   \item{\code{""}}
+#'   \item{An empty atomic vector}
+#'   \item{An atomic vector that contains only missing values}
+#'   \item{A logical vector that contains all \code{FALSE} or missing values}
+#'   \item{An object of class \code{"try-error"}}
+#'   \item{A value that represents an unclicked \code{\link{actionButton}}}
+#' }
+#'
+#' Note in particular that the value \code{0} is considered truthy, even though
+#' \code{as.logical(0)} is \code{FALSE}.
+#'
+#' If the built-in rules for truthiness do not match your requirements, you can
+#' always work around them. Since \code{FALSE} is falsy, you can simply provide
+#' the results of your own checks to \code{req}:
+#'
+#' \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 {
+        reactiveStop(class = "validation")
+      }
+    }
+  }, ...)
+
+  if (!missing(..1))
+    ..1
+  else
+    invisible()
+}
+
+#***********************************************************************#
+#**** Keep this function internal for now, may chnage in the future ****#
+#***********************************************************************#
+# #' Cancel processing of the current output
+# #'
+# #' Signals an error that Shiny treats specially if an output is currently being
+# #' evaluated. Execution will stop, but rather than clearing the output (as
+# #' \code{\link{req}} does) or showing an error message (as \code{\link{stop}}
+# #' does), the output simply remains unchanged.
+# #'
+# #' If \code{cancelOutput} is called in any non-output context (like in an
+# #' \code{\link{observe}} or \code{\link{observeEvent}}), the effect is the same
+# #' as \code{\link{req}(FALSE)}.
+# #' @export
+# #' @examples
+# #' ## Only run examples in interactive R sessions
+# #' if (interactive()) {
+# #'
+# #' # uncomment the desired line to experiment with cancelOutput() vs. req()
+# #'
+# #' ui <- fluidPage(
+# #'   textInput('txt', 'Enter text'),
+# #'   textOutput('check')
+# #' )
+# #'
+# #' server <- function(input, output) {
+# #'   output$check <- renderText({
+# #'     # req(input$txt)
+# #'     if (input$txt == 'hi') return('hi')
+# #'     else if (input$txt == 'bye') return('bye')
+# #'     # else cancelOutput()
+# #'   })
+# #' }
+# #'
+# #' shinyApp(ui, server)
+# #' }
+cancelOutput <- function() {
+  reactiveStop(class = "shiny.output.cancel")
+}
+
+# Execute a function against each element of ..., but only evaluate each element
+# after the previous element has been passed to fun_. The return value of fun_
+# is discarded, and only invisible() is returned from dotloop.
+#
+# Can be used to facilitate short-circuit eval on dots.
+dotloop <- function(fun_, ...) {
+  for (i in 1:(nargs()-1)) {
+    fun_(eval(as.symbol(paste0("..", i))))
+  }
+  invisible()
+}
+
+#' @export
+#' @rdname req
 isTruthy <- function(x) {
   if (inherits(x, 'try-error'))
     return(FALSE)
@@ -932,11 +1366,11 @@ isTruthy <- function(x) {
     return(FALSE)
   if (all(is.na(x)))
     return(FALSE)
-  if (is.character(x) && !any(nzchar(na.omit(x))))
+  if (is.character(x) && !any(nzchar(stats::na.omit(x))))
     return(FALSE)
   if (inherits(x, 'shinyActionButtonValue') && x == 0)
     return(FALSE)
-  if (is.logical(x) && !any(na.omit(x)))
+  if (is.logical(x) && !any(stats::na.omit(x)))
     return(FALSE)
 
   return(TRUE)
@@ -947,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)
 }
@@ -975,8 +1409,7 @@ setServerInfo <- function(...) {
   .globals$serverInfo <- infoOld
 }
 
-# see if the file can be read as UTF-8 on Windows, and converted from UTF-8 to
-# native encoding; if the conversion fails, it will produce NA's in the results
+# assume file is encoded in UTF-8, but warn against BOM
 checkEncoding <- function(file) {
   # skip *nix because its locale is normally UTF-8 based (e.g. en_US.UTF-8), and
   # *nix users have to make a conscious effort to save a file with an encoding
@@ -985,14 +1418,10 @@ checkEncoding <- function(file) {
   # world of consistency (falling back to getOption('encoding') will not help
   # because native.enc is also normally UTF-8 based on *nix)
   if (!isWindows()) return('UTF-8')
-  # an empty file?
   size <- file.info(file)[, 'size']
-  if (size == 0) return('UTF-8')
-
-  x <- readLines(file, encoding = 'UTF-8', warn = FALSE)
-  # if conversion is successful and there are no embedded nul's, use UTF-8
-  if (!any(is.na(iconv(x, 'UTF-8'))) &&
-        !any(readBin(file, 'raw', size) == as.raw(0))) return('UTF-8')
+  if (is.na(size)) stop('Cannot access the file ', file)
+  # BOM is 3 bytes, so if the file contains BOM, it must be at least 3 bytes
+  if (size < 3L) return('UTF-8')
 
   # check if there is a BOM character: this is also skipped on *nix, because R
   # on *nix simply ignores this meaningless character if present, but it hurts
@@ -1001,44 +1430,123 @@ checkEncoding <- function(file) {
     warning('You should not include the Byte Order Mark (BOM) in ', file, '. ',
             'Please re-save it in UTF-8 without BOM. See ',
             'http://shiny.rstudio.com/articles/unicode.html for more info.')
-    if (getRversion() < '3.0.0')
-      stop('R does not support UTF-8-BOM before 3.0.0. Please upgrade R.')
     return('UTF-8-BOM')
   }
-
-  enc <- getOption('encoding')
-  msg <- c(sprintf('The file "%s" is not encoded in UTF-8. ', file),
-           'Please convert its encoding to UTF-8 ',
-           '(e.g. use the menu `File -> Save with Encoding` in RStudio). ',
-           'See http://shiny.rstudio.com/articles/unicode.html for more info.')
-  if (enc == 'UTF-8') stop(msg)
-  # if you publish the app to ShinyApps.io, you will be in trouble
-  warning(c(msg, ' Falling back to the encoding "', enc, '".'))
-
-  enc
+  x <- readChar(file, size, useBytes = TRUE)
+  if (is.na(iconv(x, 'UTF-8', 'UTF-8'))) {
+    warning('The input file ', file, ' does not seem to be encoded in UTF8')
+  }
+  'UTF-8'
 }
 
-# try to read a file using UTF-8 (fall back to getOption('encoding') in case of
-# failure, which defaults to native.enc, i.e. native encoding)
+# read a file using UTF-8 and (on Windows) convert to native encoding if possible
 readUTF8 <- function(file) {
   enc <- checkEncoding(file)
-  # readLines() does not support UTF-8-BOM directly; has to go through file()
-  if (enc == 'UTF-8-BOM') {
-    file <- base::file(file, encoding = enc)
-    on.exit(close(file), add = TRUE)
-  }
-  x <- readLines(file, encoding = enc, warn = FALSE)
-  enc2native(x)
+  file <- base::file(file, encoding = enc)
+  on.exit(close(file), add = TRUE)
+  x <- enc2utf8(readLines(file, warn = FALSE))
+  tryNativeEncoding(x)
+}
+
+# if the UTF-8 string can be represented in the native encoding, use native encoding
+tryNativeEncoding <- function(string) {
+  if (!isWindows()) return(string)
+  string2 <- enc2native(string)
+  if (identical(enc2utf8(string2), string)) string2 else string
 }
 
 # similarly, try to source() a file with UTF-8
-sourceUTF8 <- function(file, ...) {
-  source(file, ..., keep.source = TRUE, encoding = checkEncoding(file))
+sourceUTF8 <- function(file, envir = globalenv()) {
+  lines <- readUTF8(file)
+  enc <- if (any(Encoding(lines) == 'UTF-8')) 'UTF-8' else 'unknown'
+  src <- srcfilecopy(file, lines, isFile = TRUE)  # source reference info
+  # oddly, parse(file) does not work when file contains multibyte chars that
+  # **can** be encoded natively on Windows (might be a bug in base R); we
+  # rewrite the source code in a natively encoded temp file and parse it in this
+  # case (the source reference is still pointed to the original file, though)
+  if (isWindows() && enc == 'unknown') {
+    file <- tempfile(); on.exit(unlink(file), add = TRUE)
+    writeLines(lines, file)
+  }
+  exprs <- try(parse(file, keep.source = FALSE, srcfile = src, encoding = enc))
+  if (inherits(exprs, "try-error")) {
+    diagnoseCode(file)
+    stop("Error sourcing ", file)
+  }
+
+  # Wrap the exprs in first `{`, then ..stacktraceon..(). It's only really the
+  # ..stacktraceon..() that we care about, but the `{` is needed to make that
+  # possible.
+  exprs <- makeCall(`{`, exprs)
+  # Need to wrap exprs in a list because we want it treated as a single argument
+  exprs <- makeCall(..stacktraceon.., list(exprs))
+
+  eval(exprs, envir)
 }
 
+# @param func Name of function, in unquoted form
+# @param args An evaluated list of unevaluated argument expressions
+makeCall <- function(func, args) {
+  as.call(c(list(substitute(func)), args))
+}
+
+# a workaround for https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16264
+srcfilecopy <- function(filename, lines, ...) {
+  if (getRversion() > '3.2.2') return(base::srcfilecopy(filename, lines, ...))
+  src <- base::srcfilecopy(filename, lines = '', ...)
+  src$lines <- lines
+  src
+}
+
+# write text as UTF-8
+writeUTF8 <- function(text, ...) {
+  text <- enc2utf8(text)
+  writeLines(text, ..., useBytes = TRUE)
+}
 
 URLdecode <- decodeURIComponent
 URLencode <- function(value, reserved = FALSE) {
   value <- enc2utf8(value)
   if (reserved) encodeURIComponent(value) else encodeURI(value)
 }
+
+
+# This function takes a name and function, and it wraps that function in a new
+# function which calls the original function using the specified name. This can
+# be helpful for profiling, because the specified name will show up on the stack
+# trace.
+wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
+  if (name == "name" || name == "func" || name == "relabelWrapper") {
+    stop("Invalid name for wrapFunctionLabel: ", name)
+  }
+  assign(name, func, environment())
+  registerDebugHook(name, environment(), name)
+
+  relabelWrapper <- eval(substitute(
+    function(...) {
+      # This `f` gets renamed to the value of `name`. Note that it may not
+      # print as the new name, because of source refs stored in the function.
+      if (..stacktraceon)
+        ..stacktraceon..(f(...))
+      else
+        f(...)
+    },
+    list(f = as.name(name))
+  ))
+
+  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.
 
@@ -11,7 +13,7 @@ For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstu
 * Build useful web applications with only a few lines of code—no JavaScript required.
 * Shiny applications are automatically "live" in the same way that spreadsheets are live. Outputs change instantly as users modify inputs, without requiring a reload of the browser.
 * Shiny user interfaces can be built entirely using R, or can be written directly in HTML, CSS, and JavaScript for more flexibility.
-* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.)
+* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.).
 * Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/2.3.2/).
 * A highly customizable slider widget with built-in support for animation.
 * Pre-built output widgets for displaying plots, tables, and printed output of R objects.

appveyor.yml

@@ -0,0 +1,42 @@
+# 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
+
+# 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

@@ -0,0 +1,6 @@
+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

@@ -5,6 +5,8 @@ sd_section("UI Layout",
     "bootstrapPage",
     "column",
     "conditionalPanel",
+    "fillPage",
+    "fillRow",
     "fixedPage",
     "fluidPage",
     "headerPanel",
@@ -42,7 +44,10 @@ sd_section("UI Inputs",
     "sliderInput",
     "submitButton",
     "textInput",
+    "textAreaInput",
     "passwordInput",
+    "modalButton",
+    "updateActionButton",
     "updateCheckboxGroupInput",
     "updateCheckboxInput",
     "updateDateInput",
@@ -52,14 +57,15 @@ sd_section("UI Inputs",
     "updateSelectInput",
     "updateSliderInput",
     "updateTabsetPanel",
-    "updateTextInput"
+    "updateTextInput",
+    "updateTextAreaInput",
+    "updateQueryString"
   )
 )
 sd_section("UI Outputs",
   "Functions for creating user interface elements that, in conjunction with rendering functions, display different kinds of output from your application.",
   c(
     "htmlOutput",
-    "imageOutput",
     "plotOutput",
     "outputOptions",
     "tableOutput",
@@ -67,7 +73,11 @@ sd_section("UI Outputs",
     "verbatimTextOutput",
     "downloadButton",
     "Progress",
-    "withProgress"
+    "withProgress",
+    "modalDialog",
+    "urlModal",
+    "showModal",
+    "showNotification"
   )
 )
 sd_section("Interface builder functions",
@@ -79,7 +89,12 @@ sd_section("Interface builder functions",
     "singleton",
     "tag",
     "validateCssUnit",
-    "withTags"
+    "withTags",
+    "htmlTemplate",
+    "bootstrapLib",
+    "suppressDependencies",
+    "insertUI",
+    "removeUI"
   )
 )
 sd_section("Rendering functions",
@@ -115,6 +130,7 @@ sd_section("Reactive constructs",
     "reactiveTimer",
     "reactiveValues",
     "reactiveValuesToList",
+    "freezeReactiveValue",
     "domains",
     "showReactLog"
   )
@@ -130,9 +146,22 @@ sd_section("Running",
   "Functions that are used to run or stop Shiny applications.",
   c(
     "runApp",
+    "runGadget",
     "runExample",
+    "runGadget",
     "runUrl",
-    "stopApp"
+    "stopApp",
+    "viewer"
+  )
+)
+sd_section("Bookmarking state",
+  "Functions that are used for bookmarking and restoring state.",
+  c(
+    "bookmarkButton",
+    "enableBookmarking",
+    "setBookmarkExclude",
+    "showBookmarkUrlModal",
+    "onBookmark"
   )
 )
 sd_section("Extending Shiny",
@@ -148,8 +177,13 @@ sd_section("Extending Shiny",
 sd_section("Utility functions",
   "Miscellaneous utilities that may be useful to advanced users or when extending Shiny.",
   c(
+    "req",
     "validate",
     "session",
+    "shinyOptions",
+    "safeError",
+    "onFlush",
+    "restoreInput",
     "exprToFunction",
     "installExprFunction",
     "parseQueryString",
@@ -160,6 +194,24 @@ sd_section("Utility functions",
     "shiny-options"
   )
 )
+sd_section("Plot interaction",
+  "Functions related to interactive plots",
+  c(
+    "brushedPoints",
+    "brushOpts",
+    "clickOpts",
+    "dblclickOpts",
+    "hoverOpts",
+    "nearPoints"
+  )
+)
+sd_section("Modules",
+  "Functions for modularizing Shiny apps",
+  c(
+    "NS",
+    "callModule"
+  )
+)
 sd_section("Embedding",
   "Functions that are intended for third-party packages that embed Shiny applications.",
   c(

inst/template/default.html

@@ -0,0 +1,7 @@
+<!DOCTYPE html>
+<html>
+<head>
+{{ headContent() }}
+</head>
+{{ body }}
+</html>

inst/tests/test-staticdocs.R

@@ -1,35 +0,0 @@
-context("staticdocs")
-
-test_that("All man pages have an entry in staticdocs/index.r", {
-  if (!all(file.exists(c('../../inst/staticdocs', '../../man')))) {
-    # This test works only when run against a package directory
-    return()
-  }
-  # Known not to be indexed
-  known_unindexed <- c("shiny-package", "knitr_methods", "knitr_methods_htmltools")
-
-  indexed_topics <- local({
-    result <- character(0)
-    sd_section <- function(dummy1, dummy2, section_topics) {
-      result <<- c(result, section_topics)
-    }
-    source("../../inst/staticdocs/index.r", local = TRUE)
-    result
-  })
-
-  all_topics <- sub("\\.Rd", "", list.files("../../man", pattern = "*.Rd"))
-
-  # This test ensures that every documented topic is included in
-  # staticdocs/index.r, unless explicitly waived by specifying it
-  # in the known_unindexed variable above.
-  missing <- setdiff(sort(all_topics), sort(c(known_unindexed, indexed_topics)))
-  unknown <- setdiff(sort(c(known_unindexed, indexed_topics)), sort(all_topics))
-  expect_equal(length(missing), 0,
-    info = paste("Functions missing from index:\n",
-      paste("  ", missing, sep = "", collapse = "\n"),
-      sep = ""))
-  expect_equal(length(unknown), 0,
-    info = paste("Unrecognized functions in index.r:\n",
-      paste("  ", unknown, sep = "", collapse = "\n"),
-      sep = ""))
-})

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

@@ -1,9 +1,8 @@
 /*!
- * Bootstrap v3.3.1 (http://getbootstrap.com)
- * Copyright 2011-2014 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,
 .btn-primary,
 .btn-success,
@@ -29,6 +28,27 @@
   -webkit-box-shadow: inset 0 3px 5px rgba(0, 0, 0, .125);
           box-shadow: inset 0 3px 5px rgba(0, 0, 0, .125);
 }
+.btn-default.disabled,
+.btn-primary.disabled,
+.btn-success.disabled,
+.btn-info.disabled,
+.btn-warning.disabled,
+.btn-danger.disabled,
+.btn-default[disabled],
+.btn-primary[disabled],
+.btn-success[disabled],
+.btn-info[disabled],
+.btn-warning[disabled],
+.btn-danger[disabled],
+fieldset[disabled] .btn-default,
+fieldset[disabled] .btn-primary,
+fieldset[disabled] .btn-success,
+fieldset[disabled] .btn-info,
+fieldset[disabled] .btn-warning,
+fieldset[disabled] .btn-danger {
+  -webkit-box-shadow: none;
+          box-shadow: none;
+}
 .btn-default .badge,
 .btn-primary .badge,
 .btn-success .badge,
@@ -63,8 +83,24 @@
   background-color: #e0e0e0;
   border-color: #dbdbdb;
 }
-.btn-default:disabled,
-.btn-default[disabled] {
+.btn-default.disabled,
+.btn-default[disabled],
+fieldset[disabled] .btn-default,
+.btn-default.disabled:hover,
+.btn-default[disabled]:hover,
+fieldset[disabled] .btn-default:hover,
+.btn-default.disabled:focus,
+.btn-default[disabled]:focus,
+fieldset[disabled] .btn-default:focus,
+.btn-default.disabled.focus,
+.btn-default[disabled].focus,
+fieldset[disabled] .btn-default.focus,
+.btn-default.disabled:active,
+.btn-default[disabled]:active,
+fieldset[disabled] .btn-default:active,
+.btn-default.disabled.active,
+.btn-default[disabled].active,
+fieldset[disabled] .btn-default.active {
   background-color: #e0e0e0;
   background-image: none;
 }
@@ -88,8 +124,24 @@
   background-color: #265a88;
   border-color: #245580;
 }
-.btn-primary:disabled,
-.btn-primary[disabled] {
+.btn-primary.disabled,
+.btn-primary[disabled],
+fieldset[disabled] .btn-primary,
+.btn-primary.disabled:hover,
+.btn-primary[disabled]:hover,
+fieldset[disabled] .btn-primary:hover,
+.btn-primary.disabled:focus,
+.btn-primary[disabled]:focus,
+fieldset[disabled] .btn-primary:focus,
+.btn-primary.disabled.focus,
+.btn-primary[disabled].focus,
+fieldset[disabled] .btn-primary.focus,
+.btn-primary.disabled:active,
+.btn-primary[disabled]:active,
+fieldset[disabled] .btn-primary:active,
+.btn-primary.disabled.active,
+.btn-primary[disabled].active,
+fieldset[disabled] .btn-primary.active {
   background-color: #265a88;
   background-image: none;
 }
@@ -113,8 +165,24 @@
   background-color: #419641;
   border-color: #3e8f3e;
 }
-.btn-success:disabled,
-.btn-success[disabled] {
+.btn-success.disabled,
+.btn-success[disabled],
+fieldset[disabled] .btn-success,
+.btn-success.disabled:hover,
+.btn-success[disabled]:hover,
+fieldset[disabled] .btn-success:hover,
+.btn-success.disabled:focus,
+.btn-success[disabled]:focus,
+fieldset[disabled] .btn-success:focus,
+.btn-success.disabled.focus,
+.btn-success[disabled].focus,
+fieldset[disabled] .btn-success.focus,
+.btn-success.disabled:active,
+.btn-success[disabled]:active,
+fieldset[disabled] .btn-success:active,
+.btn-success.disabled.active,
+.btn-success[disabled].active,
+fieldset[disabled] .btn-success.active {
   background-color: #419641;
   background-image: none;
 }
@@ -138,8 +206,24 @@
   background-color: #2aabd2;
   border-color: #28a4c9;
 }
-.btn-info:disabled,
-.btn-info[disabled] {
+.btn-info.disabled,
+.btn-info[disabled],
+fieldset[disabled] .btn-info,
+.btn-info.disabled:hover,
+.btn-info[disabled]:hover,
+fieldset[disabled] .btn-info:hover,
+.btn-info.disabled:focus,
+.btn-info[disabled]:focus,
+fieldset[disabled] .btn-info:focus,
+.btn-info.disabled.focus,
+.btn-info[disabled].focus,
+fieldset[disabled] .btn-info.focus,
+.btn-info.disabled:active,
+.btn-info[disabled]:active,
+fieldset[disabled] .btn-info:active,
+.btn-info.disabled.active,
+.btn-info[disabled].active,
+fieldset[disabled] .btn-info.active {
   background-color: #2aabd2;
   background-image: none;
 }
@@ -163,8 +247,24 @@
   background-color: #eb9316;
   border-color: #e38d13;
 }
-.btn-warning:disabled,
-.btn-warning[disabled] {
+.btn-warning.disabled,
+.btn-warning[disabled],
+fieldset[disabled] .btn-warning,
+.btn-warning.disabled:hover,
+.btn-warning[disabled]:hover,
+fieldset[disabled] .btn-warning:hover,
+.btn-warning.disabled:focus,
+.btn-warning[disabled]:focus,
+fieldset[disabled] .btn-warning:focus,
+.btn-warning.disabled.focus,
+.btn-warning[disabled].focus,
+fieldset[disabled] .btn-warning.focus,
+.btn-warning.disabled:active,
+.btn-warning[disabled]:active,
+fieldset[disabled] .btn-warning:active,
+.btn-warning.disabled.active,
+.btn-warning[disabled].active,
+fieldset[disabled] .btn-warning.active {
   background-color: #eb9316;
   background-image: none;
 }
@@ -188,8 +288,24 @@
   background-color: #c12e2a;
   border-color: #b92c28;
 }
-.btn-danger:disabled,
-.btn-danger[disabled] {
+.btn-danger.disabled,
+.btn-danger[disabled],
+fieldset[disabled] .btn-danger,
+.btn-danger.disabled:hover,
+.btn-danger[disabled]:hover,
+fieldset[disabled] .btn-danger:hover,
+.btn-danger.disabled:focus,
+.btn-danger[disabled]:focus,
+fieldset[disabled] .btn-danger:focus,
+.btn-danger.disabled.focus,
+.btn-danger[disabled].focus,
+fieldset[disabled] .btn-danger.focus,
+.btn-danger.disabled:active,
+.btn-danger[disabled]:active,
+fieldset[disabled] .btn-danger:active,
+.btn-danger.disabled.active,
+.btn-danger[disabled].active,
+fieldset[disabled] .btn-danger.active {
   background-color: #c12e2a;
   background-image: none;
 }
@@ -254,6 +370,7 @@
   filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff3c3c3c', endColorstr='#ff222222', GradientType=0);
   filter: progid:DXImageTransform.Microsoft.gradient(enabled = false);
   background-repeat: repeat-x;
+  border-radius: 4px;
 }
 .navbar-inverse .navbar-nav > .open > a,
 .navbar-inverse .navbar-nav > .active > a {