wip

.Rbuildignore

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

.gitignore

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

.travis.yml

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

CONTRIBUTING.md

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

DESCRIPTION

@@ -1,7 +1,8 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.0.0
+Version: 0.12.2.9006
+Date: 2015-11-23
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -14,7 +15,7 @@ Authors@R: c(
     person(family = "jQuery contributors", role = c("ctb", "cph"),
     comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
     person(family = "jQuery UI contributors", role = c("ctb", "cph"),
-    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
+    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/1.10.4/AUTHORS.txt"),
     person("Mark", "Otto", role = "ctb",
     comment = "Bootstrap library"),
     person("Jacob", "Thornton", role = "ctb",
@@ -69,9 +70,8 @@ Imports:
     jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.3.5),
-    R6 (>= 2.0),
-    sourcetools
+    htmltools (>= 0.2.6),
+    R6 (>= 2.0)
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -79,15 +79,12 @@ Suggests:
     knitr (>= 1.6),
     markdown,
     rmarkdown,
-    ggplot2,
-    magrittr
+    ggplot2
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
+VignetteBuilder: knitr
 Collate:
     'app.R'
-    'bookmark-state-local.R'
-    'stack.R'
-    'bookmark-state.R'
     'bootstrap-layout.R'
     'conditions.R'
     'map.R'
@@ -95,8 +92,8 @@ Collate:
     'utils.R'
     'bootstrap.R'
     'cache.R'
-    'diagnose.R'
     'fileupload.R'
+    'stack.R'
     'graph.R'
     'hooks.R'
     'html-deps.R'
@@ -117,15 +114,11 @@ Collate:
     'input-slider.R'
     'input-submit.R'
     'input-text.R'
-    'input-textarea.R'
     'input-utils.R'
-    'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
     'middleware.R'
-    'modal.R'
     'modules.R'
-    'notifications.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
@@ -134,16 +127,13 @@ Collate:
     'render-plot.R'
     'render-table.R'
     'run-url.R'
-    'serializers.R'
     'server-input-handlers.R'
     'server.R'
-    'shiny-options.R'
     'shiny.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
     'tar.R'
-    'test-export.R'
     'timer.R'
     'update-input.R'
 RoxygenNote: 5.0.1

NAMESPACE

@@ -2,24 +2,17 @@
 
 S3method("$",reactivevalues)
 S3method("$",session_proxy)
-S3method("$",shinyapi)
 S3method("$",shinyoutput)
 S3method("$<-",reactivevalues)
 S3method("$<-",session_proxy)
-S3method("$<-",shinyapi)
 S3method("$<-",shinyoutput)
 S3method("[",reactivevalues)
-S3method("[",shinyapi)
 S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
-S3method("[<-",shinyapi)
 S3method("[<-",shinyoutput)
 S3method("[[",reactivevalues)
-S3method("[[",session_proxy)
-S3method("[[",shinyapi)
 S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
-S3method("[[<-",shinyapi)
 S3method("[[<-",shinyoutput)
 S3method("names<-",reactivevalues)
 S3method(as.list,reactivevalues)
@@ -46,11 +39,8 @@ 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)
@@ -67,22 +57,15 @@ export(dataTableOutput)
 export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
-export(debounce)
-export(dialogViewer)
 export(div)
 export(downloadButton)
 export(downloadHandler)
 export(downloadLink)
 export(em)
-export(enableBookmarking)
 export(eventReactive)
-export(exportTestValues)
 export(exprToFunction)
 export(extractStackTrace)
 export(fileInput)
-export(fillCol)
-export(fillPage)
-export(fillRow)
 export(fixedPage)
 export(fixedPanel)
 export(fixedRow)
@@ -90,9 +73,7 @@ export(flowLayout)
 export(fluidPage)
 export(fluidRow)
 export(formatStackTrace)
-export(freezeReactiveValue)
 export(getDefaultReactiveDomain)
-export(getShinyOption)
 export(h1)
 export(h2)
 export(h3)
@@ -104,7 +85,6 @@ export(helpText)
 export(hoverOpts)
 export(hr)
 export(htmlOutput)
-export(htmlTemplate)
 export(icon)
 export(imageOutput)
 export(img)
@@ -115,17 +95,14 @@ export(includeMarkdown)
 export(includeScript)
 export(includeText)
 export(inputPanel)
-export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
 export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
 export(is.singleton)
-export(isTruthy)
 export(isolate)
 export(knit_print.html)
-export(knit_print.reactive)
 export(knit_print.shiny.appobj)
 export(knit_print.shiny.render.function)
 export(knit_print.shiny.tag)
@@ -134,8 +111,6 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
-export(modalButton)
-export(modalDialog)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
@@ -145,18 +120,10 @@ 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)
@@ -178,9 +145,6 @@ export(reactiveValues)
 export(reactiveValuesToList)
 export(registerInputHandler)
 export(removeInputHandler)
-export(removeModal)
-export(removeNotification)
-export(removeUI)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -189,34 +153,20 @@ 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(serveCSV)
-export(serveJSON)
-export(servePlot)
-export(serveRaw)
-export(serveText)
 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)
@@ -227,7 +177,6 @@ export(splitLayout)
 export(stopApp)
 export(strong)
 export(submitButton)
-export(suppressDependencies)
 export(tabPanel)
 export(tableOutput)
 export(tabsetPanel)
@@ -238,13 +187,10 @@ export(tagAppendChildren)
 export(tagList)
 export(tagSetChildren)
 export(tags)
-export(textAreaInput)
 export(textInput)
 export(textOutput)
-export(throttle)
 export(titlePanel)
 export(uiOutput)
-export(updateActionButton)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
@@ -252,15 +198,12 @@ 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)
@@ -278,4 +221,3 @@ import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
-importFrom(utils,write.csv)

NEWS

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

R/app.R

@@ -20,29 +20,19 @@
 #' @param onStart A function that will be called before the app is actually run.
 #'   This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
 #'   case, a \code{global.R} file can be used for this purpose.
-#' @param options Named options that should be passed to the \code{runApp} call
-#'   (these can be any of the following: "port", "launch.browser", "host", "quiet",
-#'   "display.mode" and "test.mode"). You can also specify \code{width} and
-#'   \code{height} parameters which provide a hint to the embedding environment
-#'   about the ideal height/width for the app.
+#' @param options Named options that should be passed to the `runApp` call. You
+#'   can also specify \code{width} and \code{height} parameters which provide a
+#'   hint to the embedding environment about the ideal height/width for the app.
 #' @param uiPattern A regular expression that will be applied to each \code{GET}
 #'   request to determine whether the \code{ui} should be used to handle the
 #'   request. Note that the entire request path must match the regular
 #'   expression in order for the match to be considered successful.
-#' @param enableBookmarking Can be one of \code{"url"}, \code{"server"}, or
-#'   \code{"disable"}. This is equivalent to calling the
-#'   \code{\link{enableBookmarking}()} function just before calling
-#'   \code{shinyApp()}. With the default value (\code{NULL}), the app will
-#'   respect the setting from any previous calls to \code{enableBookmarking()}.
-#'   See \code{\link{enableBookmarking}} for more information.
 #' @return An object that represents the app. Printing the object or passing it
 #'   to \code{\link{runApp}} will run the app.
 #'
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
-#'   options(device.ask.default = FALSE)
-#'
 #'   shinyApp(
 #'     ui = fluidPage(
 #'       numericInput("n", "n", 1),
@@ -69,9 +59,10 @@
 #'
 #'   runApp(app)
 #' }
+#'
 #' @export
 shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
-                     uiPattern="/", enableBookmarking = NULL) {
+                     uiPattern="/") {
   if (is.null(server)) {
     stop("`server` missing from shinyApp")
   }
@@ -85,24 +76,12 @@ 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,
-      appOptions = appOptions
-    ),
+      options = options),
     class = "shiny.appobj"
   )
 }
@@ -134,9 +113,7 @@ shinyAppDir <- function(appDir, options=list()) {
 #' @export
 shinyAppFile <- function(appFile, options=list()) {
   appFile <- normalizePath(appFile, mustWork = TRUE)
-  appDir <- dirname(appFile)
-
-  shinyAppDir_appR(basename(appFile), appDir, options = options)
+  shinyAppDir_appR(basename(appFile), dirname(appFile), options = options)
 }
 
 # This reads in an app dir in the case that there's a server.R (and ui.R/www)
@@ -201,8 +178,6 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     }
   }
 
-  shinyOptions(appDir = appDir)
-
   oldwd <- NULL
   monitorHandle <- NULL
   onStart <- function() {
@@ -224,8 +199,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       serverFuncSource = serverFuncSource,
       onStart = onStart,
       onEnd = onEnd,
-      options = options
-    ),
+      options = options),
     class = "shiny.appobj"
   )
 }
@@ -235,13 +209,13 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 # ignored when checking extensions. If any changes are detected, all connected
 # Shiny sessions are reloaded.
 #
-# Use options(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
+# 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:
-# options(shiny.autoreload.pattern = glob2rx("ui.R"))
+# option(shiny.autoreload.pattern = glob2rx("ui.R"))
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
@@ -278,8 +252,7 @@ initAutoReloadMonitor <- function(dir) {
 
 # This reads in an app dir for a single-file application (e.g. app.R), and
 # returns a shiny.appobj.
-shinyAppDir_appR <- function(fileName, appDir, options=list())
-{
+shinyAppDir_appR <- function(fileName, appDir, options=list()) {
   fullpath <- file.path.ci(appDir, fileName)
 
   # This sources app.R and caches the content. When appObj() is called but
@@ -292,8 +265,6 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
       if (!is.shiny.appobj(result))
         stop("app.R did not return a shiny.appobj object.")
 
-      unconsumeAppOptions(result$appOptions)
-
       return(result)
     }
   )
@@ -377,8 +348,7 @@ is.shiny.appobj <- function(x) {
 print.shiny.appobj <- function(x, ...) {
   opts <- x$options %OR% list()
   opts <- opts[names(opts) %in%
-      c("port", "launch.browser", "host", "quiet",
-        "display.mode", "test.mode")]
+      c("port", "launch.browser", "host", "quiet", "display.mode")]
 
   args <- c(list(x), opts)
 
@@ -397,20 +367,7 @@ as.tags.shiny.appobj <- function(x, ...) {
   height <- if (is.null(opts$height)) "400" else opts$height
 
   path <- addSubApp(x)
-  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"
-  )
+  tags$iframe(src=path, width=width, height=height, class="shiny-frame")
 }
 
 #' Knitr S3 methods
@@ -461,7 +418,8 @@ knit_print.shiny.appobj <- function(x, ...) {
   }
   else {
     path <- addSubApp(x)
-    output <- deferredIFrame(path, width, height)
+    output <- tags$iframe(src=path, width=width, height=height,
+                          class="shiny-frame")
   }
 
   # If embedded Shiny apps ever have JS/CSS dependencies (like pym.js) we'll
@@ -485,14 +443,3 @@ 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

@@ -1,28 +0,0 @@
-# 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,11 +31,7 @@
 #' @seealso \code{\link{column}}, \code{\link{sidebarLayout}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' # Example of UI with fluidPage
-#' ui <- fluidPage(
+#' shinyUI(fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -56,21 +52,9 @@
 #'       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)
-#'
-#'
-#' # UI demonstrating column layouts
-#' ui <- fluidPage(
+#' shinyUI(fluidPage(
 #'   title = "Hello Shiny!",
 #'   fluidRow(
 #'     column(width = 4,
@@ -80,10 +64,8 @@
 #'       "3 offset 2"
 #'     )
 #'   )
-#' )
+#' ))
 #'
-#' shinyApp(ui, server = function(input, output) { })
-#' }
 #' @rdname fluidPage
 #' @export
 fluidPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
@@ -133,10 +115,7 @@ fluidRow <- function(...) {
 #' @seealso \code{\link{column}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fixedPage(
+#' shinyUI(fixedPage(
 #'   title = "Hello, Shiny!",
 #'   fixedRow(
 #'     column(width = 4,
@@ -146,10 +125,7 @@ fluidRow <- function(...) {
 #'       "3 offset 2"
 #'     )
 #'   )
-#' )
-#'
-#' shinyApp(ui, server = function(input, output) { })
-#' }
+#' ))
 #'
 #' @rdname fixedPage
 #' @export
@@ -184,43 +160,24 @@ fixedRow <- function(...) {
 #' @seealso \code{\link{fluidRow}}, \code{\link{fixedRow}}.
 #'
 #' @examples
-#' ## 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(4,
+#'     sliderInput("obs", "Number of observations:",
+#'                 min = 1, max = 1000, value = 500)
+#'   ),
+#'   column(8,
+#'     plotOutput("distPlot")
 #'   )
 #' )
 #'
-#' 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"
-#'     )
+#' 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) {
 
@@ -245,14 +202,8 @@ column <- function(width, ..., offset = 0) {
 #'
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' titlePanel("Hello Shiny!")
 #'
-#' ui <- fluidPage(
-#'   titlePanel("Hello Shiny!")
-#' )
-#' shinyApp(ui, server = function(input, output) { })
-#' }
 #' @export
 titlePanel <- function(title, windowTitle=title) {
   tagList(
@@ -275,12 +226,8 @@ titlePanel <- function(title, windowTitle=title) {
 #'   layout.
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
 #' # Define UI
-#' ui <- fluidPage(
+#' shinyUI(fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -301,18 +248,8 @@ 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,
@@ -349,18 +286,13 @@ sidebarLayout <- function(sidebarPanel,
 #' @seealso \code{\link{fluidPage}}, \code{\link{flowLayout}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
+#' shinyUI(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) {
@@ -387,16 +319,11 @@ verticalLayout <- function(..., fluid = TRUE) {
 #' @seealso \code{\link{verticalLayout}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- flowLayout(
+#' 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()) {
 
@@ -419,6 +346,7 @@ flowLayout <- function(..., cellArgs = list()) {
 #' suitable for wrapping inputs.
 #'
 #' @param ... Input controls or other HTML elements.
+#'
 #' @export
 inputPanel <- function(...) {
   div(class = "shiny-input-panel",
@@ -441,34 +369,21 @@ inputPanel <- function(...) {
 #'   of the layout.
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' # Server code used for all examples
-#' server <- function(input, output) {
-#'   output$plot1 <- renderPlot(plot(cars))
-#'   output$plot2 <- renderPlot(plot(pressure))
-#'   output$plot3 <- renderPlot(plot(AirPassengers))
-#' }
-#'
 #' # Equal sizing
-#' ui <- splitLayout(
+#' splitLayout(
 #'   plotOutput("plot1"),
 #'   plotOutput("plot2")
 #' )
-#' shinyApp(ui, server)
 #'
 #' # Custom widths
-#' ui <- splitLayout(cellWidths = c("25%", "75%"),
+#' 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
-#' ui <- splitLayout(
+#' splitLayout(
 #'   style = "border: 1px solid silver;",
 #'   cellWidths = 300,
 #'   cellArgs = list(style = "padding: 6px"),
@@ -476,8 +391,6 @@ inputPanel <- function(...) {
 #'   plotOutput("plot2"),
 #'   plotOutput("plot3")
 #' )
-#' shinyApp(ui, server)
-#' }
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
@@ -504,193 +417,3 @@ 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/bootstrap.R

@@ -25,6 +25,7 @@ NULL
 #'   \code{\link{fluidPage}} function instead.
 #'
 #' @seealso \code{\link{fluidPage}}, \code{\link{fixedPage}}
+#'
 #' @export
 bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
 
@@ -32,6 +33,26 @@ bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
     shinyDeprecated("The 'responsive' argument is no longer used with Bootstrap 3.")
   }
 
+  # required head tags for boostrap
+  importBootstrap <- function() {
+    list(
+      htmlDependency("bootstrap", "3.3.5",
+        c(
+          href = "shared/bootstrap",
+          file = system.file("www/shared/bootstrap", package = "shiny")
+        ),
+        script = c(
+          "js/bootstrap.min.js",
+          # These shims are necessary for IE 8 compatibility
+          "shim/html5shiv.min.js",
+          "shim/respond.min.js"
+        ),
+        stylesheet = if (is.null(theme)) "css/bootstrap.min.css",
+        meta = list(viewport = "width=device-width, initial-scale=1")
+      )
+    )
+  }
+
   attachDependencies(
     tagList(
       if (!is.null(title)) tags$head(tags$title(title)),
@@ -42,37 +63,7 @@ bootstrapPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
       # remainder of tags passed to the function
       list(...)
     ),
-    bootstrapLib()
-  )
-}
-
-#' Bootstrap libraries
-#'
-#' This function returns a set of web dependencies necessary for using Bootstrap
-#' components in a web page.
-#'
-#' It isn't necessary to call this function if you use
-#' \code{\link{bootstrapPage}} or others which use \code{bootstrapPage}, such
-#' \code{\link{basicPage}}, \code{\link{fluidPage}}, \code{\link{fillPage}},
-#' \code{\link{pageWithSidebar}}, and \code{\link{navbarPage}}, because they
-#' already include the Bootstrap web dependencies.
-#'
-#' @inheritParams bootstrapPage
-#' @export
-bootstrapLib <- function(theme = NULL) {
-  htmlDependency("bootstrap", "3.3.7",
-    c(
-      href = "shared/bootstrap",
-      file = system.file("www/shared/bootstrap", package = "shiny")
-    ),
-    script = c(
-      "js/bootstrap.min.js",
-      # These shims are necessary for IE 8 compatibility
-      "shim/html5shiv.min.js",
-      "shim/respond.min.js"
-    ),
-    stylesheet = if (is.null(theme)) "css/bootstrap.min.css",
-    meta = list(viewport = "width=device-width, initial-scale=1")
+    importBootstrap()
   )
 }
 
@@ -82,102 +73,6 @@ basicPage <- function(...) {
   bootstrapPage(div(class="container-fluid", list(...)))
 }
 
-
-#' Create a page that fills the window
-#'
-#' \code{fillPage} creates a page whose height and width always fill the
-#' available area of the browser window.
-#'
-#' The \code{\link{fluidPage}} and \code{\link{fixedPage}} functions are used
-#' for creating web pages that are laid out from the top down, leaving
-#' whitespace at the bottom if the page content's height is smaller than the
-#' browser window, and scrolling if the content is larger than the window.
-#'
-#' \code{fillPage} is designed to latch the document body's size to the size of
-#' the window. This makes it possible to fill it with content that also scales
-#' to the size of the window.
-#'
-#' For example, \code{fluidPage(plotOutput("plot", height = "100\%"))} will not
-#' work as expected; the plot element's effective height will be \code{0},
-#' because the plot's containing elements (\code{<div>} and \code{<body>}) have
-#' \emph{automatic} height; that is, they determine their own height based on
-#' the height of their contained elements. However,
-#' \code{fillPage(plotOutput("plot", height = "100\%"))} will work because
-#' \code{fillPage} fixes the \code{<body>} height at 100\% of the window height.
-#'
-#' Note that \code{fillPage(plotOutput("plot"))} will not cause the plot to fill
-#' the page. Like most Shiny output widgets, \code{plotOutput}'s default height
-#' is a fixed number of pixels. You must explicitly set \code{height = "100\%"}
-#' if you want a plot (or htmlwidget, say) to fill its container.
-#'
-#' One must be careful what layouts/panels/elements come between the
-#' \code{fillPage} and the plots/widgets. Any container that has an automatic
-#' height will cause children with \code{height = "100\%"} to misbehave. Stick
-#' to functions that are designed for fill layouts, such as the ones in this
-#' package.
-#'
-#' @param ... Elements to include within the page.
-#' @param padding Padding to use for the body. This can be a numeric vector
-#'   (which will be interpreted as pixels) or a character vector with valid CSS
-#'   lengths. The length can be between one and four. If one, then that value
-#'   will be used for all four sides. If two, then the first value will be used
-#'   for the top and bottom, while the second value will be used for left and
-#'   right. If three, then the first will be used for top, the second will be
-#'   left and right, and the third will be bottom. If four, then the values will
-#'   be interpreted as top, right, bottom, and left respectively.
-#' @param title The title to use for the browser window/tab (it will not be
-#'   shown in the document).
-#' @param bootstrap If \code{TRUE}, load the Bootstrap CSS library.
-#' @param theme URL to alternative Bootstrap stylesheet.
-#'
-#' @examples
-#' fillPage(
-#'   tags$style(type = "text/css",
-#'     ".half-fill { width: 50%; height: 100%; }",
-#'     "#one { float: left; background-color: #ddddff; }",
-#'     "#two { float: right; background-color: #ccffcc; }"
-#'   ),
-#'   div(id = "one", class = "half-fill",
-#'     "Left half"
-#'   ),
-#'   div(id = "two", class = "half-fill",
-#'     "Right half"
-#'   ),
-#'   padding = 10
-#' )
-#'
-#' fillPage(
-#'   fillRow(
-#'     div(style = "background-color: red; width: 100%; height: 100%;"),
-#'     div(style = "background-color: blue; width: 100%; height: 100%;")
-#'   )
-#' )
-#' @export
-fillPage <- function(..., padding = 0, title = NULL, bootstrap = TRUE,
-  theme = NULL) {
-
-  fillCSS <- tags$head(tags$style(type = "text/css",
-    "html, body { width: 100%; height: 100%; overflow: hidden; }",
-    sprintf("body { padding: %s; margin: 0; }", collapseSizes(padding))
-  ))
-
-  if (isTRUE(bootstrap)) {
-    bootstrapPage(title = title, theme = theme, fillCSS, ...)
-  } else {
-    tagList(
-      fillCSS,
-      if (!is.null(title)) tags$head(tags$title(title)),
-      ...
-    )
-  }
-}
-
-collapseSizes <- function(padding) {
-  paste(
-    sapply(padding, shiny::validateCssUnit, USE.NAMES = FALSE),
-    collapse = " ")
-}
-
 #' Create a page with a sidebar
 #'
 #' Create a Shiny UI that contains a header with the application title, a
@@ -194,7 +89,7 @@ collapseSizes <- function(padding) {
 #'
 #' @examples
 #' # Define UI
-#' pageWithSidebar(
+#' shinyUI(pageWithSidebar(
 #'
 #'   # Application title
 #'   headerPanel("Hello Shiny!"),
@@ -212,7 +107,8 @@ collapseSizes <- function(padding) {
 #'   mainPanel(
 #'     plotOutput("distPlot")
 #'   )
-#' )
+#' ))
+#'
 #' @export
 pageWithSidebar <- function(headerPanel,
                             sidebarPanel,
@@ -239,24 +135,18 @@ pageWithSidebar <- function(headerPanel,
 #' toggle a set of \code{\link{tabPanel}} elements.
 #'
 #' @param title The title to display in the navbar
-#' @param ... \code{\link{tabPanel}} elements to include in the page. The
-#'   \code{navbarMenu} function also accepts strings, which will be used as menu
-#'   section headers. If the string is a set of dashes like \code{"----"} a
-#'   horizontal separator will be displayed in the menu.
+#' @param ... \code{\link{tabPanel}} elements to include in the page
 #' @param id If provided, you can use \code{input$}\emph{\code{id}} in your
 #'   server logic to determine which of the current tabs is active. The value
 #'   will correspond to the \code{value} argument that is passed to
 #'   \code{\link{tabPanel}}.
-#' @param selected The \code{value} (or, if none was supplied, the \code{title})
-#'   of the tab that should be selected by default. If \code{NULL}, the first
-#'   tab will be selected.
 #' @param position Determines whether the navbar should be displayed at the top
-#'   of the page with normal scrolling behavior (\code{"static-top"}), pinned at
-#'   the top (\code{"fixed-top"}), or pinned at the bottom
+#'   of the page with normal scrolling behavior (\code{"static-top"}), pinned
+#'   at the top (\code{"fixed-top"}), or pinned at the bottom
 #'   (\code{"fixed-bottom"}). Note that using \code{"fixed-top"} or
 #'   \code{"fixed-bottom"} will cause the navbar to overlay your body content,
-#'   unless you add padding, e.g.: \code{tags$style(type="text/css", "body
-#'   {padding-top: 70px;}")}
+#'   unless you add padding, e.g.:
+#'   \code{tags$style(type="text/css", "body {padding-top: 70px;}")}
 #' @param header Tag or list of tags to display as a common header above all
 #'   tabPanels.
 #' @param footer Tag or list of tags to display as a common footer below all
@@ -288,26 +178,23 @@ pageWithSidebar <- function(headerPanel,
 #'   \code{\link{updateNavbarPage}}
 #'
 #' @examples
-#' navbarPage("App Title",
+#' shinyUI(navbarPage("App Title",
 #'   tabPanel("Plot"),
 #'   tabPanel("Summary"),
 #'   tabPanel("Table")
-#' )
+#' ))
 #'
-#' navbarPage("App Title",
+#' shinyUI(navbarPage("App Title",
 #'   tabPanel("Plot"),
 #'   navbarMenu("More",
 #'     tabPanel("Summary"),
-#'     "----",
-#'     "Section header",
 #'     tabPanel("Table")
 #'   )
-#' )
+#' ))
 #' @export
 navbarPage <- function(title,
                        ...,
                        id = NULL,
-                       selected = NULL,
                        position = c("static-top", "fixed-top", "fixed-bottom"),
                        header = NULL,
                        footer = NULL,
@@ -335,25 +222,14 @@ navbarPage <- function(title,
   if (inverse)
     navbarClass <- paste(navbarClass, "navbar-inverse")
 
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
   # build the tabset
   tabs <- list(...)
-  tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id, selected)
-
-  # function to return plain or fluid class name
-  className <- function(name) {
-    if (fluid)
-      paste(name, "-fluid", sep="")
-    else
-      name
-  }
+  tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id)
 
   # built the container div dynamically to support optional collapsibility
   if (collapsible) {
     navId <- paste("navbar-collapse-", p_randomInt(1000, 10000), sep="")
-    containerDiv <- div(class=className("container"),
+    containerDiv <- div(class="container",
       div(class="navbar-header",
         tags$button(type="button", class="navbar-toggle collapsed",
           `data-toggle`="collapse", `data-target`=paste0("#", navId),
@@ -367,7 +243,7 @@ navbarPage <- function(title,
       div(class="navbar-collapse collapse", id=navId, tabset$navList)
     )
   } else {
-    containerDiv <- div(class=className("container"),
+    containerDiv <- div(class="container",
       div(class="navbar-header",
         span(class="navbar-brand", pageTitle)
       ),
@@ -375,6 +251,14 @@ navbarPage <- function(title,
     )
   }
 
+  # function to return plain or fluid class name
+  className <- function(name) {
+    if (fluid)
+      paste(name, "-fluid", sep="")
+    else
+      name
+  }
+
   # build the main tab content div
   contentDiv <- div(class=className("container"))
   if (!is.null(header))
@@ -430,6 +314,7 @@ headerPanel <- function(title, windowTitle=title) {
 #'
 #' @param ... UI elements to include inside the panel.
 #' @return The newly created panel.
+#'
 #' @export
 wellPanel <- function(...) {
   div(class="well", ...)
@@ -533,6 +418,7 @@ mainPanel <- function(..., width = 8) {
 #'       )
 #'    )
 #' )
+#'
 #' @export
 conditionalPanel <- function(condition, ...) {
   div('data-display-if'=condition, ...)
@@ -605,8 +491,10 @@ tabPanel <- function(title, ..., value = title, icon = NULL) {
 #'   tab will be selected.
 #' @param type Use "tabs" for the standard look; Use "pills" for a more plain
 #'   look where tabs are selected using a background fill color.
-#' @param position This argument is deprecated; it has been discontinued in
-#'   Bootstrap 3.
+#' @param position The position of the tabs relative to the content. Valid
+#'   values are "above", "below", "left", and "right" (defaults to "above").
+#'   Note that the \code{position} argument is not valid when \code{type} is
+#'   "pill".
 #' @return A tabset that can be passed to \code{\link{mainPanel}}
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{updateTabsetPanel}}
@@ -626,28 +514,25 @@ tabsetPanel <- function(...,
                         id = NULL,
                         selected = NULL,
                         type = c("tabs", "pills"),
-                        position = NULL) {
-  if (!is.null(position)) {
-    shinyDeprecated(msg = paste("tabsetPanel: argument 'position' is deprecated;",
-                                "it has been discontinued in Bootstrap 3."),
-                    version = "0.10.2.2")
-  }
-
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
+                        position = c("above", "below", "left", "right")) {
 
   # build the tabset
   tabs <- list(...)
   type <- match.arg(type)
-
   tabset <- buildTabset(tabs, paste0("nav nav-", type), NULL, id, selected)
 
-  # create the content
-  first <- tabset$navList
-  second <- tabset$content
+  # position the nav list and content appropriately
+  position <- match.arg(position)
+  if (position %in% c("above", "left", "right")) {
+    first <- tabset$navList
+    second <- tabset$content
+  } else if (position %in% c("below")) {
+    first <- tabset$content
+    second <- tabset$navList
+  }
 
   # create the tab div
-  tags$div(class = "tabbable", first, second)
+  tags$div(class = paste("tabbable tabs-", position, sep=""), first, second)
 }
 
 #' Create a navigation list panel
@@ -678,7 +563,7 @@ tabsetPanel <- function(...,
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
 #' @examples
-#' fluidPage(
+#' shinyUI(fluidPage(
 #'
 #'   titlePanel("Application Title"),
 #'
@@ -688,7 +573,7 @@ tabsetPanel <- function(...,
 #'     tabPanel("Second"),
 #'     tabPanel("Third")
 #'   )
-#' )
+#' ))
 #' @export
 navlistPanel <- function(...,
                          id = NULL,
@@ -702,9 +587,6 @@ navlistPanel <- function(...,
       tags$li(class="navbar-brand", text)
   }
 
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
   # build the tabset
   tabs <- list(...)
   tabset <- buildTabset(tabs,
@@ -727,188 +609,117 @@ navlistPanel <- function(...,
 }
 
 
-buildTabset <- function(tabs, ulClass, textFilter = NULL,
-                        id = NULL, selected = NULL) {
+buildTabset <- function(tabs,
+                        ulClass,
+                        textFilter = NULL,
+                        id = NULL,
+                        selected = NULL) {
 
-  # This function proceeds in two phases. First, it scans over all the items
-  # to find and mark which tab should start selected. Then it actually builds
-  # the tab nav and tab content lists.
+  # build tab nav list and tab content div
 
-  # Mark an item as selected
-  markSelected <- function(x) {
-    attr(x, "selected") <- TRUE
-    x
-  }
+  # add tab input sentinel class if we have an id
+  if (!is.null(id))
+    ulClass <- paste(ulClass, "shiny-tab-input")
 
-  # Returns TRUE if an item is selected
-  isSelected <- function(x) {
-    isTRUE(attr(x, "selected", exact = TRUE))
-  }
+  tabNavList <- tags$ul(class = ulClass, id = id)
+  tabContent <- tags$div(class = "tab-content")
+  firstTab <- TRUE
+  tabsetId <- p_randomInt(1000, 10000)
+  tabId <- 1
+  for (divTag in tabs) {
 
-  # Returns TRUE if a list of tab items contains a selected tab, FALSE
-  # otherwise.
-  containsSelected <- function(tabs) {
-    any(vapply(tabs, isSelected, logical(1)))
-  }
+    # check for text; pass it to the textFilter or skip it if there is none
+    if (is.character(divTag)) {
+      if (!is.null(textFilter))
+        tabNavList <- tagAppendChild(tabNavList, textFilter(divTag))
+      next
+    }
 
-  # Take a pass over all tabs, and mark the selected tab.
-  foundSelectedItem <- FALSE
-  findAndMarkSelected <- function(tabs, selected) {
-    lapply(tabs, function(divTag) {
-      if (foundSelectedItem) {
-        # If we already found the selected tab, no need to keep looking
+    # compute id and assign it to the div
+    thisId <- paste("tab", tabsetId, tabId, sep="-")
+    divTag$attribs$id <- thisId
+    tabId <- tabId + 1
 
-      } else if (is.character(divTag)) {
-        # Strings don't represent selectable items
+    tabValue <- divTag$attribs$`data-value`
 
-      } else if (inherits(divTag, "shiny.navbarmenu")) {
-        # Navbar menu
-        divTag$tabs <- findAndMarkSelected(divTag$tabs, selected)
-
-      } else {
-        # Regular tab item
-        if (is.null(selected)) {
-          # If selected tab isn't specified, mark first available item
-          # as selected.
-          foundSelectedItem <<- TRUE
-          divTag <- markSelected(divTag)
-
-        } else {
-          # If selected tab is specified, check for a match
-          tabValue <- divTag$attribs$`data-value` %OR% divTag$attribs$title
-          if (identical(selected, tabValue)) {
-            foundSelectedItem <<- TRUE
-            divTag <- markSelected(divTag)
-          }
-        }
+    # function to append an optional icon to an aTag
+    appendIcon <- function(aTag, iconClass) {
+      if (!is.null(iconClass)) {
+        # for font-awesome we specify fixed-width
+        if (grepl("fa-", iconClass, fixed = TRUE))
+          iconClass <- paste(iconClass, "fa-fw")
+        aTag <- tagAppendChild(aTag, icon(name = NULL, class = iconClass))
       }
-
-      return(divTag)
-    })
-  }
-
-
-  # Append an optional icon to an aTag
-  appendIcon <- function(aTag, iconClass) {
-    if (!is.null(iconClass)) {
-      # for font-awesome we specify fixed-width
-      if (grepl("fa-", iconClass, fixed = TRUE))
-        iconClass <- paste(iconClass, "fa-fw")
-      aTag <- tagAppendChild(aTag, icon(name = NULL, class = iconClass))
-    }
-    aTag
-  }
-
-  # Build the tabset
-  build <- function(tabs, ulClass, textFilter = NULL, id = NULL) {
-    # add tab input sentinel class if we have an id
-    if (!is.null(id))
-      ulClass <- paste(ulClass, "shiny-tab-input")
-
-    if (anyNamed(tabs)) {
-      nms <- names(tabs)
-      nms <- nms[nzchar(nms)]
-      stop("Tabs should all be unnamed arguments, but some are named: ",
-           paste(nms, collapse = ", "))
+      aTag
     }
 
-    tabNavList <- tags$ul(class = ulClass, id = id)
-    tabContent <- tags$div(class = "tab-content")
-    tabsetId <- p_randomInt(1000, 10000)
-    tabId <- 1
+    # check for a navbarMenu and handle appropriately
+    if (inherits(divTag, "shiny.navbarmenu")) {
 
-    buildItem <- function(divTag) {
-      # check for text; pass it to the textFilter or skip it if there is none
-      if (is.character(divTag)) {
-        if (!is.null(textFilter)) {
-          tabNavList <<- tagAppendChild(tabNavList, textFilter(divTag))
-        }
+      # create the a tag
+      aTag <- tags$a(href="#",
+                     class="dropdown-toggle",
+                     `data-toggle`="dropdown")
 
-      } else if (inherits(divTag, "shiny.navbarmenu")) {
+      # add optional icon
+      aTag <- appendIcon(aTag, divTag$iconClass)
 
-        # create the a tag
-        aTag <- tags$a(href="#",
-                       class="dropdown-toggle",
-                       `data-toggle`="dropdown")
+      # add the title and caret
+      aTag <- tagAppendChild(aTag, divTag$title)
+      aTag <- tagAppendChild(aTag, tags$b(class="caret"))
 
-        # add optional icon
-        aTag <- appendIcon(aTag, divTag$iconClass)
+      # build the dropdown list element
+      liTag <- tags$li(class = "dropdown", aTag)
 
-        # add the title and caret
-        aTag <- tagAppendChild(aTag, divTag$title)
-        aTag <- tagAppendChild(aTag, tags$b(class="caret"))
+      # build the child tabset
+      tabset <- buildTabset(divTag$tabs, "dropdown-menu")
+      liTag <- tagAppendChild(liTag, tabset$navList)
 
-        # build the dropdown list element
-        liTag <- tags$li(class = "dropdown", aTag)
+      # don't add a standard tab content div, rather add the list of tab
+      # content divs that are contained within the tabset
+      divTag <- NULL
+      tabContent <- tagAppendChildren(tabContent,
+                                      list = tabset$content$children)
+    }
+    # else it's a standard navbar item
+    else {
+      # create the a tag
+      aTag <- tags$a(href=paste("#", thisId, sep=""),
+                     `data-toggle` = "tab",
+                     `data-value` = tabValue)
 
-        # text filter for separators
-        textFilter <- function(text) {
-          if (grepl("^\\-+$", text))
-            tags$li(class="divider")
-          else
-            tags$li(class="dropdown-header", text)
-        }
+      # append optional icon
+      aTag <- appendIcon(aTag, divTag$attribs$`data-icon-class`)
 
-        # build the child tabset
-        tabset <- build(divTag$tabs, "dropdown-menu", textFilter)
-        liTag <- tagAppendChild(liTag, tabset$navList)
+      # add the title
+      aTag <- tagAppendChild(aTag, divTag$attribs$title)
 
-        # If this navbar menu contains a selected item, mark it as active
-        if (containsSelected(divTag$tabs)) {
-          liTag$attribs$class <- paste(liTag$attribs$class, "active")
-        }
-
-        tabNavList <<- tagAppendChild(tabNavList, liTag)
-        # don't add a standard tab content div, rather add the list of tab
-        # content divs that are contained within the tabset
-        tabContent <<- tagAppendChildren(tabContent,
-                                        list = tabset$content$children)
-
-      } else {
-        # Standard navbar item
-        # compute id and assign it to the div
-        thisId <- paste("tab", tabsetId, tabId, sep="-")
-        divTag$attribs$id <- thisId
-        tabId <<- tabId + 1
-
-        tabValue <- divTag$attribs$`data-value`
-
-        # create the a tag
-        aTag <- tags$a(href=paste("#", thisId, sep=""),
-                       `data-toggle` = "tab",
-                       `data-value` = tabValue)
-
-        # append optional icon
-        aTag <- appendIcon(aTag, divTag$attribs$`data-icon-class`)
-
-        # add the title
-        aTag <- tagAppendChild(aTag, divTag$attribs$title)
-
-        # create the li tag
-        liTag <- tags$li(aTag)
-
-        # If selected, set appropriate classes on li tag and div tag.
-        if (isSelected(divTag)) {
-          liTag$attribs$class <- "active"
-          divTag$attribs$class <- "tab-pane active"
-        }
-
-        divTag$attribs$title <- NULL
-
-        # append the elements to our lists
-        tabNavList <<- tagAppendChild(tabNavList, liTag)
-        tabContent <<- tagAppendChild(tabContent, divTag)
-      }
+      # create the li tag
+      liTag <- tags$li(aTag)
     }
 
-    lapply(tabs, buildItem)
-    list(navList = tabNavList, content = tabContent)
+    if (is.null(tabValue)) {
+      tabValue <- divTag$attribs$title
+    }
+
+    # If appropriate, make this the selected tab (don't ever do initial
+    # selection of tabs that are within a navbarMenu)
+    if ((ulClass != "dropdown-menu") &&
+       ((firstTab && is.null(selected)) ||
+        (!is.null(selected) && identical(selected, tabValue)))) {
+      liTag$attribs$class <- "active"
+      divTag$attribs$class <- "tab-pane active"
+      firstTab = FALSE
+    }
+
+    divTag$attribs$title <- NULL
+
+    # append the elements to our lists
+    tabNavList <- tagAppendChild(tabNavList, liTag)
+    tabContent <- tagAppendChild(tabContent, divTag)
   }
 
-
-  # Finally, actually invoke the functions to do the processing.
-  tabs <- findAndMarkSelected(tabs, selected)
-  build(tabs, ulClass, textFilter, id)
+  list(navList = tabNavList, content = tabContent)
 }
 
 
@@ -935,38 +746,24 @@ textOutput <- function(outputId, container = if (inline) span else div, inline =
 #' Render a reactive output variable as verbatim text within an
 #' application page. The text will be included within an HTML \code{pre} tag.
 #' @param outputId output variable to read the value from
-#' @param placeholder if the output is empty or \code{NULL}, should an empty
-#'   rectangle be displayed to serve as a placeholder? (does not affect
-#'   behavior when the the output in nonempty)
 #' @return A verbatim text output element that can be included in a panel
 #' @details Text is HTML-escaped prior to rendering. This element is often used
-#'   with the \link{renderPrint} function to preserve fixed-width formatting
-#'   of printed objects.
+#' with the \link{renderPrint} function to preserve fixed-width formatting
+#' of printed objects.
 #' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   shinyApp(
-#'     ui = basicPage(
-#'       textInput("txt", "Enter the text to display below:"),
-#'       verbatimTextOutput("default"),
-#'       verbatimTextOutput("placeholder", placeholder = TRUE)
-#'     ),
-#'     server = function(input, output) {
-#'       output$default <- renderText({ input$txt })
-#'       output$placeholder <- renderText({ input$txt })
-#'     }
-#'   )
-#' }
+#' mainPanel(
+#'   h4("Summary"),
+#'   verbatimTextOutput("summary"),
+#'
+#'   h4("Observations"),
+#'   tableOutput("view")
+#' )
 #' @export
-verbatimTextOutput <- function(outputId, placeholder = FALSE) {
-  pre(id = outputId,
-      class = paste(c("shiny-text-output", if (!placeholder) "noplaceholder"),
-                    collapse = " ")
-      )
+verbatimTextOutput <- function(outputId) {
+  textOutput(outputId, container = pre)
 }
 
 
-#' @name plotOutput
 #' @rdname plotOutput
 #' @export
 imageOutput <- function(outputId, width = "100%", height="400px",
@@ -1136,7 +933,7 @@ imageOutput <- function(outputId, width = "100%", height="400px",
 #'   same \code{id} to disappear.
 #' @inheritParams textOutput
 #' @note The arguments \code{clickId} and \code{hoverId} only work for R base
-#'   graphics (see the \pkg{\link[graphics:graphics-package]{graphics}} package). They do not work for
+#'   graphics (see the \pkg{\link{graphics}} package). They do not work for
 #'   \pkg{\link[grid:grid-package]{grid}}-based graphics, such as \pkg{ggplot2},
 #'   \pkg{lattice}, and so on.
 #'
@@ -1434,7 +1231,6 @@ uiOutput <- htmlOutput
 #'   is assigned to.
 #' @param label The label that should appear on the button.
 #' @param class Additional CSS classes to apply to the tag, if any.
-#' @param ... Other arguments to pass to the container tag function.
 #'
 #' @examples
 #' \dontrun{
@@ -1457,25 +1253,23 @@ uiOutput <- htmlOutput
 #' @export
 downloadButton <- function(outputId,
                            label="Download",
-                           class=NULL, ...) {
+                           class=NULL) {
   aTag <- tags$a(id=outputId,
                  class=paste('btn btn-default shiny-download-link', class),
                  href='',
                  target='_blank',
-                 download=NA,
                  icon("download"),
-                 label, ...)
+                 label)
 }
 
 #' @rdname downloadButton
 #' @export
-downloadLink <- function(outputId, label="Download", class=NULL, ...) {
+downloadLink <- function(outputId, label="Download", class=NULL) {
   tags$a(id=outputId,
          class=paste(c('shiny-download-link', class), collapse=" "),
          href='',
          target='_blank',
-         download=NA,
-         label, ...)
+         label)
 }
 
 
@@ -1511,11 +1305,12 @@ downloadLink <- function(outputId, label="Download", class=NULL, ...) {
 #' # add an icon to a submit button
 #' submitButton("Update View", icon = icon("refresh"))
 #'
-#' navbarPage("App Title",
+#' shinyUI(navbarPage("App Title",
 #'   tabPanel("Plot", icon = icon("bar-chart-o")),
 #'   tabPanel("Summary", icon = icon("list-alt")),
 #'   tabPanel("Table", icon = icon("table"))
-#' )
+#' ))
+#'
 #' @export
 icon <- function(name, class = NULL, lib = "font-awesome") {
   prefixes <- list(
@@ -1543,7 +1338,7 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
   # font-awesome needs an additional dependency (glyphicon is in bootstrap)
   if (lib == "font-awesome") {
     htmlDependencies(iconTag) <- htmlDependency(
-      "font-awesome", "4.7.0", c(href="shared/font-awesome"),
+      "font-awesome", "4.4.0", c(href="shared/font-awesome"),
       stylesheet = "css/font-awesome.min.css"
     )
   }

R/conditions.R

@@ -76,7 +76,7 @@ getCallNames <- function(calls) {
 }
 
 getLocs <- function(calls) {
-  vapply(calls, function(call) {
+  sapply(calls, function(call) {
     srcref <- attr(call, "srcref", exact = TRUE)
     if (!is.null(srcref)) {
       srcfile <- attr(srcref, "srcfile", exact = TRUE)
@@ -86,7 +86,7 @@ getLocs <- function(calls) {
       }
     }
     return("")
-  }, character(1))
+  })
 }
 
 #' @details \code{captureStackTraces} runs the given \code{expr} and if any
@@ -130,11 +130,7 @@ withLogErrors <- function(expr,
   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)
-      }
+      printError(cond, full = full, offset = offset)
     }
   )
 }
@@ -208,7 +204,7 @@ extractStackTrace <- function(calls,
     # 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))
+    srcrefs <- c(tail(srcrefs, -1), list(NULL))
   }
   calls <- setSrcRefs(calls, srcrefs)
 
@@ -229,8 +225,8 @@ extractStackTrace <- function(calls,
     # 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)
+      calls <- head(calls, -toRemove)
+      callnames <- head(callnames, -toRemove)
     }
 
     # This uses a ref-counting scheme. It might make sense to switch this

R/diagnose.R

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

R/fileupload.R

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

R/graph.R

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

R/html-deps.R

@@ -6,7 +6,7 @@
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named, then
+#'   \code{\link{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,21 +27,3 @@ 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,5 +4,4 @@
 #' @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/imageutils.R

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

R/input-action.R

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

R/input-checkbox.R

@@ -10,23 +10,9 @@
 #' @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)
-#' }
+#' checkboxInput("outliers", "Show outliers", FALSE)
 #' @export
 checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
-
-  value <- restoreInput(id = inputId, default = value)
-
   inputTag <- tags$input(id = inputId, type="checkbox")
   if (!is.null(value) && value)
     inputTag$attribs$checked <- "checked"

R/input-checkboxgroup.R

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

R/input-date.R

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

R/input-daterange.R

@@ -10,7 +10,7 @@
 #'   \item \code{yy} Year without century (12)
 #'   \item \code{yyyy} Year with century (2012)
 #'   \item \code{mm} Month number, with leading zero (01-12)
-#'   \item \code{m} Month number, without leading zero (1-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
@@ -32,44 +32,37 @@
 #' @seealso \code{\link{dateInput}}, \code{\link{updateDateRangeInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' dateRangeInput("daterange", "Date range:",
+#'                start = "2001-01-01",
+#'                end   = "2010-12-31")
 #'
-#' 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("daterange", "Date range:")
 #'
-#'   # 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("daterange", "Date range:",
+#'                start  = "2001-01-01",
+#'                end    = "2010-12-31",
+#'                min    = "2001-01-01",
+#'                max    = "2012-12-21",
+#'                format = "mm/dd/yy",
+#'                separator = " - ")
 #'
-#'   # 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("daterange", "Date range:",
+#'                start = Sys.Date()-10,
+#'                end = Sys.Date()+10)
 #'
-#'   # 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("daterange", "Date range:",
+#'                language = "de",
+#'                weekstart = 1)
 #'
-#'   # 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("daterange", "Date range:",
+#'                startview = "decade")
 #'
-#'   # 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",
@@ -82,10 +75,6 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
 
-  restored <- restoreInput(id = inputId, default = list(start, end))
-  start <- restored[[1]]
-  end <- restored[[2]]
-
   attachDependencies(
     div(id = inputId,
       class = "shiny-date-range-input form-group shiny-input-container",

R/input-file.R

@@ -28,92 +28,20 @@
 #' @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
-  )
-
+  inputTag <- tags$input(id = inputId, name = inputId, type = "file")
   if (multiple)
     inputTag$attribs$multiple <- "multiple"
   if (length(accept) > 0)
     inputTag$attribs$accept <- paste(accept, collapse=',')
 
-
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     label %AND% tags$label(label),
-
-    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"
-      )
-    ),
-
+    inputTag,
     tags$div(
       id=paste(inputId, "_progress", sep=""),
       class="progress progress-striped active shiny-file-input-progress",

R/input-numeric.R

@@ -1,3 +1,4 @@
+
 #' Create a numeric input control
 #'
 #' Create an input control for entry of numeric values
@@ -12,24 +13,12 @@
 #' @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)
-#' }
+#' numericInput("obs", "Observations:", 10,
+#'              min = 1, max = 100)
 #' @export
 numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
   width = NULL) {
 
-  value <- restoreInput(id = inputId, default = value)
-
   # build input tag
   inputTag <- tags$input(id = inputId, type = "number", class="form-control",
                          value = formatNoSci(value))

R/input-password.R

@@ -9,29 +9,12 @@
 #' @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)
-#' }
+#' passwordInput("password", "Password:")
 #' @export
-passwordInput <- function(inputId, label, value = "", width = NULL,
-                          placeholder = NULL) {
+passwordInput <- function(inputId, label, value = "", width = 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)
+    tags$input(id = inputId, type="password", class="form-control", value=value)
   )
 }

R/input-radiobuttons.R

@@ -21,33 +21,11 @@
 #' @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)
-#' }
+#' radioButtons("dist", "Distribution type:",
+#'              c("Normal" = "norm",
+#'                "Uniform" = "unif",
+#'                "Log-normal" = "lnorm",
+#'                "Exponential" = "exp"))
 #' @export
 radioButtons <- function(inputId, label, choices, selected = NULL,
   inline = FALSE, width = NULL) {
@@ -55,8 +33,6 @@ radioButtons <- function(inputId, label, choices, selected = NULL,
   # resolve names
   choices <- choicesWithNames(choices)
 
-  selected <- restoreInput(id = inputId, default = selected)
-
   # default value if it's not specified
   selected <- if (is.null(selected)) choices[[1]] else {
     validateSelected(selected, choices, inputId)

R/input-select.R

@@ -15,12 +15,7 @@
 #'
 #' @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.
-#'   This can also be a named list whose elements are (either named or
-#'   unnamed) lists or vectors. If this is the case, the outermost names
-#'   will be used as the "optgroup" label for the elements in the respective
-#'   sublist. This allows you to group and label similar choices. See the
-#'   example section for a small demo of this feature.
+#'   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.
@@ -36,49 +31,14 @@
 #' @seealso \code{\link{updateSelectInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' # basic example
-#' shinyApp(
-#'   ui = fluidPage(
-#'     selectInput("variable", "Variable:",
-#'                 c("Cylinders" = "cyl",
-#'                   "Transmission" = "am",
-#'                   "Gears" = "gear")),
-#'     tableOutput("data")
-#'   ),
-#'   server = function(input, output) {
-#'     output$data <- renderTable({
-#'       mtcars[, c("mpg", input$variable), drop = FALSE]
-#'     }, rownames = TRUE)
-#'   }
-#' )
-#'
-#' # demoing optgroup support in the `choices` arg
-#' shinyApp(
-#'   ui = fluidPage(
-#'     selectInput("state", "Choose a state:",
-#'       list(`East Coast` = c("NY", "NJ", "CT"),
-#'            `West Coast` = c("WA", "OR", "CA"),
-#'            `Midwest` = c("MN", "WI", "IA"))
-#'     ),
-#'     textOutput("result")
-#'   ),
-#'   server = function(input, output) {
-#'     output$result <- renderText({
-#'       paste("You chose", input$state)
-#'     })
-#'   }
-#' )
-#' }
+#' selectInput("variable", "Variable:",
+#'             c("Cylinders" = "cyl",
+#'               "Transmission" = "am",
+#'               "Gears" = "gear"))
 #' @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)
 
@@ -155,7 +115,7 @@ needOptgroup <- function(choices) {
 #' @rdname selectInput
 #' @param ... Arguments passed to \code{selectInput()}.
 #' @param options A list of options. See the documentation of \pkg{selectize.js}
-#'   for possible options (character option values inside \code{\link[base]{I}()} will
+#'   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\%'};
@@ -194,7 +154,7 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   if ('drag_drop' %in% options$plugins) {
     selectizeDep <- list(selectizeDep, htmlDependency(
-      'jqueryui', '1.12.1', c(href = 'shared/jqueryui'),
+      'jqueryui', '1.11.4', c(href = 'shared/jqueryui'),
       script = 'jquery-ui.min.js'
     ))
   }

R/input-slider.R

@@ -36,7 +36,7 @@
 #'   format string, to be passed to the Javascript strftime library. See
 #'   \url{https://github.com/samsonjs/strftime} for more details. The allowed
 #'   format specifications are very similar, but not identical, to those for R's
-#'   \code{\link[base]{strftime}} function. For Dates, the default is \code{"\%F"}
+#'   \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
@@ -48,28 +48,6 @@
 #' @family input elements
 #' @seealso \code{\link{updateSliderInput}}
 #'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' ui <- fluidPage(
-#'   sliderInput("obs", "Number of observations:",
-#'     min = 0, max = 1000, value = 500
-#'   ),
-#'   plotOutput("distPlot")
-#' )
-#'
-#' # Server logic
-#' server <- function(input, output) {
-#'   output$distPlot <- renderPlot({
-#'     hist(rnorm(input$obs))
-#'   })
-#' }
-#'
-#' # Complete app with UI and server components
-#' shinyApp(ui, server)
-#' }
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
                         round = FALSE, format = NULL, locale = NULL,
@@ -86,8 +64,6 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
-  value <- restoreInput(id = inputId, default = value)
-
   # If step is NULL, use heuristic to set the step size.
   findStepSize <- function(min, max, step) {
     if (!is.null(step)) return(step)
@@ -164,6 +140,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-grid` = ticks,
     `data-grid-num` = n_ticks,
     `data-grid-snap` = FALSE,
+    `data-prettify-separator` = sep,
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
@@ -175,12 +152,6 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-timezone` = timezone
   ))
 
-  if (sep == "") {
-    sliderProps$`data-prettify-enabled` <- "0"
-  } else {
-    sliderProps$`data-prettify-separator` <- sep
-  }
-
   # Replace any TRUE and FALSE with "true" and "false"
   sliderProps <- lapply(sliderProps, function(x) {
     if (identical(x, TRUE)) "true"
@@ -220,7 +191,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   }
 
   dep <- list(
-    htmlDependency("ionrangeslider", "2.1.2", c(href="shared/ionrangeslider"),
+    htmlDependency("ionrangeslider", "2.0.12", c(href="shared/ionrangeslider"),
       script = "js/ion.rangeSlider.min.js",
       # ion.rangeSlider also needs normalize.css, which is already included in
       # Bootstrap.
@@ -250,6 +221,7 @@ hasDecimals <- function(value) {
 #'   or list of tags (using \code{\link{tag}} and friends), or raw HTML (using
 #'   \code{\link{HTML}}).
 #' @param pauseButton Similar to \code{playButton}, but for the pause button.
+#'
 #' @export
 animationOptions <- function(interval=1000,
                              loop=FALSE,

R/input-submit.R

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

R/input-text.R

@@ -16,24 +16,11 @@
 #' @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)
-#' }
+#' textInput("caption", "Caption:", "Data Summary")
 #' @export
 textInput <- function(inputId, label, value = "", width = NULL,
   placeholder = NULL) {
 
-  value <- restoreInput(id = inputId, default = value)
-
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     label %AND% tags$label(label, `for` = inputId),

R/input-textarea.R

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

R/input-utils.R

@@ -4,13 +4,10 @@ controlLabel <- function(controlName, label) {
 
 
 # Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
-# refers to values. Below is a function for backward compatibility. It also
-# coerces the value to `character`.
+# refers to values. Below is a function for backward compatibility.
 validateSelected <- function(selected, choices, inputId) {
-  # this line accomplishes two tings:
-  #   - coerces selected to character
-  #   - drops name, otherwise toJSON() keeps it too
-  selected <- as.character(selected)
+  # 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)
@@ -66,7 +63,7 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
 
 
 # Takes a vector or list, and adds names (same as the value) to any entries
-# without names. Coerces all leaf nodes to `character`.
+# 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,
@@ -82,7 +79,7 @@ choicesWithNames <- function(choices) {
       if (is.list(val))
         listify(val)
       else if (length(val) == 1 && is.null(names(val)))
-        as.character(val)
+        val
       else
         makeNamed(as.list(val))
     })

R/insert-ui.R

@@ -1,174 +0,0 @@
-#' 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,6 +53,7 @@
 #'   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,
@@ -79,6 +80,8 @@ absolutePanel <- function(...,
   if (isTRUE(draggable)) {
     divTag <- tagAppendAttributes(divTag, class='draggable')
     return(tagList(
+      # IMPORTANT NOTE: If you update jqueryui, make sure you DON'T include the datepicker,
+      # as it collides with our bootstrap datepicker!
       singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
       divTag,
       tags$script('$(".draggable").draggable();')

R/middleware-shiny.R

@@ -41,229 +41,3 @@ sessionHandler <- function(req) {
     shinysession$handleRequest(subreq)
   })
 }
-
-apiHandler <- function(serverFuncSource) {
-  function(req) {
-    path <- req$PATH_INFO
-    if (is.null(path))
-      return(NULL)
-
-    matches <- regmatches(path, regexec('^/api/(.*)$', path))
-    if (length(matches[[1]]) == 0)
-      return(NULL)
-
-    apiName <- matches[[1]][2]
-
-    sharedSecret <- getOption('shiny.sharedSecret')
-    if (!is.null(sharedSecret)
-      && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
-      stop("Incorrect shared secret")
-    }
-
-    if (!is.null(getOption("shiny.observer.error", NULL))) {
-      warning(
-        call. = FALSE,
-        "options(shiny.observer.error) is no longer supported; please unset it!"
-      )
-      stopApp()
-    }
-
-    # need to give a fake websocket to the session
-    ws <- list(
-      request = req,
-      sendMessage = function(...) {
-        #print(list(...))
-      }
-    )
-
-    # Accept JSON query string and/or JSON body as input values
-    inputVals <- c(
-      parseQueryStringJSON(req$QUERY_STRING),
-      parseJSONBody(req)
-    )
-
-    shinysession <- ShinySession$new(ws)
-    on.exit({
-      try({
-        # Clean up the session. Very important, so that observers
-        # and such don't hang around, and to let memory get gc'd.
-        shinysession$wsClosed()
-        appsByToken$remove(shinysession$token)
-      })
-    }, add = TRUE)
-    appsByToken$set(shinysession$token, shinysession)
-    shinysession$setShowcase(.globals$showcaseDefault)
-
-    serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-
-    tryCatch({
-      withReactiveDomain(shinysession, {
-        shinysession$manageInputs(inputVals)
-        do.call(serverFunc, argsForServerFunc(serverFunc, shinysession))
-        result <- NULL
-        shinysession$enableApi(apiName, function(value) {
-          result <<- try(withLogErrors(value), silent = TRUE)
-        })
-        flushReact()
-        resultToResponse(result)
-      })
-    }, error = function(e) {
-      return(httpResponse(
-        status=500,
-        content=htmlEscape(conditionMessage(e))
-      ))
-    })
-  }
-}
-
-apiWsHandler <- function(serverFuncSource) {
-  function(ws) {
-    path <- ws$request$PATH_INFO
-    if (is.null(path))
-      return(NULL)
-
-    matches <- regmatches(path, regexec('^/api/(.*)$', path))
-    if (length(matches[[1]]) == 0)
-      return(NULL)
-
-    apiName <- matches[[1]][2]
-
-    sharedSecret <- getOption('shiny.sharedSecret')
-    if (!is.null(sharedSecret)
-      && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
-      ws$close()
-      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()
-    }
-
-    inputVals <- parseQueryStringJSON(ws$request$QUERY_STRING)
-
-    # Give a fake websocket to suppress messages from session
-    shinysession <- ShinySession$new(list(
-      request = ws$request,
-      sendMessage = function(...) {
-        #print(list(...))
-      }
-    ))
-    appsByToken$set(shinysession$token, shinysession)
-    shinysession$setShowcase(.globals$showcaseDefault)
-
-    serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-
-    tryCatch({
-      withReactiveDomain(shinysession, {
-        shinysession$manageInputs(inputVals)
-        do.call(serverFunc, argsForServerFunc(serverFunc, shinysession))
-        shinysession$enableApi(apiName, function(value) {
-          resp <- resultToResponse(value)
-          if (resp$status != 200L) {
-            warning("Error: ", responseToContent(resp))
-            ws$close()
-          } else {
-            content <- responseToContent(resp)
-            if (grepl("^image/", resp$content_type)) {
-              content <- paste0("data:", resp$content_type, ";base64,",
-                httpuv::rawToBase64(content))
-            }
-            try(ws$send(content), silent=TRUE)
-          }
-        })
-        flushReact()
-      })
-    }, error = function(e) {
-      ws$close()
-    })
-
-    ws$onClose(function() {
-      # Clean up the session. Very important, so that observers
-      # and such don't hang around, and to let memory get gc'd.
-      shinysession$wsClosed()
-      appsByToken$remove(shinysession$token)
-    })
-
-    # TODO: What to do on ws$onMessage?
-  }
-}
-
-parseJSONBody <- function(req) {
-  if (identical(req[["REQUEST_METHOD"]], "POST")) {
-    if (isTRUE(grepl(perl=TRUE, "^(text|application)/json(;\\s*charset\\s*=\\s*utf-8)?$", req[["HTTP_CONTENT_TYPE"]]))) {
-      tmp <- file("", "w+b")
-      on.exit(close(tmp))
-
-      input_file <- req[["rook.input"]]
-      while (TRUE) {
-        chunk <- input_file$read(8192L)
-        if (length(chunk) == 0)
-          break
-        writeBin(chunk, tmp)
-      }
-
-      return(jsonlite::fromJSON(tmp))
-    }
-
-    if (is.null(req[["HTTP_CONTENT_TYPE"]])) {
-      if (!is.null(req[["rook.input"]]) && length(req[["rook.input"]]$read(1L)) > 0) {
-        stop("Invalid POST request (body provided without content type)")
-      }
-      return()
-    }
-
-    stop("Invalid POST request (content type not supported)")
-  }
-}
-
-resultToResponse <- function(result) {
-  if (inherits(result, "httpResponse")) {
-    return(result)
-  } else if (inherits(result, "try-error")) {
-    return(httpResponse(
-      status=500,
-      content_type="text/plain",
-      content=conditionMessage(attr(result, "condition"))
-    ))
-  } else if (!is.null(attr(result, "content.type"))) {
-    return(httpResponse(
-      status=200L,
-      content_type=attr(result, "content.type"),
-      content=result
-    ))
-  } else {
-    return(httpResponse(
-      status=200L,
-      content_type="application/json",
-      content=toJSON(result, pretty=TRUE)
-    ))
-  }
-}
-
-responseToContent <- function(result) {
-  ct <- result$content_type
-  textMode <- grepl("^text/", ct) || ct == "application/json" ||
-    grepl("^application/xml($|\\+)", ct)
-
-  # TODO: Make sure text is UTF-8
-
-  if ("file" %in% names(result$content)) {
-    filename <- result$content$file
-    if ("owned" %in% names(result$content) && result$content$owned) {
-      on.exit(unlink(filename), add = TRUE)
-    }
-    if (textMode)
-      return(paste(readLines(filename), collapse = "\n"))
-    else
-      return(readBin(filename, raw(), file.info(filename)$size))
-  } else {
-    if (textMode)
-      return(paste(result$content, collapse = "\n"))
-    else
-      return(result$content)
-  }
-}

R/middleware.R

@@ -299,7 +299,9 @@ 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 {
@@ -308,18 +310,7 @@ HandlerManager <- R6Class("HandlerManager",
         },
         call = .httpServer(
           function (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)
-                }
-              }
-            )
+            withLogErrors(handlers$invoke(req))
           },
           getOption('shiny.sharedSecret')
         ),
@@ -342,7 +333,7 @@ HandlerManager <- R6Class("HandlerManager",
         }
 
         # Catch HEAD requests. For the purposes of handler functions, they
-        # should be treated like GET. The difference is that they shouldn't
+        # should be treated like GET. The difference is that  they shouldn't
         # return a body in the http response.
         head_request <- FALSE
         if (identical(req$REQUEST_METHOD, "HEAD")) {

R/modal.R

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

R/modules.R

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

R/notifications.R

@@ -1,106 +0,0 @@
-#' 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,14 +12,6 @@
 #' 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)}}{
@@ -56,10 +48,6 @@
 #' @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.
@@ -67,16 +55,11 @@
 #'   progress bar.
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   plotOutput("plot")
-#' )
-#'
-#' server <- function(input, output, session) {
+#' \dontrun{
+#' # server.R
+#' shinyServer(function(input, output, session) {
 #'   output$plot <- renderPlot({
-#'     progress <- Progress$new(session, min=1, max=15)
+#'     progress <- shiny::Progress$new(session, min=1, max=15)
 #'     on.exit(progress$close())
 #'
 #'     progress$set(message = 'Calculation in progress',
@@ -88,9 +71,7 @@
 #'     }
 #'     plot(cars)
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @seealso \code{\link{withProgress}}
 #' @format NULL
@@ -101,22 +82,18 @@ Progress <- R6Class(
   portable = TRUE,
   public = list(
 
-    initialize = function(session = getDefaultReactiveDomain(),
-      min = 0, max = 1,
-      style = getShinyOption("progress.style", default = "notification"))
-    {
-      if (is.null(session$progressStack))
+    initialize = function(session = getDefaultReactiveDomain(), min = 0, max = 1) {
+      if (!inherits(session, "ShinySession"))
         stop("'session' is not a ShinySession object.")
 
       private$session <- session
-      private$id <- createUniqueId(8)
+      private$id <- paste(as.character(as.raw(stats::runif(8, min=0, max=255))), collapse='')
       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, style = private$style))
+      session$sendProgress('open', list(id = private$id))
     },
 
     set = function(value = NULL, message = NULL, detail = NULL) {
@@ -138,8 +115,7 @@ Progress <- R6Class(
         id = private$id,
         message = message,
         detail = detail,
-        value = value,
-        style = private$style
+        value = value
       ))
 
        private$session$sendProgress('update', data)
@@ -165,9 +141,7 @@ Progress <- R6Class(
         return()
       }
 
-      private$session$sendProgress('close',
-        list(id = private$id, style = private$style)
-      )
+      private$session$sendProgress('close', list(id = private$id))
       private$closed <- TRUE
     }
   ),
@@ -177,7 +151,6 @@ Progress <- R6Class(
     id = character(0),
     min = numeric(0),
     max = numeric(0),
-    style = character(0),
     value = NULL,
     closed = logical(0)
   )
@@ -206,14 +179,6 @@ 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.
@@ -234,24 +199,14 @@ 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
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' ui <- fluidPage(
-#'   plotOutput("plot")
-#' )
-#'
-#' server <- function(input, output) {
+#' \dontrun{
+#' # server.R
+#' shinyServer(function(input, output) {
 #'   output$plot <- renderPlot({
 #'     withProgress(message = 'Calculation in progress',
 #'                  detail = 'This may take a while...', value = 0, {
@@ -262,30 +217,24 @@ 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,
-  style = getShinyOption("progress.style", default = "notification"),
-  session = getDefaultReactiveDomain(),
-  env = parent.frame(), quoted = FALSE)
-{
+                         value = min + (max - min) * 0.1,
+                         message = NULL, detail = NULL,
+                         session = getDefaultReactiveDomain(),
+                         env = parent.frame(), quoted = FALSE) {
 
   if (!quoted)
     expr <- substitute(expr)
 
-  if (is.null(session$progressStack))
+  if (!inherits(session, "ShinySession"))
     stop("'session' is not a ShinySession object.")
 
-  style <- match.arg(style, c("notification", "old"))
-
-  p <- Progress$new(session, min = min, max = max, style = style)
+  p <- Progress$new(session, min = min, max = max)
 
   session$progressStack$push(p)
   on.exit({
@@ -303,7 +252,7 @@ withProgress <- function(expr, min = 0, max = 1,
 setProgress <- function(value = NULL, message = NULL, detail = NULL,
                         session = getDefaultReactiveDomain()) {
 
-  if (is.null(session$progressStack))
+  if (!inherits(session, "ShinySession"))
     stop("'session' is not a ShinySession object.")
 
   if (session$progressStack$size() == 0) {
@@ -320,7 +269,7 @@ setProgress <- function(value = NULL, message = NULL, detail = NULL,
 incProgress <- function(amount = 0.1, message = NULL, detail = NULL,
                         session = getDefaultReactiveDomain()) {
 
-  if (is.null(session$progressStack))
+  if (!inherits(session, "ShinySession"))
     stop("'session' is not a ShinySession object.")
 
   if (session$progressStack$size() == 0) {

R/react.R

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

R/reactive-domains.R

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

R/render-plot.R

@@ -6,15 +6,6 @@
 #' 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}}.
@@ -28,27 +19,19 @@
 #'   inline plot, you must provide numeric values (in pixels) to both
 #'   \code{width} and \code{height}.
 #' @param res Resolution of resulting plot, in pixels per inch. This value is
-#'   passed to \code{\link[grDevices]{png}}. Note that this affects the resolution of PNG
+#'   passed to \code{\link{png}}. Note that this affects the resolution of PNG
 #'   rendering in R; it won't change the actual ppi of the browser.
 #' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
 #'   These can be used to set the width, height, background color, etc.
 #' @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 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.
+#' @param func A function that generates a plot (deprecated; use \code{expr}
+#'   instead).
+#'
 #' @export
 renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
-                       env=parent.frame(), quoted=FALSE,
-                       execOnResize=FALSE, outputArgs=list()
-) {
+                       env=parent.frame(), quoted=FALSE, func=NULL) {
   # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
   # is called
   installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
@@ -58,203 +41,12 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   if (is.function(width))
     widthWrapper <- reactive({ width() })
   else
-    widthWrapper <- function() { width }
+    widthWrapper <- NULL
 
   if (is.function(height))
     heightWrapper <- reactive({ height() })
   else
-    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
-    )
-  })
-
+    heightWrapper <- NULL
 
   # 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
@@ -263,7 +55,79 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   outputFunc <- plotOutput
   if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
 
-  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+  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")) {
+          utils::capture.output(coordmap <<- getGgplotCoordmap(result$value, pixelratio))
+        } else {
+          # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps the
+          # call to plotFunc
+          utils::capture.output(..stacktraceon..(print(result$value)))
+        }
+      }
+
+      if (is.null(coordmap)) {
+        coordmap <<- getPrevPlotCoordmap(width, 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=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
+  }))
 }
 
 # The coordmap extraction functions below return something like the examples
@@ -415,42 +279,61 @@ getPrevPlotCoordmap <- function(width, height) {
   ))
 }
 
-
-# Given a ggplot_build_gtable object, return a coordmap for it.
-getGgplotCoordmap <- function(p, pixelratio, res) {
-  # Structure of ggplot objects changed after 2.1.0
-  new_ggplot <- (utils::packageVersion("ggplot2") > "2.1.0")
-
-  if (!inherits(p, "ggplot_build_gtable"))
+# Print a ggplot object and return a coordmap for it.
+getGgplotCoordmap <- function(p, pixelratio) {
+  if (!inherits(p, "ggplot"))
     return(NULL)
 
+  # A modified version of print.ggplot which returns the built ggplot object as
+  # well as the gtable grob. This overrides the ggplot::print.ggplot method, but
+  # only within the context of getGgplotCoordmap. The reason this needs to be an
+  # (pseudo) S3 method is so that, if an object has a class in addition to
+  # ggplot, and there's a print method for that class, that we won't override
+  # that method.
+  # https://github.com/rstudio/shiny/issues/841
+  print.ggplot <- function(x) {
+    grid::grid.newpage()
+
+    build <- ggplot2::ggplot_build(x)
+
+    gtable <- ggplot2::ggplot_gtable(build)
+    grid::grid.draw(gtable)
+
+    list(
+      build = build,
+      gtable = gtable
+    )
+  }
+
+  # Given the name of a generic function and an object, return the class name
+  # for the method that would be used on the object.
+  which_method <- function(generic, x) {
+    classes <- class(x)
+    method_names <- paste(generic, classes, sep = ".")
+    idx <- which(method_names %in% utils::methods(generic))
+
+    if (length(idx) == 0)
+      return(NULL)
+
+    # Return name of first class with matching method
+    classes[idx[1]]
+  }
+
+
   # Given a built ggplot object, return x and y domains (data space coords) for
   # each panel.
   find_panel_info <- function(b) {
-    if (new_ggplot) {
-      layout <- b$layout$panel_layout
-    } else {
-      layout <- b$panel$layout
-    }
+    layout <- b$panel$layout
     # Convert factor to numbers
     layout$PANEL <- as.integer(as.character(layout$PANEL))
 
     # Names of facets
+    facet <- b$plot$facet
     facet_vars <- NULL
-    if (new_ggplot) {
-      facet <- b$layout$facet
-      if (inherits(facet, "FacetGrid")) {
-        facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
-      } else if (inherits(facet, "FacetWrap")) {
-        facet_vars <- vapply(facet$params$facets, as.character, character(1))
-      }
-    } else {
-      facet <- b$plot$facet
-      if (inherits(facet, "grid")) {
-        facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
-      } else if (inherits(facet, "wrap")) {
-        facet_vars <- vapply(facet$facets, as.character, character(1))
-      }
+    if (inherits(facet, "grid")) {
+      facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
+    } else if (inherits(facet, "wrap")) {
+      facet_vars <- vapply(facet$facets, as.character, character(1))
     }
 
     # Iterate over each row in the layout data frame
@@ -492,12 +375,8 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
   # Given a single range object (representing the data domain) from a built
   # ggplot object, return the domain.
   find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
-    if (new_ggplot) {
-      range <- b$layout$panel_ranges[[panel_num]]
-    } else {
-      range <- b$panel$ranges[[panel_num]]
-    }
-    domain <- list(
+    range <- b$panel$ranges[[panel_num]]
+    res <- list(
       left   = range$x.range[1],
       right  = range$x.range[2],
       bottom = range$y.range[1],
@@ -505,23 +384,19 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     )
 
     # Check for reversed scales
-    if (new_ggplot) {
-      xscale <- b$layout$panel_scales$x[[scalex_num]]
-      yscale <- b$layout$panel_scales$y[[scaley_num]]
-    } else {
-      xscale <- b$panel$x_scales[[scalex_num]]
-      yscale <- b$panel$y_scales[[scaley_num]]
-    }
+    xscale <- b$panel$x_scales[[scalex_num]]
+    yscale <- b$panel$y_scales[[scaley_num]]
+
     if (!is.null(xscale$trans) && xscale$trans$name == "reverse") {
-      domain$left  <- -domain$left
-      domain$right <- -domain$right
+      res$left  <- -res$left
+      res$right <- -res$right
     }
     if (!is.null(yscale$trans) && yscale$trans$name == "reverse") {
-      domain$top    <- -domain$top
-      domain$bottom <- -domain$bottom
+      res$top    <- -res$top
+      res$bottom <- -res$bottom
     }
 
-    domain
+    res
   }
 
   # Given built ggplot object, return object with the log base for x and y if
@@ -546,18 +421,10 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     y_names <- character(0)
 
     # Continuous scales have a trans; discrete ones don't
-    if (new_ggplot) {
-      if (!is.null(b$layout$panel_scales$x[[scalex_num]]$trans))
-        x_names <- b$layout$panel_scales$x[[scalex_num]]$trans$name
-      if (!is.null(b$layout$panel_scales$y[[scaley_num]]$trans))
-        y_names <- b$layout$panel_scales$y[[scaley_num]]$trans$name
-
-    } else {
-      if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
-        x_names <- b$panel$x_scales[[scalex_num]]$trans$name
-      if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
-        y_names <- b$panel$y_scales[[scaley_num]]$trans$name
-    }
+    if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
+      x_names <- b$panel$x_scales[[scalex_num]]$trans$name
+    if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
+      y_names <- b$panel$y_scales[[scaley_num]]$trans$name
 
     coords <- b$plot$coordinates
     if (!is.null(coords$trans)) {
@@ -611,11 +478,6 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
       )
     }
 
-    # Look for CoordFlip
-    if (inherits(b$plot$coordinates, "CoordFlip")) {
-      mappings[c("x", "y")] <- mappings[c("y", "x")]
-    }
-
     mappings_cache <<- mappings
     mappings
   }
@@ -642,22 +504,9 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
       }
     }
 
-    # 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) {
-      devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
-    }
-    w_px <- function(x) {
-      devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
-    }
+    h_px <- function(x) as.numeric(grid::convertHeight(x, "native"))
+    w_px <- function(x) as.numeric(grid::convertWidth(x, "native"))
 
     # Given a vector of relative sizes (in grid units), and a function for
     # converting grid units to numeric pixels, return a numeric vector of
@@ -724,25 +573,36 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     })
   }
 
+  # If print(p) gets dispatched to print.ggplot(p), attempt to extract coordmap.
+  # If dispatched to another method, just print the object and don't attempt to
+  # extract the coordmap. This can happen if there's another print method that
+  # takes precedence.
+  if (identical(which_method("print", p), "ggplot")) {
+    res <- print(p)
 
-  tryCatch({
-    # Get info from built ggplot object
-    info <- find_panel_info(p$build)
+    tryCatch({
+      # Get info from built ggplot object
+      info <- find_panel_info(res$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(p$gtable, pixelratio)
+      # Get ranges from gtable - it's possible for this to return more elements than
+      # info, because it calculates positions even for panels that aren't present.
+      # This can happen with facet_wrap.
+      ranges <- find_panel_ranges(res$gtable, pixelratio)
 
-    for (i in seq_along(info)) {
-      info[[i]]$range <- ranges[[i]]
-    }
+      for (i in seq_along(info)) {
+        info[[i]]$range <- ranges[[i]]
+      }
 
-    return(info)
+      return(info)
 
-  }, error = function(e) {
-    # If there was an error extracting info from the ggplot object, just return
-    # a list with the error message.
-    return(structure(list(), error = e$message))
-  })
+    }, error = function(e) {
+      # If there was an error extracting info from the ggplot object, just return
+      # a list with the error message.
+      return(structure(list(), error = e$message))
+    })
+
+  } else {
+    print(p)
+    return(list())
+  }
 }

R/render-table.R

@@ -3,221 +3,57 @@
 #' Creates a reactive table that is suitable for assigning to an \code{output}
 #' slot.
 #'
-#' The corresponding HTML output tag should be \code{div} and have the CSS
-#' class name \code{shiny-html-output}.
+#' The corresponding HTML output tag should be \code{div} and have the CSS class
+#' name \code{shiny-html-output}.
 #'
 #' @param expr An expression that returns an R object that can be used with
 #'   \code{\link[xtable]{xtable}}.
-#' @param 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 ... 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.
+#' @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, 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)
+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)
   }
 
-  # 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))
-
+  markRenderFunction(tableOutput, function() {
+    classNames <- getOption('shiny.table.class') %OR% 'data table table-bordered table-condensed'
     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)
+    if (is.null(data) || identical(data, data.frame()))
+      return("")
 
     # Separate the ... args to pass to xtable() vs print.xtable()
+    dots <- list(...)
     xtable_argnames <- setdiff(names(formals(xtable)), c("x", "..."))
     xtable_args <- dots[intersect(names(dots), xtable_argnames)]
     non_xtable_args <- dots[setdiff(names(dots), xtable_argnames)]
 
-    # 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)
+    # Call xtable with its args
     xtable_res <- do.call(xtable, c(list(data), xtable_args))
 
     # Set up print args
     print_args <- list(
-      x = xtable_res,
+      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), ";'"))
-
+      html.table.attributes = paste('class="', htmlEscape(classNames, TRUE),
+                                    '"', sep='')
+    )
     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)
+    return(paste(
+      utils::capture.output(
+        do.call(print, print_args)
+      ),
+      collapse="\n"
+    ))
+  })
 }

R/run-url.R

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

R/serializers.R

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

R/server-input-handlers.R

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

R/server.R

@@ -34,7 +34,7 @@ registerClient <- function(client) {
 #' JavaScript/CSS files available to their components.
 #'
 #' @param prefix The URL prefix (without slashes). Valid characters are a-z,
-#'   A-Z, 0-9, hyphen, period, and underscore.
+#'   A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
 #'   For example, a value of 'foo' means that any request paths that begin with
 #'   '/foo' will be mapped to the given directory.
 #' @param directoryPath The directory that contains the static resources to be
@@ -49,10 +49,11 @@ registerClient <- function(client) {
 #'
 #' @examples
 #' addResourcePath('datasets', system.file('data', package='datasets'))
+#'
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
-  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+  if (!grepl('^[a-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
     stop("addResourcePath called with invalid prefix; please see documentation")
   }
 
@@ -140,6 +141,7 @@ resourcePathHandler <- function(req) {
 #'   })
 #' }
 #' }
+#'
 #' @export
 shinyServer <- function(func) {
   .globals$server <- list(func)
@@ -189,7 +191,6 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
   appHandlers <- list(
     http = joinHandlers(c(
       sessionHandler,
-      apiHandler(serverFuncSource),
       httpHandlers,
       sys.www.root,
       resourcePathHandler,
@@ -201,11 +202,6 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
         return(TRUE)
       }
 
-      if (grepl("^/api/", ws$request$PATH_INFO)) {
-        apiWsHandler(serverFuncSource)(ws)
-        return(TRUE)
-      }
-
       if (!is.null(getOption("shiny.observer.error", NULL))) {
         warning(
           call. = FALSE,
@@ -224,8 +220,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
           if (is.character(msg))
             msg <- charToRaw(msg)
 
-          traceOption <- getOption('shiny.trace', FALSE)
-          if (isTRUE(traceOption) || traceOption == "recv") {
+          if (isTRUE(getOption('shiny.trace'))) {
             if (binary)
               message("RECV ", '$$binary data$$')
             else
@@ -237,105 +232,131 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
 
           msg <- decodeMessage(msg)
 
-          # 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)
+          # 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
+                }
+              }
             }
           }
 
-          withRestoreContext(shinysession$restoreContext, {
+          switch(
+            msg$method,
+            init = {
 
-            msg$data <- applyInputHandlers(msg$data)
-
-            switch(
-              msg$method,
-              init = {
-
-                serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-                if (!identicalFunctionBodies(serverFunc, appvars$server)) {
-                  appvars$server <- serverFunc
-                  if (!is.null(appvars$server))
-                  {
-                    # Tag this function as the Shiny server function. A debugger may use this
-                    # tag to give this function special treatment.
-                    # It's very important that it's appvars$server itself and NOT a copy that
-                    # is invoked, otherwise new breakpoints won't be picked up.
-                    attr(appvars$server, "shinyServerFunction") <- TRUE
-                    registerDebugHook("server", appvars, "Server Function")
-                  }
+              serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+              if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+                appvars$server <- serverFunc
+                if (!is.null(appvars$server))
+                {
+                  # Tag this function as the Shiny server function. A debugger may use this
+                  # tag to give this function special treatment.
+                  # It's very important that it's appvars$server itself and NOT a copy that
+                  # is invoked, otherwise new breakpoints won't be picked up.
+                  attr(appvars$server, "shinyServerFunction") <- TRUE
+                  registerDebugHook("server", appvars, "Server Function")
                 }
+              }
 
-                # Check for switching into/out of showcase mode
-                if (.globals$showcaseOverride &&
-                    exists(".clientdata_url_search", where = msg$data)) {
-                  mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
-                  if (!is.null(mode))
-                    shinysession$setShowcase(mode)
-                }
+              # Check for switching into/out of showcase mode
+              if (.globals$showcaseOverride &&
+                  exists(".clientdata_url_search", where = msg$data)) {
+                mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+                if (!is.null(mode))
+                  shinysession$setShowcase(mode)
+              }
 
-                shinysession$manageInputs(msg$data)
+              shinysession$manageInputs(msg$data)
 
-                # The client tells us what singletons were rendered into
-                # the initial page
-                if (!is.null(msg$data$.clientdata_singletons)) {
-                  shinysession$singletons <- strsplit(
-                    msg$data$.clientdata_singletons, ',')[[1]]
-                }
+              # The client tells us what singletons were rendered into
+              # the initial page
+              if (!is.null(msg$data$.clientdata_singletons)) {
+                shinysession$singletons <- strsplit(
+                  msg$data$.clientdata_singletons, ',')[[1]]
+              }
 
-                local({
-                  args <- argsForServerFunc(serverFunc, shinysession)
+              local({
+                args <- list(
+                  input=shinysession$input,
+                  output=.createOutputWriter(shinysession))
 
-                  withReactiveDomain(shinysession, {
-                    do.call(
-                      # No corresponding ..stacktraceoff; the server func is pure
-                      # user code
-                      wrapFunctionLabel(appvars$server, "server",
-                        ..stacktraceon = TRUE
-                      ),
-                      args
-                    )
-                  })
+                # 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(
+                    # No corresponding ..stacktraceoff; the server func is pure
+                    # user code
+                    wrapFunctionLabel(appvars$server, "server",
+                      ..stacktraceon = TRUE
+                    ),
+                    args
+                  )
                 })
-              },
-              update = {
-                shinysession$manageInputs(msg$data)
-              },
-              shinysession$dispatch(msg)
-            )
-            shinysession$manageHiddenOutputs()
+              })
+            },
+            update = {
+              shinysession$manageInputs(msg$data)
+            },
+            shinysession$dispatch(msg)
+          )
+          shinysession$manageHiddenOutputs()
 
-            if (exists(".shiny__stdout", globalenv()) &&
-                exists("HTTP_GUID", ws$request)) {
-              # safe to assume we're in shiny-server
-              shiny_stdout <- get(".shiny__stdout", globalenv())
+          if (exists(".shiny__stdout", globalenv()) &&
+              exists("HTTP_GUID", ws$request)) {
+            # safe to assume we're in shiny-server
+            shiny_stdout <- get(".shiny__stdout", globalenv())
 
-              # eNter a flushReact
-              writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
+            # eNter a flushReact
+            writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
+              " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+              sep=""), con=shiny_stdout)
+            flush(shiny_stdout)
 
-              flushReact()
+            flushReact()
 
-              # eXit a flushReact
-              writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-            } else {
-              flushReact()
-            }
-
-            flushAllSessions()
+            # 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
           })
         })
       }
@@ -355,26 +376,6 @@ 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.
@@ -436,12 +437,6 @@ 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()))
   }
 }
@@ -455,7 +450,10 @@ serviceApp <- function() {
     }
 
     flushReact()
-    flushAllSessions()
+
+    for (shinysession in appsByToken$values()) {
+      shinysession$flushOutput()
+    }
   }
 
   # If this R session is interactive, then call service() with a short timeout
@@ -468,9 +466,6 @@ serviceApp <- function() {
 
 .shinyServerMinVersion <- '0.3.4'
 
-# Global flag that's TRUE whenever we're inside of the scope of a call to runApp
-.globals$running <- FALSE
-
 #' Run Shiny Application
 #'
 #' Runs a Shiny application. This function normally does not return; interrupt R
@@ -512,9 +507,6 @@ serviceApp <- function() {
 #'   application. If set to \code{"normal"}, displays the application normally.
 #'   Defaults to \code{"auto"}, which displays the application in the mode given
 #'   in its \code{DESCRIPTION} file, if any.
-#' @param test.mode Should the application be launched in test mode? This is
-#'   only used for recording or running automated tests. Defaults to the
-#'   \code{shiny.testmode} option, or FALSE if the option is not set.
 #'
 #' @examples
 #' \dontrun{
@@ -527,8 +519,6 @@ serviceApp <- function() {
 #'
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
-#'   options(device.ask.default = FALSE)
-#'
 #'   # Apps can be run without a server.r and ui.r file
 #'   runApp(list(
 #'     ui = bootstrapPage(
@@ -560,76 +550,22 @@ runApp <- function(appDir=getwd(),
                                             interactive()),
                    host=getOption('shiny.host', '127.0.0.1'),
                    workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase"),
-                   test.mode=getOption('shiny.testmode', FALSE)) {
+                   display.mode=c("auto", "normal", "showcase")) {
   on.exit({
     handlerManager$clear()
   }, add = TRUE)
 
-  if (.globals$running) {
-    stop("Can't call `runApp()` from within `runApp()`. If your ,",
-         "application code contains `runApp()`, please remove it.")
-  }
-  .globals$running <- TRUE
-  on.exit({
-    .globals$running <- FALSE
-  }, add = TRUE)
 
-  # 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
-  # Set pool.scheduler to support pool package
-  ops <- options(warn = 1, pool.scheduler = scheduleTask)
+  ops <- options(warn = 1)
   on.exit(options(ops), add = TRUE)
 
-  appParts <- as.shiny.appobj(appDir)
-
-  # The lines below set some of the app's running options, which
-  # can be:
-  #   - left unspeficied (in which case the arguments' default
-  #     values from `runApp` kick in);
-  #   - passed through `shinyApp`
-  #   - passed through `runApp` (this function)
-  #   - passed through both `shinyApp` and `runApp` (the latter
-  #     takes precedence)
-  #
-  # Matrix of possibilities:
-  # | IN shinyApp | IN runApp | result       | check                                                                                                                                  |
-  # |-------------|-----------|--------------|----------------------------------------------------------------------------------------------------------------------------------------|
-  # | no          | no        | use defaults | exhaust all possibilities: if it's missing (runApp does not specify); THEN if it's not in shinyApp appParts$options; THEN use defaults |
-  # | yes         | no        | use shinyApp | if it's missing (runApp does not specify); THEN if it's in shinyApp appParts$options; THEN use shinyApp                                |
-  # | no          | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
-  # | yes         | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
-  #
-  # I tried to make this as compact and intuitive as possible,
-  # given that there are four distinct possibilities to check
-  appOps <- appParts$options
-  findVal <- function(arg, default) {
-    if (arg %in% names(appOps)) appOps[[arg]] else default
-  }
-
-  if (missing(port))
-    port <- findVal("port", port)
-  if (missing(launch.browser))
-    launch.browser <- findVal("launch.browser", launch.browser)
-  if (missing(host))
-    host <- findVal("host", host)
-  if (missing(quiet))
-    quiet <- findVal("quiet", quiet)
-  if (missing(display.mode))
-    display.mode <- findVal("display.mode", display.mode)
-  if (missing(test.mode))
-    test.mode <- findVal("test.mode", test.mode)
-
-  if (is.null(host) || is.na(host)) host <- '0.0.0.0'
-
   workerId(workerId)
 
-  if (inShinyServer()) {
+  if (nzchar(Sys.getenv('SHINY_PORT'))) {
     # 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
@@ -646,11 +582,6 @@ runApp <- function(appDir=getwd(),
   # the display.mode parameter. The latter takes precedence.
   setShowcaseDefault(0)
 
-  .globals$testMode <- test.mode
-  if (test.mode) {
-    message("Running application in test mode.")
-  }
-
   # If appDir specifies a path, and display mode is specified in the
   # DESCRIPTION file at that path, apply it here.
   if (is.character(appDir)) {
@@ -666,38 +597,21 @@ runApp <- function(appDir=getwd(),
       on.exit(close(con), add = TRUE)
       settings <- read.dcf(con)
       if ("DisplayMode" %in% colnames(settings)) {
-        mode <- settings[1, "DisplayMode"]
+        mode <- settings[1,"DisplayMode"]
         if (mode == "Showcase") {
           setShowcaseDefault(1)
-          if ("IncludeWWW" %in% colnames(settings)) {
-            .globals$IncludeWWW <- as.logical(settings[1, "IncludeWWW"])
-            if (is.na(.globals$IncludeWWW)) {
-              stop("In your Description file, `IncludeWWW` ",
-                   "must be set to `True` (default) or `False`")
-            }
-          } else {
-            .globals$IncludeWWW <- TRUE
-          }
         }
       }
     }
   }
 
-  ## default is to show the .js, .css and .html files in the www directory
-  ## (if not in showcase mode, this variable will simply be ignored)
-  if (is.null(.globals$IncludeWWW) || is.na(.globals$IncludeWWW)) {
-    .globals$IncludeWWW <- TRUE
-  }
-
   # If display mode is specified as an argument, apply it (overriding the
   # value specified in DESCRIPTION, if any).
   display.mode <- match.arg(display.mode)
-  if (display.mode == "normal") {
+  if (display.mode == "normal")
     setShowcaseDefault(0)
-  }
-  else if (display.mode == "showcase") {
+  else if (display.mode == "showcase")
     setShowcaseDefault(1)
-  }
 
   require(shiny)
 
@@ -718,14 +632,7 @@ runApp <- function(appDir=getwd(),
       }
       else {
         # Try up to 20 random ports
-        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
-          }
-        }
+        port <- p_randomInt(3000, 8000)
       }
 
       # Test port to see if we can use it
@@ -738,11 +645,7 @@ runApp <- function(appDir=getwd(),
     }
   }
 
-  # 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)
-
+  appParts <- as.shiny.appobj(appDir)
   # 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))
@@ -775,31 +678,20 @@ runApp <- function(appDir=getwd(),
     callAppHook("onAppStop", appUrl)
   }, add = TRUE)
 
-  .globals$reterror <- NULL
   .globals$retval <- NULL
   .globals$stopped <- FALSE
   # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
   # reactive(), Callbacks$invoke(), and others
   ..stacktraceoff..(
-    captureStackTraces({
-      # If any observers were created before runApp was called, this will make
-      # sure they run once the app starts. (Issue #1013)
-      scheduleFlush()
-
+    captureStackTraces(
       while (!.globals$stopped) {
         serviceApp()
         Sys.sleep(0.001)
       }
-    })
+    )
   )
 
-  if (isTRUE(.globals$reterror)) {
-    stop(.globals$retval)
-  }
-  else if (.globals$retval$visible)
-    .globals$retval$value
-  else
-    invisible(.globals$retval$value)
+  return(.globals$retval)
 }
 
 #' Stop the currently running Shiny app
@@ -809,26 +701,10 @@ runApp <- function(appDir=getwd(),
 #'
 #' @param returnValue The value that should be returned from
 #'   \code{\link{runApp}}.
+#'
 #' @export
 stopApp <- function(returnValue = invisible()) {
-  # reterror will indicate whether retval is an error (i.e. it should be passed
-  # 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$retval <- returnValue
   .globals$stopped <- TRUE
   httpuv::interrupt()
 }
@@ -891,140 +767,3 @@ 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

@@ -1,83 +0,0 @@
-.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,46 +20,62 @@ withMathJax <- function(...) {
       singleton(tags$script(src = path, type = 'text/javascript'))
     ),
     ...,
-    tags$script(HTML('if (window.MathJax) MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
+    tags$script(HTML('MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
   )
 }
 
-renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
-  # If the ui is a NOT complete document (created by htmlTemplate()), then do some
-  # preprocessing and make sure it's a complete document.
-  if (!inherits(ui, "html_document")) {
-    if (showcase > 0)
-      ui <- showcaseUI(ui)
+renderPage <- function(ui, connection, showcase=0) {
 
-    # 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)
+  if (showcase > 0)
+    ui <- showcaseUI(ui)
 
-    # Put the body into the default template
-    ui <- htmlTemplate(
-      system.file("template", "default.html", package = "shiny"),
-      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)
 
-  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")
+  result <- renderTags(ui)
+
+  deps <- c(
+    list(
+      htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
+      htmlDependency("jquery", "1.11.3", c(href="shared"), script = "jquery.min.js"),
+      htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
+        script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
+        stylesheet = "shiny.css")
+    ),
+    result$dependencies
   )
+  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")
 
-  if (testMode) {
-    # Add code injection listener if in test mode
-    shiny_deps[[length(shiny_deps) + 1]] <-
-      htmlDependency("shiny-testmode", utils::packageVersion("shiny"),
-        c(href="shared"), script = "shiny-testmode.js")
-  }
+  # write preamble
+  writeUTF8(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)
+  writeUTF8(c(result$head,
+               '</head>',
+               recursive=TRUE),
+             con = connection)
 
-  html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
-  writeUTF8(html, con = connection)
+  writeUTF8(result$html, con = connection)
+
+  # write end document
+  writeUTF8('</html>',
+             con = connection)
 }
 
 #' Create a Shiny UI handler
@@ -72,6 +88,7 @@ renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
 #'
 #' @param ui A user interace definition
 #' @return The user interface definition, without modifications or side effects.
+#'
 #' @export
 shinyUI <- function(ui) {
   .globals$ui <- list(ui)
@@ -98,40 +115,21 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
       if (!is.null(mode))
         showcaseMode <- mode
     }
-
-    testMode <- .globals$testMode %OR% FALSE
-
-    # Create a restore context using query string
-    bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
-    if (bookmarkStore == "disable") {
-      # If bookmarking is disabled, use empty context
-      restoreContext <- RestoreContext$new()
-    } else {
-      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())
-        }
+    uiValue <- if (is.function(ui)) {
+      if (length(formals(ui)) > 0) {
+        # No corresponding ..stacktraceoff.., this is pure user code
+        ..stacktraceon..(ui(req))
       } 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
+        # No corresponding ..stacktraceoff.., this is pure user code
+        ..stacktraceon..(ui())
       }
-    })
+    } else {
+      ui
+    }
     if (is.null(uiValue))
       return(NULL)
 
-    renderPage(uiValue, textConn, showcaseMode, testMode)
+    renderPage(uiValue, textConn, showcaseMode)
     html <- paste(readLines(textConn, encoding = 'UTF-8'), collapse='\n')
     return(httpResponse(200, content=enc2utf8(html)))
   }

R/shinywrappers.R

@@ -12,74 +12,24 @@ 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, 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(...)
-  }
-
+markRenderFunction <- function(uiFunc, renderFunc) {
   structure(renderFunc,
-            class       = c("shiny.render.function", "function"),
-            outputFunc  = uiFunc,
-            outputArgs  = outputArgs,
-            hasExecuted = hasExecuted)
+            class      = c("shiny.render.function", "function"),
+            outputFunc = uiFunc)
 }
 
 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"]]) && !("inline" %in% names(outputArgs))) {
-    outputArgs[["inline"]] <- inline
-  }
-
-  do.call(outputFunction, outputArgs)
+  if (is.logical(formals(outputFunction)[["inline"]])) {
+    outputFunction(id, inline = inline)
+  } else outputFunction(id)
 }
 
 #' @export
@@ -119,24 +69,13 @@ 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
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
+#' \dontrun{
 #'
-#' ui <- fluidPage(
-#'   sliderInput("n", "Number of observations", 2, 1000, 500),
-#'   plotOutput("plot1"),
-#'   plotOutput("plot2"),
-#'   plotOutput("plot3")
-#' )
-#'
-#' server <- function(input, output, session) {
+#' shinyServer(function(input, output, clientData) {
 #'
 #'   # A plot of fixed size
 #'   output$plot1 <- renderImage({
@@ -158,14 +97,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  <- session$clientData$output_plot2_width
-#'     height <- session$clientData$output_plot2_height
+#'     width  <- clientData$output_plot2_width
+#'     height <- clientData$output_plot2_height
 #'
 #'     # A temp file to save the output.
 #'     outfile <- tempfile(fileext='.png')
 #'
 #'     png(outfile, width=width, height=height)
-#'     hist(rnorm(input$n))
+#'     hist(rnorm(input$obs))
 #'     dev.off()
 #'
 #'     # Return a list containing the filename
@@ -176,8 +115,6 @@ 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',
@@ -186,15 +123,14 @@ 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, outputArgs=list()) {
+                        deleteFile=TRUE) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
+  return(markRenderFunction(imageOutput, 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.
@@ -211,9 +147,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
     # Return a list with src, and other img attributes
     c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
       extra_attr)
-  }
-
-  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
+  }))
 }
 
 
@@ -221,7 +155,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' Makes a reactive version of the given function that captures any printed
 #' output, and also captures its printable result (unless
-#' \code{\link[base]{invisible}}), into a string. The resulting function is suitable
+#' \code{\link{invisible}}), into a string. The resulting function is suitable
 #' for assigning to an  \code{output} slot.
 #'
 #' The corresponding HTML output tag can be anything (though \code{pre} is
@@ -233,33 +167,34 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' Note that unlike most other Shiny output functions, if the given function
 #' returns \code{NULL} then \code{NULL} will actually be visible in the output.
-#' To display nothing, make your function return \code{\link[base]{invisible}()}.
+#' To display nothing, make your function return \code{\link{invisible}()}.
 #'
 #' @param expr An expression that may print output and/or return a printable R
 #'   object.
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
-#'   is useful if you want to save an expression in a variable.
-#' @param width The value for \code{\link[base]{options}('width')}.
-#' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to \code{\link{verbatimTextOutput}} when \code{renderPrint} is used
-#'   in an interactive R Markdown document.
+#' @param func A function that may print output and/or return a printable R
+#'   object (deprecated; use \code{expr} instead).
+#' @param width The value for \code{\link{options}('width')}.
 #' @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,
-                        width = getOption('width'), outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+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)
+  }
 
-  renderFunc <- function(shinysession, name, ...) {
+  markRenderFunction(verbatimTextOutput, function() {
     op <- options(width = width)
     on.exit(options(op), add = TRUE)
     paste(utils::capture.output(func()), collapse = "\n")
-  }
-
-  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
+  })
 }
 
 #' Text Output
@@ -280,25 +215,26 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
 #' @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{textOutput}} when \code{renderText} is used in an
-#'   interactive R Markdown document.
+#' @param func A function that returns an R object that can be used as an
+#'   argument to \code{cat}.(deprecated; use \code{expr} instead).
 #'
 #' @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,
-                       outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
-
-  renderFunc <- function(shinysession, name, ...) {
-    value <- func()
-    return(paste(utils::capture.output(cat(value)), collapse="\n"))
+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)
   }
 
-  markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
+  markRenderFunction(textOutput, function() {
+    value <- func()
+    return(paste(utils::capture.output(cat(value)), collapse="\n"))
+  })
 }
 
 #' UI Output
@@ -314,136 +250,46 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #' @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{uiOutput}} when \code{renderUI} is used in an
-#'   interactive R Markdown document.
+#' @param func A function that returns a Shiny tag object, \code{\link{HTML}},
+#'   or a list of such objects (deprecated; use \code{expr} instead).
 #'
 #' @seealso conditionalPanel
+#'
 #' @export
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   uiOutput("moreControls")
-#' )
-#'
-#' server <- function(input, output) {
+#' \dontrun{
 #'   output$moreControls <- renderUI({
-#'     tagList(
-#'       sliderInput("n", "N", 1, 1000, 500),
-#'       textInput("label", "Label")
+#'     list(
+#'
 #'     )
 #'   })
 #' }
-#' shinyApp(ui, server)
-#' }
-#'
-renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
-                     outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+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)
+  }
 
-  renderFunc <- function(shinysession, name, ...) {
+  markRenderFunction(uiOutput, function(shinysession, name, ...) {
     result <- func()
     if (is.null(result) || length(result) == 0)
       return(NULL)
 
-    processDeps(result, shinysession)
-  }
+    result <- takeSingletons(result, shinysession$singletons, desingleton=FALSE)$ui
+    result <- surroundSingletons(result)
+    dependencies <- lapply(resolveDependencies(findDependencies(result)),
+      createWebDependency)
+    names(dependencies) <- NULL
 
-  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
-}
-
-#' @export
-serveJSON <- function(expr, env=parent.frame(), quoted=FALSE) {
-  installExprFunction(expr, "func", env, quoted)
-  function() {
-    structure(
-      toJSON(func(), pretty = TRUE),
-      content.type = "application/json"
+    # renderTags returns a list with head, singletons, and html
+    output <- list(
+      html = doRenderTags(result),
+      deps = dependencies
     )
-  }
-}
 
-#' @export
-servePlot <- function(expr, env=parent.frame(), quoted=FALSE,
-  defaultWidth = 600, defaultHeight = 400) {
-
-  if (!is.function(defaultWidth))
-    defaultWidth <- valueToFunc(defaultWidth)
-  if (!is.function(defaultHeight))
-    defaultHeight <- valueToFunc(defaultHeight)
-
-  installExprFunction(expr, "func", env, quoted)
-  function() {
-    input <- getDefaultReactiveDomain()$input
-    w <- if (!is.null(input$`plot-width`)) as.numeric(input$`plot-width`) else defaultWidth()
-    h <- if (!is.null(input$`plot-height`)) as.numeric(input$`plot-height`) else defaultHeight()
-
-    pngfile <- plotPNG(function() {
-      result <- withVisible(func())
-      if (result$visible) {
-        # Use capture.output to squelch printing to the actual console; we
-        # are only interested in plot output
-        utils::capture.output({
-          # 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.
-          print(result$value)
-        })
-      }
-    }, width = w, height = h)
-
-    structure(
-      list(file = pngfile, owned = TRUE),
-      content.type = "image/png"
-    )
-  }
-}
-
-#' @importFrom utils write.csv
-#' @export
-serveCSV <- function(expr, env=parent.frame(), quoted=FALSE, row.names=FALSE) {
-  installExprFunction(expr, "func", env, quoted)
-  function() {
-    tmp <- tempfile(".csv")
-    write.csv(func(), tmp, row.names=row.names)
-    structure(
-      list(file = tmp, owned = TRUE),
-      content.type = "text/csv"
-    )
-  }
-}
-
-#' @export
-serveText <- function(expr, env=parent.frame(), quoted=FALSE) {
-  installExprFunction(expr, "func", env, quoted)
-  function() {
-    structure(
-      paste(func(), collapse = "\n"),
-      content.type = "text/plain"
-    )
-  }
-}
-
-#' @export
-serveRaw <- function(expr, env=parent.frame(), quoted=FALSE, contentType) {
-
-  if (!is.function(contentType))
-    contentType <- valueToFunc(contentType)
-
-  installExprFunction(expr, "func", env, quoted)
-  function() {
-    bytes <- func()
-    if (!is.raw(bytes)) {
-      stop("serveRaw expects raw vector data")
-    }
-    structure(
-      bytes,
-      content.type = contentType()
-    )
-  }
+    return(output)
+  })
 }
 
 #' File Downloads
@@ -469,40 +315,28 @@ serveRaw <- function(expr, env=parent.frame(), quoted=FALSE, contentType) {
 #'   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
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   downloadLink("downloadData", "Download")
+#' \dontrun{
+#' # In server.R:
+#' output$downloadData <- downloadHandler(
+#'   filename = function() {
+#'     paste('data-', Sys.Date(), '.csv', sep='')
+#'   },
+#'   content = function(file) {
+#'     write.csv(data, file)
+#'   }
 #' )
 #'
-#' 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)
-#'     }
-#'   )
+#' # In ui.R:
+#' downloadLink('downloadData', 'Download')
 #' }
 #'
-#' shinyApp(ui, server)
-#' }
 #' @export
-downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()) {
-  renderFunc <- function(shinysession, name, ...) {
+downloadHandler <- function(filename, content, contentType=NA) {
+  return(markRenderFunction(downloadButton, function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
-  }
-  markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+  }))
 }
 
 #' Table output with the JavaScript library DataTables
@@ -513,7 +347,7 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #' the server infrastructure.
 #'
 #' For the \code{options} argument, the character elements that have the class
-#' \code{"AsIs"} (usually returned from \code{\link[base]{I}()}) will be evaluated in
+#' \code{"AsIs"} (usually returned from \code{\link{I}()}) will be evaluated in
 #' JavaScript. This is useful when the type of the option value is not supported
 #' in JSON, e.g., a JavaScript function, which can be obtained by evaluating a
 #' character string. Note this only applies to the root-level elements of the
@@ -533,10 +367,6 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #'   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
@@ -571,11 +401,10 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #' }
 renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             callback = 'function(oTable) {}', escape = TRUE,
-                            env = parent.frame(), quoted = FALSE,
-                            outputArgs=list()) {
+                            env = parent.frame(), quoted = FALSE) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
+  markRenderFunction(dataTableOutput, function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
     options <- checkDT9(options)
     res <- checkAsIs(options)
@@ -601,9 +430,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
       evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
       callback = paste(callback, collapse = '\n'), escape = escape
     )
-  }
-
-  markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+  })
 }
 
 # a data frame containing the DataTables 1.9 and 1.10 names

R/showcase.R

@@ -31,7 +31,7 @@ licenseLink <- function(licenseName) {
 showcaseHead <- function() {
 
   deps  <- list(
-    htmlDependency("jqueryui", "1.12.1", c(href="shared/jqueryui"),
+    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,60 +77,10 @@ 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",
@@ -138,21 +88,27 @@ showcaseCodeTabs <- function(codeLicense) {
       icon("level-up"),
       "show with app"),
     ul(class="nav nav-tabs",
-       navTabsHelper(rFiles),
-       navTabsDropdown(unlist(wwwFiles))
-    ),
+       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))
+       })),
     div(class="tab-content", id="showcase-code-content",
-        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")
-    ),
+        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))))
+        })),
     codeLicense))
 }
 
@@ -221,4 +177,3 @@ showcaseUI <- function(ui) {
     showcaseBody(ui)
   )
 }
-

R/test-export.R

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

R/timer.R

@@ -22,11 +22,6 @@ 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
 
@@ -61,7 +56,7 @@ TimerCallbacks <- R6Class(
     },
     executeElapsed = function() {
       elapsed <- takeElapsed()
-      if (nrow(elapsed) == 0)
+      if (length(elapsed) == 0)
         return(FALSE)
 
       for (id in elapsed$id) {
@@ -76,16 +71,3 @@ 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,16 +6,9 @@
 #' @seealso \code{\link{textInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' 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.
@@ -29,9 +22,7 @@
 #'       label = paste("New label", x),
 #'       value = paste("New text", x))
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
@@ -39,44 +30,6 @@ 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
 #'
@@ -86,87 +39,26 @@ updateTextAreaInput <- updateTextInput
 #' @seealso \code{\link{checkboxInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' 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 odd, FALSE if even.
-#'     x_even <- input$controller %% 2 == 1
+#'     # TRUE if input$controller is even, FALSE otherwise.
+#'     x_even <- input$controller %% 2 == 0
 #'
 #'     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. Supply \code{NA} to clear the date.
+#'   \code{yyyy-mm-dd} format.
 #' @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
@@ -175,44 +67,32 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 #' @seealso \code{\link{dateInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' ui <- fluidPage(
-#'   sliderInput("n", "Day of month", 1, 30, 10),
-#'   dateInput("inDate", "Input date")
-#' )
-#'
-#' server <- function(input, output, session) {
 #'   observe({
-#'     date <- as.Date(paste0("2013-04-", input$n))
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
 #'     updateDateInput(session, "inDate",
-#'       label = paste("Date label", input$n),
-#'       value = date,
-#'       min   = date - 3,
-#'       max   = date + 3
+#'       label = paste("Date label", x),
+#'       value = paste("2013-04-", x, sep=""),
+#'       min   = paste("2013-04-", x-1, sep=""),
+#'       max   = paste("2013-04-", x+1, sep="")
 #'     )
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
                             min = NULL, max = NULL) {
 
-  # 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)
+  # 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")
 
   message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
@@ -223,9 +103,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. Supplying \code{NA} clears the start date.
+#'   \code{yyyy-mm-dd} format.
 #' @param end The end date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the end date.
+#'   \code{yyyy-mm-dd} format.
 #' @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
@@ -234,29 +114,20 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #' @seealso \code{\link{dateRangeInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' ui <- fluidPage(
-#'   sliderInput("n", "Day of month", 1, 30, 10),
-#'   dateRangeInput("inDateRange", "Input date range")
-#' )
-#'
-#' server <- function(input, output, session) {
 #'   observe({
-#'     date <- as.Date(paste0("2013-04-", input$n))
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
 #'
 #'     updateDateRangeInput(session, "inDateRange",
-#'       label = paste("Date range label", input$n),
-#'       start = date - 1,
-#'       end = date + 1,
-#'       min = date - 5,
-#'       max = date + 5
-#'     )
+#'       label = paste("Date range label", x),
+#'       start = paste("2013-01-", x, sep=""))
+#'       end = paste("2013-12-", x, sep=""))
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateDateRangeInput <- function(session, inputId, label = NULL,
@@ -271,7 +142,7 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 
   message <- dropNulls(list(
     label = label,
-    value = dropNulls(list(start = start, end = end)),
+    value = c(start, end),
     min = min,
     max = max
   ))
@@ -291,31 +162,22 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 #' \code{\link{navbarPage}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' 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")
-#'     )
-#'   )
-#' ))
+#'   observe({
+#'     # TRUE if input$controller is even, FALSE otherwise.
+#'     x_even <- input$controller %% 2 == 0
 #'
-#' server <- function(input, output, session) {
-#'   observeEvent(input$controller, {
-#'     updateTabsetPanel(session, "inTabset",
-#'       selected = paste0("panel", input$controller)
-#'     )
+#'     # 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")
+#'     }
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateTabsetPanel <- function(session, inputId, selected = NULL) {
@@ -342,18 +204,10 @@ updateNavlistPanel <- updateTabsetPanel
 #' @seealso \code{\link{numericInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' 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, {
+#'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
 #'     x <- input$controller
@@ -364,9 +218,7 @@ updateNavlistPanel <- updateTabsetPanel
 #'       label = paste("Number label ", x),
 #'       value = x, min = x-10, max = x+10, step = 5)
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
@@ -457,11 +309,11 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
   if (!is.null(choices))
     choices <- choicesWithNames(choices)
   if (!is.null(selected))
-    selected <- validateSelected(selected, choices, session$ns(inputId))
+    selected <- validateSelected(selected, choices, inputId)
 
   options <- if (!is.null(choices)) {
     format(tagList(
-      generateOptions(session$ns(inputId), choices, selected, inline, type = type)
+      generateOptions(inputId, choices, selected, inline, type = type)
     ))
   }
 
@@ -478,35 +330,31 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' @seealso \code{\link{checkboxGroupInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' 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({
-#'     x <- input$inCheckboxGroup
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
 #'
-#'     # Can use character(0) to remove all choices
-#'     if (is.null(x))
-#'       x <- character(0)
+#'     # 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 also set the label and select items
 #'     updateCheckboxGroupInput(session, "inCheckboxGroup2",
-#'       label = paste("Checkboxgroup label", length(x)),
-#'       choices = x,
-#'       selected = x
+#'       label = paste("checkboxgroup label", x),
+#'       choices = cb_options,
+#'       selected = sprintf("option-%d-2", x)
 #'     )
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateCheckboxGroupInput <- function(session, inputId, label = NULL,
@@ -524,31 +372,29 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' @seealso \code{\link{radioButtons}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' 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({
-#'     x <- input$inRadioButtons
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
 #'
-#'     # Can also set the label and select items
-#'     updateRadioButtons(session, "inRadioButtons2",
-#'       label = paste("radioButtons label", x),
-#'       choices = x,
-#'       selected = x
+#'     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)
 #'     )
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
@@ -567,35 +413,32 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @seealso \code{\link{selectInput}}
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
+#' \dontrun{
+#' shinyServer(function(input, output, session) {
 #'
-#' 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({
-#'     x <- input$inCheckboxGroup
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
 #'
-#'     # Can use character(0) to remove all choices
-#'     if (is.null(x))
-#'       x <- character(0)
+#'     # 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 also set the label and select items
-#'     updateSelectInput(session, "inSelect",
-#'       label = paste("Select input label", length(x)),
-#'       choices = x,
-#'       selected = tail(x, 1)
+#'     # 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)
 #'     )
 #'   })
-#' }
-#'
-#' shinyApp(ui, server)
+#' })
 #' }
 #' @export
 updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
@@ -622,7 +465,7 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     res <- checkAsIs(options)
     cfg <- tags$script(
       type = 'application/json',
-      `data-for` = session$ns(inputId),
+      `data-for` = inputId,
       `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
       HTML(toJSON(res$options))
     )
@@ -632,7 +475,6 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
   value <- unname(selected)
-  attr(choices, 'selected_value') <- value
   message <- dropNulls(list(
     label = label,
     value = value,
@@ -650,8 +492,6 @@ selectizeJSON <- function(data, req) {
   key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
   if (identical(key, '')) key <- character(0)
   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: , ...}
@@ -675,11 +515,6 @@ selectizeJSON <- function(data, req) {
   }
   # only return the first n rows (n = maximum options in configuration)
   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,6 +23,7 @@ NULL
 #' rnormA(3)  # [1]  1.8285879 -0.7468041 -0.4639111
 #' rnormA(5)  # [1]  1.8285879 -0.7468041 -0.4639111 -1.6510126 -1.4686924
 #' rnormB(5)  # [1] -0.7946034  0.2568374 -0.6567597  1.2451387 -0.8375699
+#'
 #' @export
 repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max)) {
   force(seed)
@@ -154,20 +155,6 @@ 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
@@ -182,55 +169,6 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
-
-# Given a vector/list, returns a named vector (the labels will be blank).
-asNamedVector <- function(x) {
-  if (!is.null(names(x)))
-    return(x)
-
-  names(x) <- rep.int("", length(x))
-  x
-}
-
-# Given two named vectors, join them together, and keep only the last element
-# with a given name in the resulting vector. If b has any elements with the same
-# name as elements in a, the element in a is dropped. Also, if there are any
-# duplicated names in a or b, only the last one with that name is kept.
-mergeVectors <- function(a, b) {
-  if (anyUnnamed(a) || anyUnnamed(b)) {
-    stop("Vectors must be either NULL or have names for all elements")
-  }
-
-  x <- c(a, b)
-  drop_idx <- duplicated(names(x), fromLast = TRUE)
-  x[!drop_idx]
-}
-
-# Sort a vector by the names of items. If there are multiple items with the
-# same name, preserve the original order of those items. For empty
-# vectors/lists/NULL, return the original value.
-sortByName <- function(x) {
-  if (anyUnnamed(x))
-    stop("All items must be named")
-
-  # Special case for empty vectors/lists, and NULL
-  if (length(x) == 0)
-    return(x)
-
-  x[order(names(x))]
-}
-
-# Wrapper around list2env with a NULL check. In R <3.2.0, if an empty unnamed
-# list is passed to list2env(), it errors. But an empty named list is OK. For
-# R >=3.2.0, this wrapper is not necessary.
-list2env2 <- function(x, ...) {
-  # Ensure that zero-length lists have a name attribute
-   if (length(x) == 0)
-    attr(x, "names") <- character(0)
-
-  list2env(x, ...)
-}
-
 # Combine dir and (file)name into a file path. If a file already exists with a
 # name differing only by case, then use it instead.
 file.path.ci <- function(...) {
@@ -273,12 +211,6 @@ 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.
@@ -350,7 +282,7 @@ download <- function(url, ...) {
       #         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, ...))
+      suppressWarnings(download.file(url, method = method, ...))
 
     } else {
       # If non-Windows, check for libcurl/curl/wget/lynx, then call download.file with
@@ -411,6 +343,8 @@ 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
@@ -444,14 +378,35 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #'
 #' isolate(tripleA())
 #' # "text, text, text"
+#'
 #' @export
-exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
-  if (!quoted) {
-    expr <- eval(substitute(substitute(expr)), parent.frame())
+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)
   }
 
-  # expr is a quoted expression
-  makeFunction(body=expr, env=env)
+  if (quoted) {
+    # expr is a quoted expression
+    makeFunction(body=expr, env=env)
+  } else {
+    # expr is an unquoted expression
+    makeFunction(body=expr_sub, env=env)
+  }
 }
 
 #' Install an expression as a function
@@ -477,30 +432,20 @@ exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
 #'   the name of the calling function.
 #' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
 #'   \code{\link{stacktrace}}.
+#'
 #' @export
 installExprFunction <- function(expr, name, eval.env = parent.frame(2),
                                 quoted = FALSE,
                                 assign.env = parent.frame(1),
-                                label = deparse(sys.call(-1)[[1]]),
+                                label = as.character(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")
-  }
+  func <- exprToFunction(expr, eval.env, quoted, 2)
   if (wrappedWithLabel) {
     func <- wrapFunctionLabel(func, label, ..stacktraceon = ..stacktraceon)
-  } else {
-    registerDebugHook(name, assign.env, label)
   }
   assign(name, func, envir = assign.env)
+  registerDebugHook(name, assign.env, label)
 }
 
 #' Parse a GET query string from a URL
@@ -520,7 +465,7 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
 #'
 #' \dontrun{
 #' # Example of usage within a Shiny app
-#' function(input, output, session) {
+#' shinyServer(function(input, output, session) {
 #'
 #'   output$queryText <- renderText({
 #'     query <- parseQueryString(session$clientData$url_search)
@@ -536,7 +481,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) {
@@ -548,8 +493,6 @@ 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))
@@ -576,20 +519,6 @@ parseQueryString <- function(str, nested = FALSE) {
   res
 }
 
-parseQueryStringJSON <- function(str, nested = FALSE) {
-  vals <- parseQueryString(str, nested)
-  mapply(names(vals), vals, SIMPLIFY = FALSE,
-    FUN = function(name, value) {
-      tryCatch(
-        jsonlite::fromJSON(value),
-        error = function(e) {
-          stop("Failed to parse URL parameter \"", name, "\"")
-        }
-      )
-    }
-  )
-}
-
 # Assign value to the bottom element of the list x using recursive indices idx
 assignNestedList <- function(x = list(), idx, value) {
   for (i in seq_along(idx)) {
@@ -604,16 +533,10 @@ assignNestedList <- function(x = list(), idx, value) {
 # option (e.g. we can set options(shiny.error = recover))
 #' @include conditions.R
 shinyCallingHandlers <- function(expr) {
-  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()
-    }
-  )
+  withCallingHandlers(captureStackTraces(expr), error = function(e) {
+    handle <- getOption('shiny.error')
+    if (is.function(handle)) handle()
+  })
 }
 
 #' Print message for deprecated functions in Shiny
@@ -679,10 +602,7 @@ Callbacks <- R6Class(
     .callbacks = 'Map',
 
     initialize = function() {
-      # 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)
+      .nextId <<- as.integer(.Machine$integer.max)
       .callbacks <<- Map$new()
     },
     register = function(callback) {
@@ -732,21 +652,6 @@ dataTablesJSON <- function(data, req) {
   q <- parseQueryString(params, nested = TRUE)
   ci <- q$search[['caseInsensitive']] == 'true'
 
-  # data may have been replaced/updated in the new table while the Ajax request
-  # from the previous table is still on its way, so it is possible that the old
-  # request asks for more columns than the current data, in which case we should
-  # discard this request and return empty data; the next Ajax request from the
-  # new table will retrieve the correct number of columns of data
-  if (length(q$columns) != ncol(data)) {
-    res <- toJSON(list(
-      draw = as.integer(q$draw),
-      recordsTotal = n,
-      recordsFiltered = 0,
-      data = NULL
-    ))
-    return(httpResponse(200, 'application/json', enc2utf8(res)))
-  }
-
   # global searching
   i <- seq_len(n)
   if (length(q$search[['value']]) && q$search[['value']] != '') {
@@ -947,143 +852,6 @@ 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
@@ -1140,17 +908,15 @@ reactiveStop <- function(message = "", class = NULL) {
 #'   \code{shiny-output-error-} prepended to this value.
 #' @export
 #' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' ui <- fluidPage(
+#' # in ui.R
+#' fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
 #'   selectizeInput('in2', 'Select a state', choices = state.name),
 #'   plotOutput('plot')
 #' )
 #'
-#' server <- function(input, output) {
+#' # in server.R
+#' function(input, output) {
 #'   output$plot <- renderPlot({
 #'     validate(
 #'       need(input$in1, 'Check at least one letter!'),
@@ -1159,10 +925,6 @@ reactiveStop <- function(message = "", class = NULL) {
 #'     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
@@ -1183,7 +945,8 @@ validate <- function(..., errorClass = character(0)) {
   # There may be empty strings remaining; these are message-less failures that
   # started as FALSE
   results <- results[nzchar(results)]
-  reactiveStop(paste(results, collapse="\n"), c(errorClass, "validation"))
+
+  stopWithCondition(c("validation", errorClass), paste(results, collapse="\n"))
 }
 
 #' @param expr An expression to test. The condition will pass if the expression
@@ -1206,202 +969,6 @@ 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[base]{logical}}, is \code{TRUE} or \code{FALSE}. We use
-#' the term a little loosely here; our usage tries to match the intuitive
-#' notions of "Is this value missing or available?", or "Has the user provided
-#' an answer?", or in the case of action buttons, "Has the button been
-#' 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)
@@ -1430,7 +997,7 @@ isTruthy <- function(x) {
 stopWithCondition <- function(class, message) {
   cond <- structure(
     list(message = message),
-    class = c(class, 'error', 'condition')
+    class = c(class, 'shiny.silent.error', 'error', 'condition')
   )
   stop(cond)
 }
@@ -1481,10 +1048,6 @@ checkEncoding <- function(file) {
             'http://shiny.rstudio.com/articles/unicode.html for more info.')
     return('UTF-8-BOM')
   }
-  x <- readChar(file, size, useBytes = TRUE)
-  if (is.na(iconv(x, 'UTF-8', 'UTF-8'))) {
-    warning('The input file ', file, ' does not seem to be encoded in UTF8')
-  }
   'UTF-8'
 }
 
@@ -1510,18 +1073,14 @@ sourceUTF8 <- function(file, envir = globalenv()) {
   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)
-  }
+  # **can** be encoded natively on Windows (might be a bug in base R); we fall
+  # back to parse(text) in this case
+  exprs <- tryCatch(
+    parse(file, keep.source = FALSE, srcfile = src, encoding = enc),
+    error = function(e) {
+      parse(text = lines, keep.source = FALSE, srcfile = src, encoding = enc)
+    }
+  )
 
   # Wrap the exprs in first `{`, then ..stacktraceon..(). It's only really the
   # ..stacktraceon..() that we care about, but the `{` is needed to make that
@@ -1540,8 +1099,7 @@ makeCall <- function(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, ...))
+if (getRversion() <= '3.2.2') srcfilecopy <- function(filename, lines, ...) {
   src <- base::srcfilecopy(filename, lines = '', ...)
   src$lines <- lines
   src
@@ -1569,7 +1127,6 @@ wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
     stop("Invalid name for wrapFunctionLabel: ", name)
   }
   assign(name, func, environment())
-  registerDebugHook(name, environment(), name)
 
   relabelWrapper <- eval(substitute(
     function(...) {
@@ -1585,23 +1142,3 @@ wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
 
   relabelWrapper
 }
-
-
-# This is a very simple mutable object which only stores one value
-# (which we can set and get). Using this class is sometimes useful
-# when communicating persistent changes across functions.
-Mutable <- R6Class("Mutable",
-  private = list(
-    value = NULL
-  ),
-  public = list(
-    set = function(value) { private$value <- value },
-    get = function() { private$value }
-  )
-)
-
-# Turn a value into a no-arg function that returns that value
-valueToFunc <- function(val) {
-  force(val)
-  function() val
-}

README.md

@@ -1,8 +1,6 @@
 # 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)
+[![Build Status](https://travis-ci.org/rstudio/shiny.svg?branch=master)](https://travis-ci.org/rstudio/shiny)
 
 Shiny is a new package from RStudio that makes it incredibly easy to build interactive web applications with R.
 
@@ -59,10 +57,6 @@ devtools::install_version("shiny", version = "0.10.2.2")
 
 The Javascript code in Shiny is minified using tools that run on Node.js. See the tools/ directory for more information.
 
-## Guidelines for contributing
-
-We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.md](CONTRIBUTING.md) file for detailed guidelines of how to contribute.
-
 ## License
 
 The shiny package is licensed under the GPLv3. See these files in the inst directory for additional details:

appveyor.yml

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

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

@@ -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
-function(input, output) {
+shinyServer(function(input, output) {
 
   # Expression that generates a histogram. The expression is
   # wrapped in a call to renderPlot to indicate that:
@@ -18,4 +18,4 @@ 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
-fluidPage(
+shinyUI(fluidPage(
 
   # Application title
   titlePanel("Hello Shiny!"),
@@ -21,4 +21,4 @@ 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
-function(input, output) {
+shinyServer(function(input, output) {
   
   # Return the requested dataset
   datasetInput <- reactive({
@@ -23,4 +23,4 @@ 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
-fluidPage(
+shinyUI(fluidPage(
   
   # Application title
   titlePanel("Shiny Text"),
@@ -24,4 +24,4 @@ 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
-function(input, output) {
+shinyServer(function(input, output) {
 
   # By declaring datasetInput as a reactive expression we ensure 
   # that:
@@ -50,4 +50,4 @@ 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
-fluidPage(
+shinyUI(fluidPage(
   
   # Application title
   titlePanel("Reactivity"),
@@ -31,4 +31,4 @@ 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
-function(input, output) {
+shinyServer(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 @@ 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
-fluidPage(
+shinyUI(fluidPage(
   
   # Application title
   titlePanel("Miles Per Gallon"),
@@ -26,4 +26,4 @@ fluidPage(
       plotOutput("mpgPlot")
     )
   )
-)
+))

inst/examples/05_sliders/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic for slider examples
-function(input, output) {
+shinyServer(function(input, output) {
   
   # Reactive expression to compose a data frame containing all of
   # the values
@@ -26,4 +26,4 @@ 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
-fluidPage(
+shinyUI(fluidPage(
 
   #  Application title
   titlePanel("Sliders"),
@@ -40,4 +40,4 @@ fluidPage(
       tableOutput("values")
     )
   )
-)
+))

inst/examples/06_tabsets/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic for random distribution application
-function(input, output) {
+shinyServer(function(input, output) {
   
   # Reactive expression to generate the requested distribution.
   # This is called whenever the inputs change. The output
@@ -41,4 +41,4 @@ 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 
-fluidPage(
+shinyUI(fluidPage(
     
   # Application title
   titlePanel("Tabsets"),
@@ -35,4 +35,4 @@ fluidPage(
       )
     )
   )
-)
+))

inst/examples/07_widgets/Readme.md

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

inst/examples/07_widgets/server.R

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

inst/examples/07_widgets/ui.R

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

inst/examples/08_html/server.R

@@ -1,7 +1,7 @@
 library(shiny)
 
 # Define server logic for random distribution application
-function(input, output) {
+shinyServer(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 @@ function(input, output) {
     data.frame(x=data())
   })
   
-}
+})

inst/examples/09_upload/server.R

@@ -1,6 +1,6 @@
 library(shiny)
 
-function(input, output) {
+shinyServer(function(input, output) {
   output$contents <- renderTable({
     
     # input$file1 will be NULL initially. After the user selects
@@ -17,4 +17,4 @@ 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)
 
-fluidPage(
+shinyUI(fluidPage(
   titlePanel("Uploading Files"),
   sidebarLayout(
     sidebarPanel(
@@ -25,4 +25,4 @@ fluidPage(
       tableOutput('contents')
     )
   )
-)
+))

inst/examples/10_download/server.R

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

inst/examples/10_download/ui.R

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

inst/examples/11_timer/server.R

@@ -1,6 +1,6 @@
-function(input, output, session) {
+shinyServer(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 @@
-fluidPage(
+shinyUI(fluidPage(
   textOutput("currentTime")
-)
+))

inst/staticdocs/index.r

@@ -5,8 +5,6 @@ sd_section("UI Layout",
     "bootstrapPage",
     "column",
     "conditionalPanel",
-    "fillPage",
-    "fillRow",
     "fixedPage",
     "fluidPage",
     "headerPanel",
@@ -44,10 +42,7 @@ sd_section("UI Inputs",
     "sliderInput",
     "submitButton",
     "textInput",
-    "textAreaInput",
     "passwordInput",
-    "modalButton",
-    "updateActionButton",
     "updateCheckboxGroupInput",
     "updateCheckboxInput",
     "updateDateInput",
@@ -57,9 +52,7 @@ sd_section("UI Inputs",
     "updateSelectInput",
     "updateSliderInput",
     "updateTabsetPanel",
-    "updateTextInput",
-    "updateTextAreaInput",
-    "updateQueryString"
+    "updateTextInput"
   )
 )
 sd_section("UI Outputs",
@@ -73,11 +66,7 @@ sd_section("UI Outputs",
     "verbatimTextOutput",
     "downloadButton",
     "Progress",
-    "withProgress",
-    "modalDialog",
-    "urlModal",
-    "showModal",
-    "showNotification"
+    "withProgress"
   )
 )
 sd_section("Interface builder functions",
@@ -89,12 +78,7 @@ sd_section("Interface builder functions",
     "singleton",
     "tag",
     "validateCssUnit",
-    "withTags",
-    "htmlTemplate",
-    "bootstrapLib",
-    "suppressDependencies",
-    "insertUI",
-    "removeUI"
+    "withTags"
   )
 )
 sd_section("Rendering functions",
@@ -115,25 +99,23 @@ sd_section("Rendering functions",
     "reactiveUI"
   )
 )
-sd_section("Reactive programming",
+sd_section("Reactive constructs",
   "A sub-library that provides reactive programming facilities for R.",
   c(
-    "reactive",
-    "observe",
-    "observeEvent",
-    "reactiveValues",
-    "reactiveValuesToList",
+    "invalidateLater",
     "is.reactivevalues",
     "isolate",
-    "invalidateLater",
-    "debounce",
-    "showReactLog",
     "makeReactiveBinding",
+    "observe",
+    "observeEvent",
+    "reactive",
     "reactiveFileReader",
     "reactivePoll",
     "reactiveTimer",
+    "reactiveValues",
+    "reactiveValuesToList",
     "domains",
-    "freezeReactiveValue"
+    "showReactLog"
   )
 )
 sd_section("Boilerplate",
@@ -147,22 +129,9 @@ sd_section("Running",
   "Functions that are used to run or stop Shiny applications.",
   c(
     "runApp",
-    "runGadget",
     "runExample",
-    "runGadget",
     "runUrl",
-    "stopApp",
-    "viewer"
-  )
-)
-sd_section("Bookmarking state",
-  "Functions that are used for bookmarking and restoring state.",
-  c(
-    "bookmarkButton",
-    "enableBookmarking",
-    "setBookmarkExclude",
-    "showBookmarkUrlModal",
-    "onBookmark"
+    "stopApp"
   )
 )
 sd_section("Extending Shiny",
@@ -178,19 +147,12 @@ 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",
-    "applyInputHandlers",
     "exprToFunction",
     "installExprFunction",
     "parseQueryString",
     "plotPNG",
-    "exportTestValues",
     "repeatable",
     "shinyDeprecated",
     "serverInfo",

inst/template/default.html

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

inst/tests/test-bootstrap.r

@@ -56,7 +56,7 @@ test_that("Choices are correctly assigned names", {
   # Unnamed list
   expect_identical(
     choicesWithNames(list("a","b",3)),
-    list(a="a", b="b", "3"="3")
+    list(a="a", b="b", "3"=3)
   )
   # Vector, with some named, some not
   expect_identical(
@@ -66,38 +66,23 @@ test_that("Choices are correctly assigned names", {
   # List, with some named, some not
   expect_identical(
     choicesWithNames(list(A="a", "b", C=3, 4)),
-    list(A="a", "b"="b", C="3", "4"="4")
+    list(A="a", "b"="b", C=3, "4"=4)
   )
   # List, named, with a sub-vector
   expect_identical(
     choicesWithNames(list(A="a", B="b", C=c("d", "e"))),
     list(A="a", B="b", C=list(d="d", e="e"))
   )
-  # List, named, with a sub-vector with numeric elements
-  expect_identical(
-    choicesWithNames(list(A="a", B="b", C=c(1, 2))),
-    list(A="a", B="b", C=list(`1`="1", `2`="2"))
-  )
   # List, named, with sublist
   expect_identical(
     choicesWithNames(list(A="a", B="b", C=list("d", "e"))),
     list(A="a", B="b", C=list(d="d", e="e"))
   )
-  # List, named, with sublist with numeric elements
-  expect_identical(
-    choicesWithNames(list(A="a", B="b", C=list(1, 2))),
-    list(A="a", B="b", C=list(`1`="1", `2`="2"))
-  )
   # List, named, with a named sub-vector of length 1
   expect_identical(
     choicesWithNames(list(A="a", B="b", C=c(D="d"))),
     list(A="a", B="b", C=list(D="d"))
   )
-  # List, named, with a named sub-vector of length 1 with a numeric element
-  expect_identical(
-    choicesWithNames(list(A="a", B="b", C=c(D=1))),
-    list(A="a", B="b", C=list(D="1"))
-  )
   # List, some named, with sublist
   expect_identical(
     choicesWithNames(list(A="a", "b", C=list("d", E="e"))),

inst/tests/test-plot-coordmap.R

@@ -6,16 +6,6 @@ sortList <- function(x) {
   x[sort(names(x))]
 }
 
-# Extract the print.ggplot function from inside of renderPlot. Yuck.
-print_ggplot_expr <- Filter(function(x) {
-  is.call(x) &&
-  x[[1]] == as.name("<-") &&
-  x[[2]] == as.name("print.ggplot")
-}, body(renderPlot))[[1]]
-# This will create print.ggplot in the current environment
-eval(print_ggplot_expr)
-
-
 test_that("ggplot coordmap", {
   dat <- data.frame(xvar = c(0, 5), yvar = c(10, 20))
 
@@ -26,8 +16,8 @@ test_that("ggplot coordmap", {
   p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
     scale_x_continuous(expand = c(0, 0)) +
     scale_y_continuous(expand = c(0, 0))
-  png(tmpfile, width = 500, height = 500)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  png(tmpfile)
+  m <- getGgplotCoordmap(p, 1)
   dev.off()
 
   # Check mapping vars
@@ -37,26 +27,12 @@ test_that("ggplot coordmap", {
     sortList(m[[1]]$domain),
     sortList(list(left=0, right=5, bottom=10, top=20))
   )
-  # Check for no log bases
-  expect_equal(
-    sortList(m[[1]]$log),
-    sortList(list(x=NULL, y=NULL))
-  )
-  # panel_vars should be an empty named list
-  expect_identical(m[[1]]$panel_vars, list(a=1)[0])
-  # Sanity check for ranges. Checking exact range values isn't feasible due to
-  # variations in graphics devices, and possible changes to positioning in
-  # ggplot2.
-  expect_true(m[[1]]$range$left    >  20 && m[[1]]$range$left   <  70)
-  expect_true(m[[1]]$range$right   > 480 && m[[1]]$range$right  < 499)
-  expect_true(m[[1]]$range$bottom  > 450 && m[[1]]$range$bottom < 490)
-  expect_true(m[[1]]$range$top     > 1   && m[[1]]$range$top    <  20)
 
 
   # Scatterplot where aes() is declared in geom
   p <- ggplot(dat, aes(xvar)) + geom_point(aes(y=yvar))
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(p, 1)
   dev.off()
 
   # Check mapping vars
@@ -66,7 +42,7 @@ test_that("ggplot coordmap", {
   # Plot with computed variable (histogram)
   p <- ggplot(dat, aes(xvar)) + geom_histogram(binwidth=1)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(p, 1)
   dev.off()
 
   # Check mapping vars - no value for y
@@ -87,7 +63,7 @@ test_that("ggplot coordmap with facet_wrap", {
     scale_y_continuous(expand = c(0, 0)) +
     facet_wrap(~ g, ncol = 2)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(p, 1)
   dev.off()
 
   # Should have 3 panels
@@ -136,7 +112,7 @@ test_that("ggplot coordmap with facet_grid", {
   # facet_grid horizontal
   p1 <- p + facet_grid(. ~ g)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p1), 1, 72)
+  m <- getGgplotCoordmap(p1, 1)
   dev.off()
 
   # Should have 3 panels
@@ -173,7 +149,7 @@ test_that("ggplot coordmap with facet_grid", {
   # facet_grid vertical
   p1 <- p + facet_grid(g ~ .)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p1), 1, 72)
+  m <- getGgplotCoordmap(p1, 1)
   dev.off()
 
   # Should have 3 panels
@@ -221,7 +197,7 @@ test_that("ggplot coordmap with 2D facet_grid", {
 
   p1 <- p + facet_grid(g ~ h)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p1), 1, 72)
+  m <- getGgplotCoordmap(p1, 1)
   dev.off()
 
   # Should have 4 panels
@@ -259,105 +235,3 @@ test_that("ggplot coordmap with 2D facet_grid", {
   expect_equal(m[[3]]$panel_vars, list(panelvar1 = dat$h[1], panelvar2 = dat$g[2]))
   expect_equal(m[[4]]$panel_vars, list(panelvar1 = dat$h[2], panelvar2 = dat$g[2]))
 })
-
-
-test_that("ggplot coordmap with various data types", {
-  tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
-
-  # Factors
-  dat <- expand.grid(xvar = letters[1:3], yvar = LETTERS[1:4])
-  p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
-    scale_x_discrete(expand = c(0 ,0)) +
-    scale_y_discrete(expand = c(0, 0))
-  png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
-  dev.off()
-
-  # Check domain
-  expect_equal(
-    sortList(m[[1]]$domain),
-    sortList(list(left=1, right=3, bottom=1, top=4))
-  )
-
-  # Dates and date-times
-  dat <- data.frame(
-    xvar = as.Date("2016-09-27") + c(0, 10),
-    yvar = as.POSIXct("2016-09-27 09:00:00", origin = "1960-01-01", tz = "GMT") + c(3600, 0)
-  )
-  p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
-    scale_x_date(expand = c(0 ,0)) +
-    scale_y_datetime(expand = c(0, 0))
-  png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
-  dev.off()
-
-  # Check domain
-  expect_equal(
-    sortList(m[[1]]$domain),
-    sortList(list(
-      left   = as.numeric(dat$xvar[1]),
-      right  = as.numeric(dat$xvar[2]),
-      bottom = as.numeric(dat$yvar[2]),
-      top    = as.numeric(dat$yvar[1])
-    ))
-  )
-})
-
-test_that("ggplot coordmap with various scales and coords", {
-  tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
-
-  # Reversed scales
-  dat <- data.frame(xvar = c(0, 5), yvar = c(10, 20))
-  p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
-    scale_x_continuous(expand = c(0 ,0)) +
-    scale_y_reverse(expand = c(0, 0))
-  png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
-  dev.off()
-
-  # Check domain (y reversed)
-  expect_equal(
-    sortList(m[[1]]$domain),
-    sortList(list(left=0, right=5, bottom=20, top=10))
-  )
-
-  # coord_flip
-  p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
-    scale_x_continuous(expand = c(0 ,0)) +
-    scale_y_continuous(expand = c(0 ,0)) +
-    coord_flip()
-  png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
-  dev.off()
-
-  # Check mapping vars
-  expect_equal(m[[1]]$mapping, list(x = "yvar", y = "xvar"))
-  # Check domain (y reversed)
-  expect_equal(
-    sortList(m[[1]]$domain),
-    sortList(list(left=10, right=20, bottom=0, top=5))
-  )
-
-  # Log scales and log coord transformations
-  dat <- data.frame(xvar = c(10^-1, 10^3), yvar = c(2^-2, 2^4))
-  p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
-    scale_x_log10(expand = c(0 ,0)) +
-    scale_y_continuous(expand = c(0, 0)) +
-    coord_trans(y = "log2")
-  png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
-  dev.off()
-
-  # Check log bases
-  expect_equal(
-    sortList(m[[1]]$log),
-    sortList(list(x=10, y=2))
-  )
-  # Check domains
-  expect_equal(
-    sortList(m[[1]]$domain),
-    sortList(list(left=-1, right=3, bottom=-2, top=4))
-  )
-})

inst/tests/test-reactivity.r

@@ -596,9 +596,9 @@ test_that("reactive() accepts quoted and unquoted expressions", {
   fun <- reactive(q_expr, quoted = TRUE)
   expect_equal(isolate(fun()), 2)
 
-  # Functions being passed to reactives is no longer treated specially
-  fun <- reactive(function() { vals$A + 1 })
-  expect_true(is.function(isolate(fun())))
+  # If function is used, work, but print message
+  expect_message(fun <- reactive(function() { vals$A + 1 }))
+  expect_equal(isolate(fun()), 2)
 
 
   # Check that environment is correct - parent environment should be this one
@@ -637,10 +637,10 @@ test_that("observe() accepts quoted and unquoted expressions", {
   flushReact()
   expect_equal(valB, 4)
 
-  # Functions are no longer treated specially
-  observe(function() { valB <<- vals$A + 5 })
+  # If function is used, work, but print message
+  expect_message(observe(function() { valB <<- vals$A + 5 }))
   flushReact()
-  expect_equal(valB, 4)
+  expect_equal(valB, 5)
 
 
   # Check that environment is correct - parent environment should be this one
@@ -664,15 +664,6 @@ test_that("Observer priorities are respected", {
   expect_identical(results, c(30, 20, 21, 22, 10))
 })
 
-test_that("installExprFunction doesn't rely on name being `expr`", {
-  justExecute <- function(anExpression, envirToUse = parent.frame(), isQuoted = FALSE) {
-    shiny:::installExprFunction(anExpression, "myFunc", envirToUse, quoted = isQuoted)
-    myFunc()
-  }
-
-  expect_identical(-1, justExecute({-1}))
-})
-
 test_that("reactivePoll and reactiveFileReader", {
   path <- tempfile('file')
   on.exit(unlink(path))
@@ -819,66 +810,6 @@ test_that("observers autodestroy (or not)", {
   })
 })
 
-test_that("observers are garbage collected when destroyed", {
-  domain <- createMockDomain()
-  rv <- reactiveValues(x = 1)
-
-  # Auto-destroy. GC on domain end.
-  a <- observe(rv$x, domain = domain)
-  # No auto-destroy. GC with rv.
-  b <- observe(rv$x, domain = domain, autoDestroy = FALSE)
-  # No auto-destroy and no reactive dependencies. GC immediately.
-  c <- observe({}, domain = domain)
-  c$setAutoDestroy(FALSE)
-  # Similar to b, but we'll set it to autoDestroy later.
-  d <- observe(rv$x, domain = domain, autoDestroy = FALSE)
-  # Like a, but we'll destroy it immediately.
-  e <- observe(rx$x, domain = domain)
-  e$destroy()
-
-  collected <- new.env(parent = emptyenv())
-
-  reg.finalizer(a, function(o) collected$a <- TRUE)
-  reg.finalizer(b, function(o) collected$b <- TRUE)
-  reg.finalizer(c, function(o) collected$c <- TRUE)
-  reg.finalizer(d, function(o) collected$d <- TRUE)
-  reg.finalizer(e, function(o) collected$e <- TRUE)
-
-  rm(list = c("a", "b", "c", "e")) # Not "d"
-
-  gc()
-  # Nothing can be GC'd yet, because all of the observers are
-  # pending execution (i.e. waiting for flushReact).
-  expect_equal(ls(collected), character())
-
-  flushReact()
-  # Now "c" can be garbage collected, because it ran and took
-  # no dependencies (and isn't tied to the session in any way).
-  # And "e" can also be garbage collected, it's been destroyed.
-  gc()
-  expect_equal(ls(collected), c("c", "e"))
-
-  domain$end()
-  # We can GC "a" as well; even though it references rv, it is
-  # destroyed when the session ends.
-  gc()
-  expect_equal(sort(ls(collected)), c("a", "c", "e"))
-
-  # It's OK to turn on auto-destroy even after the session was
-  # destroyed.
-  d$setAutoDestroy(TRUE)
-  # This should no-op.
-  d$setAutoDestroy(FALSE)
-  rm(d)
-  gc()
-  expect_equal(sort(ls(collected)), c("a", "c", "d", "e"))
-
-  rm(rv)
-  # Both rv and "b" can now be collected.
-  gc()
-  expect_equal(sort(ls(collected)), c("a", "b", "c", "d", "e"))
-})
-
 test_that("maskReactiveContext blocks use of reactives", {
   vals <- reactiveValues(x = 123)
 
@@ -976,83 +907,3 @@ test_that("event handling helpers take correct dependencies", {
   expect_equal(execCount(o1), 2)
   expect_equal(execCount(o2), 2)
 })
-
-run_debounce_throttle <- function(do_priming) {
-  # The changing of rv$a will be the (chatty) source of reactivity.
-  rv <- reactiveValues(a = 0)
-
-  # This observer will be what changes rv$a.
-  src <- observe({
-    invalidateLater(100)
-    rv$a <- isolate(rv$a) + 1
-  })
-  on.exit(src$destroy(), add = TRUE)
-
-  # Make a debounced reactive to test.
-  dr <- debounce(reactive(rv$a), 500)
-
-  # Make a throttled reactive to test.
-  tr <- throttle(reactive(rv$a), 500)
-
-  # Keep track of how often dr/tr are fired
-  dr_fired <- 0
-  dr_monitor <- observeEvent(dr(), {
-    dr_fired <<- dr_fired + 1
-  })
-  on.exit(dr_monitor$destroy(), add = TRUE)
-
-  tr_fired <- 0
-  tr_monitor <- observeEvent(tr(), {
-    tr_fired <<- tr_fired + 1
-  })
-  on.exit(tr_monitor$destroy(), add = TRUE)
-
-  # Starting values are both 0. Earlier I found that the tests behaved
-  # differently if I accessed the values of dr/tr before the first call to
-  # flushReact(). That bug was fixed, but to ensure that similar bugs don't
-  # appear undetected, we run this test with and without do_priming.
-  if (do_priming) {
-    expect_identical(isolate(dr()), 0)
-    expect_identical(isolate(tr()), 0)
-  }
-
-  # Pump timer and reactives for about 1.4 seconds
-  stopAt <- Sys.time() + 1.4
-  while (Sys.time() < stopAt) {
-    timerCallbacks$executeElapsed()
-    flushReact()
-    Sys.sleep(0.001)
-  }
-
-  # dr() should not have had time to fire, other than the initial run, since
-  # there haven't been long enough gaps between invalidations.
-  expect_identical(dr_fired, 1)
-  # The value of dr() should not have updated either.
-  expect_identical(isolate(dr()), 0)
-
-  # tr() however, has had time to fire multiple times and update its value.
-  expect_identical(tr_fired, 3)
-  expect_identical(isolate(tr()), 10)
-
-  # Now let some time pass without any more updates.
-  src$destroy() # No more updates
-  stopAt <- Sys.time() + 1
-  while (Sys.time() < stopAt) {
-    timerCallbacks$executeElapsed()
-    flushReact()
-    Sys.sleep(0.001)
-  }
-
-  # dr should've fired, and we should have converged on the right answer.
-  expect_identical(dr_fired, 2)
-  isolate(expect_identical(rv$a, dr()))
-  expect_identical(tr_fired, 4)
-  isolate(expect_identical(rv$a, tr()))
-}
-
-test_that("debounce/throttle work properly (with priming)", {
-  run_debounce_throttle(TRUE)
-})
-test_that("debounce/throttle work properly (without priming)", {
-  run_debounce_throttle(FALSE)
-})

inst/tests/test-stacks.R

@@ -0,0 +1,77 @@
+context("stacks")
+
+causeError <- function(full) {
+  A <- function() {
+    stop("foo")
+  }
+
+  B <- function() {
+    A()
+  }
+
+  C <- reactive({
+    B()
+  })
+
+  res <- try(captureStackTraces(isolate(renderTable({C()}, server = FALSE)())),
+    silent = TRUE)
+  cond <- attr(res, "condition", exact = TRUE)
+
+  df <- extractStackTrace(conditionStackTrace(cond), full = full)
+  df$loc <- cleanLocs(df$loc)
+  # Compensate for this test being called from different call sites;
+  # whack the
+  df <- head(df, -sys.nframe())
+  df$num <- df$num - sys.nframe()
+  df
+}
+
+cleanLocs <- function(locs) {
+  locs[!grepl("test-stacks\\.R", locs, perl = TRUE)] <- ""
+  sub("^.*#", "", locs)
+}
+
+dumpTests <- function(df) {
+  print(bquote({
+    expect_equal(df$num, .(df$num))
+    expect_equal(df$call, .(df$call))
+    expect_equal(nzchar(df$loc), .(nzchar(df$loc)))
+  }))
+}
+
+test_that("integration tests", {
+  df <- causeError(full = FALSE)
+  # dumpTests(df)
+
+  expect_equal(df$num, c(31L, 30L, 29L, 18L, 17L, 16L, 15L,
+    8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L))
+  expect_equal(df$call, c("A", "B", "reactive C", "C", "renderTable",
+    "func", "renderTable({     C() }, server = FALSE)", "isolate",
+    "withCallingHandlers", "captureStackTraces", "doTryCatch",
+    "tryCatchOne", "tryCatchList", "tryCatch", "try"))
+  expect_equal(nzchar(df$loc), c(TRUE, TRUE, TRUE, FALSE, TRUE,
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
+    FALSE))
+
+  df <- causeError(full = TRUE)
+  # dumpTests(df)
+
+  expect_equal(df$num, c(34L, 33L, 32L, 31L, 30L, 29L, 28L,
+    27L, 26L, 25L, 24L, 23L, 22L, 21L, 20L, 19L, 18L, 17L, 16L,
+    15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L,
+    2L, 1L))
+  expect_equal(df$call, c("h", ".handleSimpleError", "stop",
+    "A", "B", "reactive C", "..stacktraceon..", ".func", "withVisible",
+    "withCallingHandlers", "contextFunc", "env$runWith", "withReactiveDomain",
+    "ctx$run", "self$.updateValue", "..stacktraceoff..", "C",
+    "renderTable", "func", "renderTable({     C() }, server = FALSE)",
+    "..stacktraceon..", "contextFunc", "env$runWith", "withReactiveDomain",
+    "ctx$run", "..stacktraceoff..", "isolate", "withCallingHandlers",
+    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList",
+    "tryCatch", "try"))
+  expect_equal(nzchar(df$loc), c(FALSE, FALSE, FALSE, TRUE,
+    TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
+    FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE,
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
+    FALSE, FALSE, FALSE))
+})

inst/tests/test-staticdocs.R

@@ -1,38 +1,23 @@
 context("staticdocs")
 
 test_that("All man pages have an entry in staticdocs/index.r", {
-  if (all(file.exists(c('../../inst/staticdocs', '../../man')))) {
-    # We're running tests on a source tree
-    mode <- "source"
-  } else if (all(file.exists(c('../../shiny/staticdocs', '../../shiny/html')))) {
-    # We're testing an installed package, possibly for R CMD check
-    mode <- "bundle"
-  } else {
-    cat("Unknown testing environment for test-staticdocs.R.\n", file = stderr())
+  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", "stacktrace", "knitr_methods", "knitr_methods_htmltools")
 
-  # Read in topics from a staticdocs/index.r file
-  get_indexed_topics <- function(index_path) {
+  indexed_topics <- local({
     result <- character(0)
     sd_section <- function(dummy1, dummy2, section_topics) {
       result <<- c(result, section_topics)
     }
-    source(index_path, local = TRUE)
+    source("../../inst/staticdocs/index.r", local = TRUE)
     result
-  }
+  })
 
-  if (mode == "source") {
-    indexed_topics <- get_indexed_topics("../../inst/staticdocs/index.r")
-    all_topics <- sub("\\.Rd", "", list.files("../../man", pattern = "*.Rd"))
-
-  } else if (mode == "bundle") {
-    indexed_topics <- get_indexed_topics("../../shiny/staticdocs/index.r")
-    all_topics <- unique(unname(readRDS("../../shiny/help/aliases.rds")))
-  }
+  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

inst/tests/test-url.R

@@ -18,8 +18,6 @@ test_that("Query string parsing", {
   # Should be the same with or without leading question mark
   expect_identical(parseQueryString("?foo=1&bar=b"), parseQueryString("foo=1&bar=b"))
 
-  # Leading/trailing/consecutive ampersands are ignored
-  expect_identical(parseQueryString("?&a=1&&b=2&"), parseQueryString("?a=1&b=2"))
 
   # Nested and non-nested query strings
   expect_identical(