Add tests for glyphicon

* Add FontAwesome upgrade information to NEWS.md

* Update NEWS.md

* Update NEWS.md

.Rbuildignore

@@ -1,3 +1,4 @@
+^data-raw$
 ^\.Rproj\.user$
 ^\.git$
 ^examples$
@@ -6,10 +7,17 @@
 ^shiny\.cmd$
 ^run\.R$
 ^\.gitignore$
+^smoketests$
 ^res$
 ^man-roxygen$
 ^\.travis\.yml$
 ^staticdocs$
 ^tools$
+^srcjs$
 ^CONTRIBUTING.md$
 ^cran-comments.md$
+^.*\.o$
+^appveyor\.yml$
+^revdep$
+^TODO-promises.md$
+^manualtests$

.gitattributes

@@ -1 +1,4 @@
 /NEWS merge=union
+/inst/www/shared/shiny.js -merge -diff
+*.min.js -merge -diff
+*.js.map -merge -diff

.gitignore

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

.travis.yml

@@ -1,27 +1,12 @@
-# it is not really python, but there is no R support on Travis CI yet
-language: python
+language: r
+r:
+  - oldrel
+  - release
+  - devel
+sudo: false
+cache: packages
 
-# environment variables
-env:
-  - R_LIBS_USER=~/R R_MY_PKG="$(basename $TRAVIS_REPO_SLUG)"
-
-# install dependencies
-install:
-  - sudo apt-add-repository -y "deb http://cran.rstudio.com/bin/linux/ubuntu `lsb_release -cs`/"
-  - sudo apt-key adv --keyserver keyserver.ubuntu.com --recv-keys E084DAB9
-  - sudo apt-add-repository -y ppa:marutter/c2d4u
-  - sudo apt-get -qq update
-  - sudo apt-get -qq install r-base r-cran-shiny r-cran-cairo r-cran-devtools r-cran-knitr
-  - "[ ! -d ~/R ] && mkdir ~/R"
-  - echo "options(repos = c(CRAN = 'http://cran.rstudio.com'))" > ~/.Rprofile
-  - Rscript -e "update.packages(instlib = '~/R', ask = FALSE, quiet = TRUE)"
-  - Rscript -e "devtools::install_deps(dep = TRUE)"
-
-# run tests
-script:
-  - cd ..; rm -f *.tar.gz; R CMD build $R_MY_PKG
-  - R CMD check $R_MY_PKG*.tar.gz --no-manual
-
-after_failure:
-  - cat $R_MY_PKG.Rcheck/00install.out || true
-  - cat $R_MY_PKG.Rcheck/00check.log || true
+notifications:
+  email:
+    on_success: change
+    on_failure: change

CONTRIBUTING.md

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

DESCRIPTION

@@ -1,17 +1,20 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.11
-Date: 2015-01-08
+Version: 1.2.0
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
+    person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
+    person("JJ", "Allaire", role = "aut", email = "jj@rstudio.com"),
+    person("Yihui", "Xie", role = "aut", email = "yihui@rstudio.com"),
+    person("Jonathan", "McPherson", role = "aut", email = "jonathan@rstudio.com"),
     person(family = "RStudio", role = "cph"),
     person(family = "jQuery Foundation", role = "cph",
     comment = "jQuery library and jQuery UI library"),
     person(family = "jQuery contributors", role = c("ctb", "cph"),
     comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
     person(family = "jQuery UI contributors", role = c("ctb", "cph"),
-    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/1.10.4/AUTHORS.txt"),
+    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
     person("Mark", "Otto", role = "ctb",
     comment = "Bootstrap library"),
     person("Jacob", "Thornton", role = "ctb",
@@ -38,6 +41,8 @@ Authors@R: c(
     comment = "es5-shim library"),
     person("Denis", "Ineshin", role = c("ctb", "cph"),
     comment = "ion.rangeSlider library"),
+    person("Sami", "Samhuri", role = c("ctb", "cph"),
+    comment = "Javascript strftime library"),
     person(family = "SpryMedia Limited", role = c("ctb", "cph"),
     comment = "DataTables library"),
     person("John", "Fraser", role = c("ctb", "cph"),
@@ -49,61 +54,109 @@ Authors@R: c(
     person(family = "R Core Team", role = c("ctb", "cph"),
     comment = "tar implementation from R")
     )
-Description: Shiny makes it incredibly easy to build interactive web
+Description: Makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
-    outputs and extensive pre-built widgets make it possible to build
+    outputs and extensive prebuilt widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
 License: GPL-3 | file LICENSE
 Depends:
-    R (>= 3.0.0)
+    R (>= 3.0.2),
+    methods
 Imports:
-    tools,
     utils,
-    httpuv (>= 1.3.2),
-    mime (>= 0.1.3),
-    RJSONIO,
+    grDevices,
+    httpuv (>= 1.4.4),
+    mime (>= 0.3),
+    jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.2.6),
-    R6 (>= 2.0)
+    htmltools (>= 0.3.5),
+    R6 (>= 2.0),
+    sourcetools,
+    later (>= 0.7.2),
+    promises (>= 1.0.1),
+    tools,
+    crayon,
+    rlang
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
     testthat,
     knitr (>= 1.6),
-    markdown
+    markdown,
+    rmarkdown,
+    ggplot2,
+    magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     'app.R'
+    'bookmark-state-local.R'
+    'stack.R'
+    'bookmark-state.R'
     'bootstrap-layout.R'
-    'map.R'
     'globals.R'
+    'conditions.R'
+    'map.R'
     'utils.R'
     'bootstrap.R'
-    'cache.R'
+    'cache-context.R'
+    'cache-disk.R'
+    'cache-memory.R'
+    'cache-utils.R'
+    'diagnose.R'
     'fileupload.R'
-    'stack.R'
     'graph.R'
+    'reactives.R'
+    'reactive-domains.R'
+    'history.R'
     'hooks.R'
     'html-deps.R'
     'htmltools.R'
+    'image-interact-opts.R'
+    'image-interact.R'
     'imageutils.R'
+    'input-action.R'
+    'input-checkbox.R'
+    'input-checkboxgroup.R'
+    'input-date.R'
+    'input-daterange.R'
+    'input-file.R'
+    'input-numeric.R'
+    'input-password.R'
+    'input-radiobuttons.R'
+    'input-select.R'
+    'input-slider.R'
+    'input-submit.R'
+    'input-text.R'
+    'input-textarea.R'
+    'input-utils.R'
+    'insert-tab.R'
+    'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
     'middleware.R'
+    'modal.R'
+    'modules.R'
+    'notifications.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
-    'reactive-domains.R'
-    'reactives.R'
+    'render-cached-plot.R'
+    'render-plot.R'
+    'render-table.R'
     'run-url.R'
+    'serializers.R'
+    'server-input-handlers.R'
     'server.R'
+    'shiny-options.R'
     'shiny.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
-    'slider.R'
+    'snapshot.R'
     'tar.R'
+    'test-export.R'
     'timer.R'
     'update-input.R'
+RoxygenNote: 6.1.0

LICENSE

@@ -1,7 +1,7 @@
 The shiny package as a whole is distributed under GPL-3 (GNU GENERAL PUBLIC
 LICENSE version 3).
 
-The shiny package inludes other open source software components. The following
+The shiny package includes other open source software components. The following
 is a list of these components (full copies of the license agreements used by
 these components are included below):
 
@@ -12,9 +12,10 @@ these components are included below):
 - Respond.js, https://github.com/scottjehl/Respond
 - bootstrap-datepicker, https://github.com/eternicode/bootstrap-datepicker
 - Font Awesome, https://github.com/FortAwesome/Font-Awesome
-- selectize.js, https://github.com/brianreavis/selectize.js
+- selectize.js, https://github.com/selectize/selectize.js
 - es5-shim, https://github.com/es-shims/es5-shim
 - ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
+- strftime for Javascript, https://github.com/samsonjs/strftime
 - DataTables, https://github.com/DataTables/DataTables
 - showdown.js, https://github.com/showdownjs/showdown
 - highlight.js, https://github.com/isagalaev/highlight.js
@@ -672,7 +673,7 @@ bootstrap-datepicker
    limitations under the License.
 
 
-Font-Awesome (CSS file is MIT licensed; font has SIL Open Font License 1.1)
+Font Awesome (CSS files are MIT licensed; fonts have SIL Open Font License 1.1, svgs have CC BY 4.0 License)
 ----------------------------------------------------------------------
 
 The MIT License (MIT)
@@ -794,6 +795,326 @@ DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
 FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
 OTHER DEALINGS IN THE FONT SOFTWARE.
 
+=======================================================================
+
+Creative Commons Attribution 4.0 International Public License
+
+By exercising the Licensed Rights (defined below), You accept and agree
+to be bound by the terms and conditions of this Creative Commons
+Attribution 4.0 International Public License ("Public License"). To the
+extent this Public License may be interpreted as a contract, You are
+granted the Licensed Rights in consideration of Your acceptance of
+these terms and conditions, and the Licensor grants You such rights in
+consideration of benefits the Licensor receives from making the
+Licensed Material available under these terms and conditions.
+
+
+Section 1 -- Definitions.
+
+  a. Adapted Material means material subject to Copyright and Similar
+     Rights that is derived from or based upon the Licensed Material
+     and in which the Licensed Material is translated, altered,
+     arranged, transformed, or otherwise modified in a manner requiring
+     permission under the Copyright and Similar Rights held by the
+     Licensor. For purposes of this Public License, where the Licensed
+     Material is a musical work, performance, or sound recording,
+     Adapted Material is always produced where the Licensed Material is
+     synched in timed relation with a moving image.
+
+  b. Adapter's License means the license You apply to Your Copyright
+     and Similar Rights in Your contributions to Adapted Material in
+     accordance with the terms and conditions of this Public License.
+
+  c. Copyright and Similar Rights means copyright and/or similar rights
+     closely related to copyright including, without limitation,
+     performance, broadcast, sound recording, and Sui Generis Database
+     Rights, without regard to how the rights are labeled or
+     categorized. For purposes of this Public License, the rights
+     specified in Section 2(b)(1)-(2) are not Copyright and Similar
+     Rights.
+
+  d. Effective Technological Measures means those measures that, in the
+     absence of proper authority, may not be circumvented under laws
+     fulfilling obligations under Article 11 of the WIPO Copyright
+     Treaty adopted on December 20, 1996, and/or similar international
+     agreements.
+
+  e. Exceptions and Limitations means fair use, fair dealing, and/or
+     any other exception or limitation to Copyright and Similar Rights
+     that applies to Your use of the Licensed Material.
+
+  f. Licensed Material means the artistic or literary work, database,
+     or other material to which the Licensor applied this Public
+     License.
+
+  g. Licensed Rights means the rights granted to You subject to the
+     terms and conditions of this Public License, which are limited to
+     all Copyright and Similar Rights that apply to Your use of the
+     Licensed Material and that the Licensor has authority to license.
+
+  h. Licensor means the individual(s) or entity(ies) granting rights
+     under this Public License.
+
+  i. Share means to provide material to the public by any means or
+     process that requires permission under the Licensed Rights, such
+     as reproduction, public display, public performance, distribution,
+     dissemination, communication, or importation, and to make material
+     available to the public including in ways that members of the
+     public may access the material from a place and at a time
+     individually chosen by them.
+
+  j. Sui Generis Database Rights means rights other than copyright
+     resulting from Directive 96/9/EC of the European Parliament and of
+     the Council of 11 March 1996 on the legal protection of databases,
+     as amended and/or succeeded, as well as other essentially
+     equivalent rights anywhere in the world.
+
+  k. You means the individual or entity exercising the Licensed Rights
+     under this Public License. Your has a corresponding meaning.
+
+
+Section 2 -- Scope.
+
+  a. License grant.
+
+       1. Subject to the terms and conditions of this Public License,
+          the Licensor hereby grants You a worldwide, royalty-free,
+          non-sublicensable, non-exclusive, irrevocable license to
+          exercise the Licensed Rights in the Licensed Material to:
+
+            a. reproduce and Share the Licensed Material, in whole or
+               in part; and
+
+            b. produce, reproduce, and Share Adapted Material.
+
+       2. Exceptions and Limitations. For the avoidance of doubt, where
+          Exceptions and Limitations apply to Your use, this Public
+          License does not apply, and You do not need to comply with
+          its terms and conditions.
+
+       3. Term. The term of this Public License is specified in Section
+          6(a).
+
+       4. Media and formats; technical modifications allowed. The
+          Licensor authorizes You to exercise the Licensed Rights in
+          all media and formats whether now known or hereafter created,
+          and to make technical modifications necessary to do so. The
+          Licensor waives and/or agrees not to assert any right or
+          authority to forbid You from making technical modifications
+          necessary to exercise the Licensed Rights, including
+          technical modifications necessary to circumvent Effective
+          Technological Measures. For purposes of this Public License,
+          simply making modifications authorized by this Section 2(a)
+          (4) never produces Adapted Material.
+
+       5. Downstream recipients.
+
+            a. Offer from the Licensor -- Licensed Material. Every
+               recipient of the Licensed Material automatically
+               receives an offer from the Licensor to exercise the
+               Licensed Rights under the terms and conditions of this
+               Public License.
+
+            b. No downstream restrictions. You may not offer or impose
+               any additional or different terms or conditions on, or
+               apply any Effective Technological Measures to, the
+               Licensed Material if doing so restricts exercise of the
+               Licensed Rights by any recipient of the Licensed
+               Material.
+
+       6. No endorsement. Nothing in this Public License constitutes or
+          may be construed as permission to assert or imply that You
+          are, or that Your use of the Licensed Material is, connected
+          with, or sponsored, endorsed, or granted official status by,
+          the Licensor or others designated to receive attribution as
+          provided in Section 3(a)(1)(A)(i).
+
+  b. Other rights.
+
+       1. Moral rights, such as the right of integrity, are not
+          licensed under this Public License, nor are publicity,
+          privacy, and/or other similar personality rights; however, to
+          the extent possible, the Licensor waives and/or agrees not to
+          assert any such rights held by the Licensor to the limited
+          extent necessary to allow You to exercise the Licensed
+          Rights, but not otherwise.
+
+       2. Patent and trademark rights are not licensed under this
+          Public License.
+
+       3. To the extent possible, the Licensor waives any right to
+          collect royalties from You for the exercise of the Licensed
+          Rights, whether directly or through a collecting society
+          under any voluntary or waivable statutory or compulsory
+          licensing scheme. In all other cases the Licensor expressly
+          reserves any right to collect such royalties.
+
+
+Section 3 -- License Conditions.
+
+Your exercise of the Licensed Rights is expressly made subject to the
+following conditions.
+
+  a. Attribution.
+
+       1. If You Share the Licensed Material (including in modified
+          form), You must:
+
+            a. retain the following if it is supplied by the Licensor
+               with the Licensed Material:
+
+                 i. identification of the creator(s) of the Licensed
+                    Material and any others designated to receive
+                    attribution, in any reasonable manner requested by
+                    the Licensor (including by pseudonym if
+                    designated);
+
+                ii. a copyright notice;
+
+               iii. a notice that refers to this Public License;
+
+                iv. a notice that refers to the disclaimer of
+                    warranties;
+
+                 v. a URI or hyperlink to the Licensed Material to the
+                    extent reasonably practicable;
+
+            b. indicate if You modified the Licensed Material and
+               retain an indication of any previous modifications; and
+
+            c. indicate the Licensed Material is licensed under this
+               Public License, and include the text of, or the URI or
+               hyperlink to, this Public License.
+
+       2. You may satisfy the conditions in Section 3(a)(1) in any
+          reasonable manner based on the medium, means, and context in
+          which You Share the Licensed Material. For example, it may be
+          reasonable to satisfy the conditions by providing a URI or
+          hyperlink to a resource that includes the required
+          information.
+
+       3. If requested by the Licensor, You must remove any of the
+          information required by Section 3(a)(1)(A) to the extent
+          reasonably practicable.
+
+       4. If You Share Adapted Material You produce, the Adapter's
+          License You apply must not prevent recipients of the Adapted
+          Material from complying with this Public License.
+
+
+Section 4 -- Sui Generis Database Rights.
+
+Where the Licensed Rights include Sui Generis Database Rights that
+apply to Your use of the Licensed Material:
+
+  a. for the avoidance of doubt, Section 2(a)(1) grants You the right
+     to extract, reuse, reproduce, and Share all or a substantial
+     portion of the contents of the database;
+
+  b. if You include all or a substantial portion of the database
+     contents in a database in which You have Sui Generis Database
+     Rights, then the database in which You have Sui Generis Database
+     Rights (but not its individual contents) is Adapted Material; and
+
+  c. You must comply with the conditions in Section 3(a) if You Share
+     all or a substantial portion of the contents of the database.
+
+For the avoidance of doubt, this Section 4 supplements and does not
+replace Your obligations under this Public License where the Licensed
+Rights include other Copyright and Similar Rights.
+
+
+Section 5 -- Disclaimer of Warranties and Limitation of Liability.
+
+  a. UNLESS OTHERWISE SEPARATELY UNDERTAKEN BY THE LICENSOR, TO THE
+     EXTENT POSSIBLE, THE LICENSOR OFFERS THE LICENSED MATERIAL AS-IS
+     AND AS-AVAILABLE, AND MAKES NO REPRESENTATIONS OR WARRANTIES OF
+     ANY KIND CONCERNING THE LICENSED MATERIAL, WHETHER EXPRESS,
+     IMPLIED, STATUTORY, OR OTHER. THIS INCLUDES, WITHOUT LIMITATION,
+     WARRANTIES OF TITLE, MERCHANTABILITY, FITNESS FOR A PARTICULAR
+     PURPOSE, NON-INFRINGEMENT, ABSENCE OF LATENT OR OTHER DEFECTS,
+     ACCURACY, OR THE PRESENCE OR ABSENCE OF ERRORS, WHETHER OR NOT
+     KNOWN OR DISCOVERABLE. WHERE DISCLAIMERS OF WARRANTIES ARE NOT
+     ALLOWED IN FULL OR IN PART, THIS DISCLAIMER MAY NOT APPLY TO YOU.
+
+  b. TO THE EXTENT POSSIBLE, IN NO EVENT WILL THE LICENSOR BE LIABLE
+     TO YOU ON ANY LEGAL THEORY (INCLUDING, WITHOUT LIMITATION,
+     NEGLIGENCE) OR OTHERWISE FOR ANY DIRECT, SPECIAL, INDIRECT,
+     INCIDENTAL, CONSEQUENTIAL, PUNITIVE, EXEMPLARY, OR OTHER LOSSES,
+     COSTS, EXPENSES, OR DAMAGES ARISING OUT OF THIS PUBLIC LICENSE OR
+     USE OF THE LICENSED MATERIAL, EVEN IF THE LICENSOR HAS BEEN
+     ADVISED OF THE POSSIBILITY OF SUCH LOSSES, COSTS, EXPENSES, OR
+     DAMAGES. WHERE A LIMITATION OF LIABILITY IS NOT ALLOWED IN FULL OR
+     IN PART, THIS LIMITATION MAY NOT APPLY TO YOU.
+
+  c. The disclaimer of warranties and limitation of liability provided
+     above shall be interpreted in a manner that, to the extent
+     possible, most closely approximates an absolute disclaimer and
+     waiver of all liability.
+
+
+Section 6 -- Term and Termination.
+
+  a. This Public License applies for the term of the Copyright and
+     Similar Rights licensed here. However, if You fail to comply with
+     this Public License, then Your rights under this Public License
+     terminate automatically.
+
+  b. Where Your right to use the Licensed Material has terminated under
+     Section 6(a), it reinstates:
+
+       1. automatically as of the date the violation is cured, provided
+          it is cured within 30 days of Your discovery of the
+          violation; or
+
+       2. upon express reinstatement by the Licensor.
+
+     For the avoidance of doubt, this Section 6(b) does not affect any
+     right the Licensor may have to seek remedies for Your violations
+     of this Public License.
+
+  c. For the avoidance of doubt, the Licensor may also offer the
+     Licensed Material under separate terms or conditions or stop
+     distributing the Licensed Material at any time; however, doing so
+     will not terminate this Public License.
+
+  d. Sections 1, 5, 6, 7, and 8 survive termination of this Public
+     License.
+
+
+Section 7 -- Other Terms and Conditions.
+
+  a. The Licensor shall not be bound by any additional or different
+     terms or conditions communicated by You unless expressly agreed.
+
+  b. Any arrangements, understandings, or agreements regarding the
+     Licensed Material not stated herein are separate from and
+     independent of the terms and conditions of this Public License.
+
+
+Section 8 -- Interpretation.
+
+  a. For the avoidance of doubt, this Public License does not, and
+     shall not be interpreted to, reduce, limit, restrict, or impose
+     conditions on any use of the Licensed Material that could lawfully
+     be made without permission under this Public License.
+
+  b. To the extent possible, if any provision of this Public License is
+     deemed unenforceable, it shall be automatically reformed to the
+     minimum extent necessary to make it enforceable. If the provision
+     cannot be reformed, it shall be severed from this Public License
+     without affecting the enforceability of the remaining terms and
+     conditions.
+
+  c. No term or condition of this Public License will be waived and no
+     failure to comply consented to unless expressly agreed to by the
+     Licensor.
+
+  d. Nothing in this Public License constitutes or may be interpreted
+     as a limitation upon, or waiver of, any privileges and immunities
+     that apply to the Licensor or You, including from the legal
+     processes of any jurisdiction or authority.
+
 
 selectize.js
 ----------------------------------------------------------------------
@@ -1051,6 +1372,31 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 SOFTWARE.
 
 
+strftime for Javascript License
+----------------------------------------------------------------------
+
+The MIT License (MIT)
+Copyright © 2015 Sami Samhuri, http://samhuri.net <sami@samhuri.net>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the “Software”), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+
 DataTables License
 ----------------------------------------------------------------------
 

NAMESPACE

@@ -1,14 +1,17 @@
-# Generated by roxygen2 (4.1.0): do not edit by hand
+# Generated by roxygen2: do not edit by hand
 
 S3method("$",reactivevalues)
+S3method("$",session_proxy)
 S3method("$",shinyoutput)
 S3method("$<-",reactivevalues)
+S3method("$<-",session_proxy)
 S3method("$<-",shinyoutput)
 S3method("[",reactivevalues)
 S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
 S3method("[<-",shinyoutput)
 S3method("[[",reactivevalues)
+S3method("[[",session_proxy)
 S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
 S3method("[[<-",shinyoutput)
@@ -19,11 +22,18 @@ S3method(as.shiny.appobj,list)
 S3method(as.shiny.appobj,shiny.appobj)
 S3method(as.tags,shiny.appobj)
 S3method(as.tags,shiny.render.function)
+S3method(format,reactiveExpr)
+S3method(format,reactiveVal)
 S3method(names,reactivevalues)
+S3method(print,key_missing)
 S3method(print,reactive)
 S3method(print,shiny.appobj)
 S3method(str,reactivevalues)
+export("conditionStackTrace<-")
+export(..stacktraceoff..)
+export(..stacktraceon..)
 export(HTML)
+export(NS)
 export(Progress)
 export(a)
 export(absolutePanel)
@@ -31,34 +41,62 @@ export(actionButton)
 export(actionLink)
 export(addResourcePath)
 export(animationOptions)
+export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
+export(bookmarkButton)
+export(bootstrapLib)
 export(bootstrapPage)
 export(br)
+export(browserViewer)
+export(brushOpts)
+export(brushedPoints)
+export(callModule)
+export(captureStackTraces)
 export(checkboxGroupInput)
 export(checkboxInput)
+export(clickOpts)
 export(code)
 export(column)
+export(conditionStackTrace)
 export(conditionalPanel)
+export(createRenderFunction)
 export(createWebDependency)
 export(dataTableOutput)
 export(dateInput)
 export(dateRangeInput)
+export(dblclickOpts)
+export(debounce)
+export(dialogViewer)
+export(diskCache)
 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)
 export(flowLayout)
 export(fluidPage)
 export(fluidRow)
+export(formatStackTrace)
+export(freezeReactiveVal)
+export(freezeReactiveValue)
+export(getCurrentOutputInfo)
 export(getDefaultReactiveDomain)
+export(getQueryString)
+export(getShinyOption)
+export(getUrlHash)
 export(h1)
 export(h2)
 export(h3)
@@ -67,8 +105,11 @@ export(h5)
 export(h6)
 export(headerPanel)
 export(helpText)
+export(hideTab)
+export(hoverOpts)
 export(hr)
 export(htmlOutput)
+export(htmlTemplate)
 export(icon)
 export(imageOutput)
 export(img)
@@ -79,14 +120,21 @@ export(includeMarkdown)
 export(includeScript)
 export(includeText)
 export(inputPanel)
+export(insertTab)
+export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
+export(is.key_missing)
 export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
 export(is.singleton)
+export(isRunning)
+export(isTruthy)
 export(isolate)
+export(key_missing)
 export(knit_print.html)
+export(knit_print.reactive)
 export(knit_print.shiny.appobj)
 export(knit_print.shiny.render.function)
 export(knit_print.shiny.tag)
@@ -95,22 +143,39 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
+export(memoryCache)
+export(modalButton)
+export(modalDialog)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
+export(nearPoints)
 export(need)
+export(ns.sep)
 export(numericInput)
 export(observe)
 export(observeEvent)
+export(onBookmark)
+export(onBookmarked)
+export(onFlush)
+export(onFlushed)
 export(onReactiveDomainEnded)
+export(onRestore)
+export(onRestored)
+export(onSessionEnded)
+export(onStop)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
+export(paneViewer)
 export(parseQueryString)
 export(passwordInput)
 export(plotOutput)
 export(plotPNG)
 export(pre)
+export(prependTab)
+export(printError)
+export(printStackTrace)
 export(radioButtons)
 export(reactive)
 export(reactiveFileReader)
@@ -121,10 +186,16 @@ export(reactiveTable)
 export(reactiveText)
 export(reactiveTimer)
 export(reactiveUI)
+export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
 export(registerInputHandler)
 export(removeInputHandler)
+export(removeModal)
+export(removeNotification)
+export(removeTab)
+export(removeUI)
+export(renderCachedPlot)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -133,29 +204,46 @@ export(renderTable)
 export(renderText)
 export(renderUI)
 export(repeatable)
+export(req)
+export(restoreInput)
 export(runApp)
 export(runExample)
+export(runGadget)
 export(runGist)
 export(runGitHub)
 export(runUrl)
+export(safeError)
 export(selectInput)
 export(selectizeInput)
 export(serverInfo)
+export(setBookmarkExclude)
 export(setProgress)
+export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
+export(shinyAppFile)
+export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
+export(showBookmarkUrlModal)
+export(showModal)
+export(showNotification)
 export(showReactLog)
+export(showTab)
 export(sidebarLayout)
 export(sidebarPanel)
 export(singleton)
+export(sizeGrowthRatio)
 export(sliderInput)
+export(snapshotExclude)
+export(snapshotPreprocessInput)
+export(snapshotPreprocessOutput)
 export(span)
 export(splitLayout)
 export(stopApp)
 export(strong)
 export(submitButton)
+export(suppressDependencies)
 export(tabPanel)
 export(tableOutput)
 export(tabsetPanel)
@@ -166,26 +254,39 @@ 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)
 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(updateVarSelectInput)
+export(updateVarSelectizeInput)
+export(urlModal)
 export(validate)
 export(validateCssUnit)
+export(varSelectInput)
+export(varSelectizeInput)
 export(verbatimTextOutput)
 export(verticalLayout)
 export(wellPanel)
+export(withLogErrors)
 export(withMathJax)
 export(withProgress)
 export(withReactiveDomain)
@@ -194,6 +295,8 @@ import(R6)
 import(digest)
 import(htmltools)
 import(httpuv)
+import(methods)
 import(mime)
 import(xtable)
-importFrom(RJSONIO,fromJSON)
+importFrom(grDevices,dev.cur)
+importFrom(grDevices,dev.set)

NEWS

@@ -1,730 +0,0 @@
-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,48 +20,58 @@
 #' @param onStart A function that will be called before the app is actually run.
 #'   This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
 #'   case, a \code{global.R} file can be used for this purpose.
-#' @param options Named options that should be passed to the `runApp` call. You
-#'   can also specify \code{width} and \code{height} parameters which provide a
-#'   hint to the embedding environment about the ideal height/width for the app.
+#' @param options Named options that should be passed to the \code{runApp} call
+#'   (these can be any of the following: "port", "launch.browser", "host", "quiet",
+#'   "display.mode" and "test.mode"). You can also specify \code{width} and
+#'   \code{height} parameters which provide a hint to the embedding environment
+#'   about the ideal height/width for the app.
 #' @param uiPattern A regular expression that will be applied to each \code{GET}
 #'   request to determine whether the \code{ui} should be used to handle the
 #'   request. Note that the entire request path must match the regular
 #'   expression in order for the match to be considered successful.
+#' @param enableBookmarking Can be one of \code{"url"}, \code{"server"}, or
+#'   \code{"disable"}. This is equivalent to calling the
+#'   \code{\link{enableBookmarking}()} function just before calling
+#'   \code{shinyApp()}. With the default value (\code{NULL}), the app will
+#'   respect the setting from any previous calls to \code{enableBookmarking()}.
+#'   See \code{\link{enableBookmarking}} for more information.
 #' @return An object that represents the app. Printing the object or passing it
 #'   to \code{\link{runApp}} will run the app.
 #'
 #' @examples
-#' \donttest{
-#' shinyApp(
-#'   ui = fluidPage(
-#'     numericInput("n", "n", 1),
-#'     plotOutput("plot")
-#'   ),
-#'   server = function(input, output) {
-#'     output$plot <- renderPlot( plot(head(cars, input$n)) )
-#'   }
-#' )
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   options(device.ask.default = FALSE)
 #'
-#' shinyAppDir(system.file("examples/01_hello", package="shiny"))
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       numericInput("n", "n", 1),
+#'       plotOutput("plot")
+#'     ),
+#'     server = function(input, output) {
+#'       output$plot <- renderPlot( plot(head(cars, input$n)) )
+#'     }
+#'   )
+#'
+#'   shinyAppDir(system.file("examples/01_hello", package="shiny"))
 #'
 #'
-#' # The object can be passed to runApp()
-#' app <- shinyApp(
-#'   ui = fluidPage(
-#'     numericInput("n", "n", 1),
-#'     plotOutput("plot")
-#'   ),
-#'   server = function(input, output) {
-#'     output$plot <- renderPlot( plot(head(cars, input$n)) )
-#'   }
-#' )
+#'   # The object can be passed to runApp()
+#'   app <- shinyApp(
+#'     ui = fluidPage(
+#'       numericInput("n", "n", 1),
+#'       plotOutput("plot")
+#'     ),
+#'     server = function(input, output) {
+#'       output$plot <- renderPlot( plot(head(cars, input$n)) )
+#'     }
+#'   )
 #'
-#' runApp(app)
+#'   runApp(app)
 #' }
-#'
 #' @export
 shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
-                     uiPattern="/") {
+                     uiPattern="/", enableBookmarking=NULL) {
   if (is.null(server)) {
     stop("`server` missing from shinyApp")
   }
@@ -75,12 +85,24 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
     server
   }
 
+  if (!is.null(enableBookmarking)) {
+    bookmarkStore <- match.arg(enableBookmarking, c("url", "server", "disable"))
+    enableBookmarking(bookmarkStore)
+  }
+
+  # Store the appDir and bookmarking-related options, so that we can read them
+  # from within the app.
+  shinyOptions(appDir = getwd())
+  appOptions <- consumeAppOptions()
+
   structure(
     list(
       httpHandler = httpHandler,
       serverFuncSource = serverFuncSource,
       onStart = onStart,
-      options = options),
+      options = options,
+      appOptions = appOptions
+    ),
     class = "shiny.appobj"
   )
 }
@@ -90,7 +112,7 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
 #'   file and either ui.R or www/index.html)
 #' @export
 shinyAppDir <- function(appDir, options=list()) {
-  if (!file_test('-d', appDir)) {
+  if (!utils::file_test('-d', appDir)) {
     stop("No Shiny application exists at the path \"", appDir, "\"")
   }
 
@@ -101,12 +123,22 @@ shinyAppDir <- function(appDir, options=list()) {
   if (file.exists.ci(appDir, "server.R")) {
     shinyAppDir_serverR(appDir, options = options)
   } else if (file.exists.ci(appDir, "app.R")) {
-    shinyAppDir_appR(appDir, options = options)
+    shinyAppDir_appR("app.R", appDir, options = options)
   } else {
     stop("App dir must contain either app.R or server.R.")
   }
 }
 
+#' @rdname shinyApp
+#' @param appFile Path to a .R file containing a Shiny application
+#' @export
+shinyAppFile <- function(appFile, options=list()) {
+  appFile <- normalizePath(appFile, mustWork = TRUE)
+  appDir <- dirname(appFile)
+
+  shinyAppDir_appR(basename(appFile), appDir, options = options)
+}
+
 # This reads in an app dir in the case that there's a server.R (and ui.R/www)
 # present, and returns a shiny.appobj.
 shinyAppDir_serverR <- function(appDir, options=list()) {
@@ -123,7 +155,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
         # If not, then take the last expression that's returned from ui.R.
         .globals$ui <- NULL
         on.exit(.globals$ui <- NULL, add = FALSE)
-        ui <- sourceUTF8(uiR, local = new.env(parent = globalenv()))$value
+        ui <- sourceUTF8(uiR, envir = new.env(parent = globalenv()))
         if (!is.null(.globals$ui)) {
           ui <- .globals$ui[[1]]
         }
@@ -146,7 +178,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       # server.R.
       .globals$server <- NULL
       on.exit(.globals$server <- NULL, add = TRUE)
-      result <- sourceUTF8(serverR, local = new.env(parent = globalenv()))$value
+      result <- sourceUTF8(serverR, envir = new.env(parent = globalenv()))
       if (!is.null(.globals$server)) {
         result <- .globals$server[[1]]
       }
@@ -169,15 +201,21 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     }
   }
 
+  shinyOptions(appDir = appDir)
+
   oldwd <- NULL
+  monitorHandle <- NULL
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
+    monitorHandle <<- initAutoReloadMonitor(appDir)
     if (file.exists(file.path.ci(appDir, "global.R")))
       sourceUTF8(file.path.ci(appDir, "global.R"))
   }
-  onEnd <- function() {
+  onStop <- function() {
     setwd(oldwd)
+    monitorHandle()
+    monitorHandle <<- NULL
   }
 
   structure(
@@ -185,27 +223,77 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = serverFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
-      options = options),
+      onStop = onStop,
+      options = options
+    ),
     class = "shiny.appobj"
   )
 }
 
-# This reads in an app dir in the case that there's a app.R present, and returns
-# a shiny.appobj.
-shinyAppDir_appR <- function(appDir, options=list()) {
-  fullpath <- file.path.ci(appDir, "app.R")
+# Start a reactive observer that continually monitors dir for changes to files
+# that have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. Case is
+# ignored when checking extensions. If any changes are detected, all connected
+# Shiny sessions are reloaded.
+#
+# Use options(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
+# for changes is expensive (we are polling for mtimes here, nothing fancy) this
+# feature is intended only for development.
+#
+# You can customize the file patterns Shiny will monitor by setting the
+# shiny.autoreload.pattern option. For example, to monitor only ui.R:
+# options(shiny.autoreload.pattern = glob2rx("ui.R"))
+#
+# The return value is a function that halts monitoring when called.
+initAutoReloadMonitor <- function(dir) {
+  if (!getOption("shiny.autoreload", FALSE)) {
+    return(function(){})
+  }
+
+  filePattern <- getOption("shiny.autoreload.pattern",
+    ".*\\.(r|html?|js|css|png|jpe?g|gif)$")
+
+  lastValue <- NULL
+  obs <- observe({
+    files <- sort(list.files(dir, pattern = filePattern, recursive = TRUE,
+      ignore.case = TRUE))
+    times <- file.info(files)$mtime
+    names(times) <- files
+
+    if (is.null(lastValue)) {
+      # First run
+      lastValue <<- times
+    } else if (!identical(lastValue, times)) {
+      # We've changed!
+      lastValue <<- times
+      for (session in appsByToken$values()) {
+        session$reload()
+      }
+    }
+
+    invalidateLater(getOption("shiny.autoreload.interval", 500))
+  })
+
+  obs$destroy
+}
+
+# This reads in an app dir for a single-file application (e.g. app.R), and
+# returns a shiny.appobj.
+shinyAppDir_appR <- function(fileName, appDir, options=list())
+{
+  fullpath <- file.path.ci(appDir, fileName)
 
   # This sources app.R and caches the content. When appObj() is called but
   # app.R hasn't changed, it won't re-source the file. But if called and
   # app.R has changed, it'll re-source the file and return the result.
-  appObj <- cachedFuncWithFile(appDir, "app.R", case.sensitive = FALSE,
+  appObj <- cachedFuncWithFile(appDir, fileName, case.sensitive = FALSE,
     function(appR) {
-      result <- sourceUTF8(fullpath, local = new.env(parent = globalenv()))$value
+      result <- sourceUTF8(fullpath, envir = new.env(parent = globalenv()))
 
       if (!is.shiny.appobj(result))
         stop("app.R did not return a shiny.appobj object.")
 
+      unconsumeAppOptions(result$appOptions)
+
       return(result)
     }
   )
@@ -224,12 +312,17 @@ shinyAppDir_appR <- function(appDir, options=list()) {
   fallbackWWWDir <- system.file("www-dir", package = "shiny")
 
   oldwd <- NULL
+  monitorHandle <- NULL
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
+    monitorHandle <<- initAutoReloadMonitor(appDir)
+    if (!is.null(appObj()$onStart)) appObj()$onStart()
   }
-  onEnd <- function() {
+  onStop <- function() {
     setwd(oldwd)
+    monitorHandle()
+    monitorHandle <<- NULL
   }
 
   structure(
@@ -237,7 +330,7 @@ shinyAppDir_appR <- function(appDir, options=list()) {
       httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = dynServerFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
+      onStop = onStop,
       options = options
     ),
     class = "shiny.appobj"
@@ -267,7 +360,10 @@ as.shiny.appobj.list <- function(x) {
 #' @rdname shinyApp
 #' @export
 as.shiny.appobj.character <- function(x) {
-  shinyAppDir(x)
+  if (identical(tolower(tools::file_ext(x)), "r"))
+    shinyAppFile(x)
+  else
+    shinyAppDir(x)
 }
 
 #' @rdname shinyApp
@@ -282,11 +378,13 @@ is.shiny.appobj <- function(x) {
 print.shiny.appobj <- function(x, ...) {
   opts <- x$options %OR% list()
   opts <- opts[names(opts) %in%
-      c("port", "launch.browser", "host", "quiet", "display.mode")]
+      c("port", "launch.browser", "host", "quiet",
+        "display.mode", "test.mode")]
 
-  args <- c(list(x), opts)
+  # Quote x and put runApp in quotes so that there's a nicer stack trace (#1851)
+  args <- c(list(quote(x)), opts)
 
-  do.call(runApp, args)
+  do.call("runApp", args)
 }
 
 #' @rdname shinyApp
@@ -301,7 +399,20 @@ as.tags.shiny.appobj <- function(x, ...) {
   height <- if (is.null(opts$height)) "400" else opts$height
 
   path <- addSubApp(x)
-  tags$iframe(src=path, width=width, height=height, class="shiny-frame")
+  deferredIFrame(path, width, height)
+}
+
+# Generate subapp iframes in such a way that they will not actually load right
+# away. Loading subapps immediately upon app load can result in a storm of
+# connections, all of which are contending for the few concurrent connections
+# that a browser will make to a specific origin. Instead, we load dummy iframes
+# and let the client load them when convenient. (See the initIframes function in
+# init_shiny.js.)
+deferredIFrame <- function(path, width, height) {
+  tags$iframe("data-deferred-src" = path,
+    width = width, height = height,
+    class = "shiny-frame shiny-frame-deferred"
+  )
 }
 
 #' Knitr S3 methods
@@ -352,8 +463,7 @@ knit_print.shiny.appobj <- function(x, ...) {
   }
   else {
     path <- addSubApp(x)
-    output <- tags$iframe(src=path, width=width, height=height,
-                          class="shiny-frame")
+    output <- deferredIFrame(path, width, height)
   }
 
   # If embedded Shiny apps ever have JS/CSS dependencies (like pym.js) we'll
@@ -377,3 +487,14 @@ knit_print.shiny.render.function <- function(x, ..., inline = FALSE) {
                                       shiny_rmd_warning())
   output
 }
+
+# Lets us drop reactive expressions directly into a knitr chunk and have the
+# value printed out! Nice for teaching if nothing else.
+#' @rdname knitr_methods
+#' @export
+knit_print.reactive <- function(x, ..., inline = FALSE) {
+  renderFunc <- if (inline) renderText else renderPrint
+  knitr::knit_print(renderFunc({
+    x()
+  }), inline = inline)
+}

R/bookmark-state-local.R

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

R/bootstrap-layout.R

@@ -31,7 +31,11 @@
 #' @seealso \code{\link{column}}, \code{\link{sidebarLayout}}
 #'
 #' @examples
-#' shinyUI(fluidPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # Example of UI with fluidPage
+#' ui <- fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -52,9 +56,21 @@
 #'       plotOutput("distPlot")
 #'     )
 #'   )
-#' ))
+#' )
 #'
-#' shinyUI(fluidPage(
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#'
+#'
+#' # UI demonstrating column layouts
+#' ui <- fluidPage(
 #'   title = "Hello Shiny!",
 #'   fluidRow(
 #'     column(width = 4,
@@ -64,8 +80,10 @@
 #'       "3 offset 2"
 #'     )
 #'   )
-#' ))
+#' )
 #'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @rdname fluidPage
 #' @export
 fluidPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
@@ -115,7 +133,10 @@ fluidRow <- function(...) {
 #' @seealso \code{\link{column}}
 #'
 #' @examples
-#' shinyUI(fixedPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fixedPage(
 #'   title = "Hello, Shiny!",
 #'   fixedRow(
 #'     column(width = 4,
@@ -125,7 +146,10 @@ fluidRow <- function(...) {
 #'       "3 offset 2"
 #'     )
 #'   )
-#' ))
+#' )
+#'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #'
 #' @rdname fixedPage
 #' @export
@@ -160,24 +184,43 @@ fixedRow <- function(...) {
 #' @seealso \code{\link{fluidRow}}, \code{\link{fixedRow}}.
 #'
 #' @examples
-#' fluidRow(
-#'   column(4,
-#'     sliderInput("obs", "Number of observations:",
-#'                 min = 1, max = 1000, value = 500)
-#'   ),
-#'   column(8,
-#'     plotOutput("distPlot")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   fluidRow(
+#'     column(4,
+#'       sliderInput("obs", "Number of observations:",
+#'                   min = 1, max = 1000, value = 500)
+#'     ),
+#'     column(8,
+#'       plotOutput("distPlot")
+#'     )
 #'   )
 #' )
 #'
-#' fluidRow(
-#'   column(width = 4,
-#'     "4"
-#'   ),
-#'   column(width = 3, offset = 2,
-#'     "3 offset 2"
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#'
+#'
+#' ui <- fluidPage(
+#'   fluidRow(
+#'     column(width = 4,
+#'       "4"
+#'     ),
+#'     column(width = 3, offset = 2,
+#'       "3 offset 2"
+#'     )
 #'   )
 #' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 column <- function(width, ..., offset = 0) {
 
@@ -202,8 +245,14 @@ column <- function(width, ..., offset = 0) {
 #'
 #'
 #' @examples
-#' titlePanel("Hello Shiny!")
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   titlePanel("Hello Shiny!")
+#' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 titlePanel <- function(title, windowTitle=title) {
   tagList(
@@ -226,8 +275,12 @@ titlePanel <- function(title, windowTitle=title) {
 #'   layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
 #' # Define UI
-#' shinyUI(fluidPage(
+#' ui <- fluidPage(
 #'
 #'   # Application title
 #'   titlePanel("Hello Shiny!"),
@@ -248,8 +301,18 @@ titlePanel <- function(title, windowTitle=title) {
 #'       plotOutput("distPlot")
 #'     )
 #'   )
-#' ))
+#' )
 #'
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     hist(rnorm(input$obs))
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
 #' @export
 sidebarLayout <- function(sidebarPanel,
                           mainPanel,
@@ -286,13 +349,18 @@ sidebarLayout <- function(sidebarPanel,
 #' @seealso \code{\link{fluidPage}}, \code{\link{flowLayout}}
 #'
 #' @examples
-#' shinyUI(fluidPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
 #'   verticalLayout(
 #'     a(href="http://example.com/link1", "Link One"),
 #'     a(href="http://example.com/link2", "Link Two"),
 #'     a(href="http://example.com/link3", "Link Three")
 #'   )
-#' ))
+#' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 verticalLayout <- function(..., fluid = TRUE) {
   lapply(list(...), function(row) {
@@ -308,8 +376,8 @@ verticalLayout <- function(..., fluid = TRUE) {
 #'
 #' Lays out elements in a left-to-right, top-to-bottom arrangement. The elements
 #' on a given row will be top-aligned with each other. This layout will not work
-#' well with elements that have a percentage-based width (e.g. `plotOutput` at
-#' its default setting of `width = "100%"`).
+#' well with elements that have a percentage-based width (e.g.
+#' \code{\link{plotOutput}} at its default setting of \code{width = "100\%"}).
 #'
 #' @param ... Unnamed arguments will become child elements of the layout. Named
 #'   arguments will become HTML attributes on the outermost tag.
@@ -319,11 +387,16 @@ verticalLayout <- function(..., fluid = TRUE) {
 #' @seealso \code{\link{verticalLayout}}
 #'
 #' @examples
-#' flowLayout(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- flowLayout(
 #'   numericInput("rows", "How many rows?", 5),
 #'   selectInput("letter", "Which letter?", LETTERS),
 #'   sliderInput("value", "What value?", 0, 100, 50)
 #' )
+#' shinyApp(ui, server = function(input, output) { })
+#' }
 #' @export
 flowLayout <- function(..., cellArgs = list()) {
 
@@ -346,7 +419,6 @@ flowLayout <- function(..., cellArgs = list()) {
 #' suitable for wrapping inputs.
 #'
 #' @param ... Input controls or other HTML elements.
-#'
 #' @export
 inputPanel <- function(...) {
   div(class = "shiny-input-panel",
@@ -369,21 +441,34 @@ inputPanel <- function(...) {
 #'   of the layout.
 #'
 #' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' # Server code used for all examples
+#' server <- function(input, output) {
+#'   output$plot1 <- renderPlot(plot(cars))
+#'   output$plot2 <- renderPlot(plot(pressure))
+#'   output$plot3 <- renderPlot(plot(AirPassengers))
+#' }
+#'
 #' # Equal sizing
-#' splitLayout(
+#' ui <- splitLayout(
 #'   plotOutput("plot1"),
 #'   plotOutput("plot2")
 #' )
+#' shinyApp(ui, server)
 #'
 #' # Custom widths
-#' splitLayout(cellWidths = c("25%", "75%"),
+#' ui <- splitLayout(cellWidths = c("25%", "75%"),
 #'   plotOutput("plot1"),
 #'   plotOutput("plot2")
 #' )
+#' shinyApp(ui, server)
 #'
 #' # All cells at 300 pixels wide, with cell padding
 #' # and a border around everything
-#' splitLayout(
+#' ui <- splitLayout(
 #'   style = "border: 1px solid silver;",
 #'   cellWidths = 300,
 #'   cellArgs = list(style = "padding: 6px"),
@@ -391,6 +476,8 @@ inputPanel <- function(...) {
 #'   plotOutput("plot2"),
 #'   plotOutput("plot3")
 #' )
+#' shinyApp(ui, server)
+#' }
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
@@ -417,3 +504,193 @@ splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
     }, SIMPLIFY = FALSE)
   ))
 }
+
+#' Flex Box-based row/column layouts
+#'
+#' Creates row and column layouts with proportionally-sized cells, using the
+#' Flex Box layout model of CSS3. These can be nested to create arbitrary
+#' proportional-grid layouts. \strong{Warning:} Flex Box is not well supported
+#' by Internet Explorer, so these functions should only be used where modern
+#' browsers can be assumed.
+#'
+#' @details If you try to use \code{fillRow} and \code{fillCol} inside of other
+#'   Shiny containers, such as \code{\link{sidebarLayout}},
+#'   \code{\link{navbarPage}}, or even \code{tags$div}, you will probably find
+#'   that they will not appear. This is due to \code{fillRow} and \code{fillCol}
+#'   defaulting to \code{height="100\%"}, which will only work inside of
+#'   containers that have determined their own size (rather than shrinking to
+#'   the size of their contents, as is usually the case in HTML).
+#'
+#'   To avoid this problem, you have two options:
+#'   \itemize{
+#'     \item only use \code{fillRow}/\code{fillCol} inside of \code{fillPage},
+#'       \code{fillRow}, or \code{fillCol}
+#'     \item provide an explicit \code{height} argument to
+#'       \code{fillRow}/\code{fillCol}
+#'   }
+#'
+#' @param ... UI objects to put in each row/column cell; each argument will
+#'   occupy a single cell. (To put multiple items in a single cell, you can use
+#'   \code{\link{tagList}} or \code{\link{div}} to combine them.) Named
+#'   arguments will be used as attributes on the \code{div} element that
+#'   encapsulates the row/column.
+#' @param flex Determines how space should be distributed to the cells. Can be a
+#'   single value like \code{1} or \code{2} to evenly distribute the available
+#'   space; or use a vector of numbers to specify the proportions. For example,
+#'   \code{flex = c(2, 3)} would cause the space to be split 40\%/60\% between
+#'   two cells. NA values will cause the corresponding cell to be sized
+#'   according to its contents (without growing or shrinking).
+#' @param width,height The total amount of width and height to use for the
+#'   entire row/column. For the default height of \code{"100\%"} to be
+#'   effective, the parent must be \code{fillPage}, another
+#'   \code{fillRow}/\code{fillCol}, or some other HTML element whose height is
+#'   not determined by the height of its contents.
+#'
+#' @examples
+#' # Only run this example in interactive R sessions.
+#' if (interactive()) {
+#'
+#' ui <- fillPage(fillRow(
+#'   plotOutput("plotLeft", height = "100%"),
+#'   fillCol(
+#'     plotOutput("plotTopRight", height = "100%"),
+#'     plotOutput("plotBottomRight", height = "100%")
+#'   )
+#' ))
+#'
+#' server <- function(input, output, session) {
+#'   output$plotLeft <- renderPlot(plot(cars))
+#'   output$plotTopRight <- renderPlot(plot(pressure))
+#'   output$plotBottomRight <- renderPlot(plot(AirPassengers))
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
+#' @export
+fillRow <- function(..., flex = 1, width = "100%", height = "100%") {
+  flexfill(..., direction = "row", flex = flex, width = width, height = height)
+}
+
+#' @rdname fillRow
+#' @export
+fillCol <- function(..., flex = 1, width = "100%", height = "100%") {
+  flexfill(..., direction = "column", flex = flex, width = width, height = height)
+}
+
+flexfill <- function(..., direction, flex, width = width, height = height) {
+  children <- list(...)
+  attrs <- list()
+
+  if (!is.null(names(children))) {
+    attrs <- children[names(children) != ""]
+    children <- children[names(children) == ""]
+  }
+
+  if (length(flex) > length(children)) {
+    flex <- flex[seq_along(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/cache-disk.R

@@ -0,0 +1,561 @@
+#' Create a disk cache object
+#'
+#' A disk cache object is a key-value store that saves the values as files in a
+#' directory on disk. Objects can be stored and retrieved using the \code{get()}
+#' and \code{set()} methods. Objects are automatically pruned from the cache
+#' according to the parameters \code{max_size}, \code{max_age}, \code{max_n},
+#' and \code{evict}.
+#'
+#'
+#' @section Missing Keys:
+#'
+#'   The \code{missing} and \code{exec_missing} parameters controls what happens
+#'   when \code{get()} is called with a key that is not in the cache (a cache
+#'   miss). The default behavior is to return a \code{\link{key_missing}}
+#'   object. This is a \emph{sentinel value} that indicates that the key was not
+#'   present in the cache. You can test if the returned value represents a
+#'   missing key by using the \code{\link{is.key_missing}} function. You can
+#'   also have \code{get()} return a different sentinel value, like \code{NULL}.
+#'   If you want to throw an error on a cache miss, you can do so by providing a
+#'   function for \code{missing} that takes one argument, the key, and also use
+#'   \code{exec_missing=TRUE}.
+#'
+#'   When the cache is created, you can supply a value for \code{missing}, which
+#'   sets the default value to be returned for missing values. It can also be
+#'   overridden when \code{get()} is called, by supplying a \code{missing}
+#'   argument. For example, if you use \code{cache$get("mykey", missing =
+#'   NULL)}, it will return \code{NULL} if the key is not in the cache.
+#'
+#'   If your cache is configured so that \code{get()} returns a sentinel value
+#'   to represent a cache miss, then \code{set} will also not allow you to store
+#'   the sentinel value in the cache. It will throw an error if you attempt to
+#'   do so.
+#'
+#'   Instead of returning the same sentinel value each time there is cache miss,
+#'   the cache can execute a function each time \code{get()} encounters missing
+#'   key. If the function returns a value, then \code{get()} will in turn return
+#'   that value. However, a more common use is for the function to throw an
+#'   error. If an error is thrown, then \code{get()} will not return a value.
+#'
+#'   To do this, pass a one-argument function to \code{missing}, and use
+#'   \code{exec_missing=TRUE}. For example, if you want to throw an error that
+#'   prints the missing key, you could do this:
+#'
+#'   \preformatted{
+#'   diskCache(
+#'     missing = function(key) {
+#'       stop("Attempted to get missing key: ", key)
+#'     },
+#'     exec_missing = TRUE
+#'   )
+#'   }
+#'
+#'   If you use this, the code that calls \code{get()} should be wrapped with
+#'   \code{\link{tryCatch}()} to gracefully handle missing keys.
+#'
+#' @section Cache pruning:
+#'
+#'   Cache pruning occurs when \code{set()} is called, or it can be invoked
+#'   manually by calling \code{prune()}.
+#'
+#'   The disk cache will throttle the pruning so that it does not happen on
+#'   every call to \code{set()}, because the filesystem operations for checking
+#'   the status of files can be slow. Instead, it will prune once in every 20
+#'   calls to \code{set()}, or if at least 5 seconds have elapsed since the last
+#'   prune occurred, whichever is first. These parameters are currently not
+#'   customizable, but may be in the future.
+#'
+#'   When a pruning occurs, if there are any objects that are older than
+#'   \code{max_age}, they will be removed.
+#'
+#'   The \code{max_size} and \code{max_n} parameters are applied to the cache as
+#'   a whole, in contrast to \code{max_age}, which is applied to each object
+#'   individually.
+#'
+#'   If the number of objects in the cache exceeds \code{max_n}, then objects
+#'   will be removed from the cache according to the eviction policy, which is
+#'   set with the \code{evict} parameter. Objects will be removed so that the
+#'   number of items is \code{max_n}.
+#'
+#'   If the size of the objects in the cache exceeds \code{max_size}, then
+#'   objects will be removed from the cache. Objects will be removed from the
+#'   cache so that the total size remains under \code{max_size}. Note that the
+#'   size is calculated using the size of the files, not the size of disk space
+#'   used by the files -- these two values can differ because of files are
+#'   stored in blocks on disk. For example, if the block size is 4096 bytes,
+#'   then a file that is one byte in size will take 4096 bytes on disk.
+#'
+#'   Another time that objects can be removed from the cache is when
+#'   \code{get()} is called. If the target object is older than \code{max_age},
+#'   it will be removed and the cache will report it as a missing value.
+#'
+#' @section Eviction policies:
+#'
+#' If \code{max_n} or \code{max_size} are used, then objects will be removed
+#' from the cache according to an eviction policy. The available eviction
+#' policies are:
+#'
+#'   \describe{
+#'     \item{\code{"lru"}}{
+#'       Least Recently Used. The least recently used objects will be removed.
+#'       This uses the filesystem's mtime property. When "lru" is used, each
+#'       \code{get()} is called, it will update the file's mtime.
+#'     }
+#'     \item{\code{"fifo"}}{
+#'       First-in-first-out. The oldest objects will be removed.
+#'     }
+#'   }
+#'
+#' Both of these policies use files' mtime. Note that some filesystems (notably
+#' FAT) have poor mtime resolution. (atime is not used because support for
+#' atime is worse than mtime.)
+#'
+#'
+#' @section Sharing among multiple processes:
+#'
+#' The directory for a DiskCache can be shared among multiple R processes. To
+#' do this, each R process should have a DiskCache object that uses the same
+#' directory. Each DiskCache will do pruning independently of the others, so if
+#' they have different pruning parameters, then one DiskCache may remove cached
+#' objects before another DiskCache would do so.
+#'
+#' Even though it is possible for multiple processes to share a DiskCache
+#' directory, this should not be done on networked file systems, because of
+#' slow performance of networked file systems can cause problems. If you need
+#' a high-performance shared cache, you can use one built on a database like
+#' Redis, SQLite, mySQL, or similar.
+#'
+#' When multiple processes share a cache directory, there are some potential
+#' race conditions. For example, if your code calls \code{exists(key)} to check
+#' if an object is in the cache, and then call \code{get(key)}, the object may
+#' be removed from the cache in between those two calls, and \code{get(key)}
+#' will throw an error. Instead of calling the two functions, it is better to
+#' simply call \code{get(key)}, and use \code{tryCatch()} to handle the error
+#' that is thrown if the object is not in the cache. This effectively tests for
+#' existence and gets the object in one operation.
+#'
+#' It is also possible for one processes to prune objects at the same time that
+#' another processes is trying to prune objects. If this happens, you may see
+#' a warning from \code{file.remove()} failing to remove a file that has
+#' already been deleted.
+#'
+#'
+#' @section Methods:
+#'
+#'  A disk cache object has the following methods:
+#'
+#'   \describe{
+#'     \item{\code{get(key, missing, exec_missing)}}{
+#'       Returns the value associated with \code{key}. If the key is not in the
+#'       cache, then it returns the value specified by \code{missing} or,
+#'       \code{missing} is a function and \code{exec_missing=TRUE}, then
+#'       executes \code{missing}. The function can throw an error or return the
+#'       value. If either of these parameters are specified here, then they
+#'       will override the defaults that were set when the DiskCache object was
+#'       created. See section Missing Keys for more information.
+#'     }
+#'     \item{\code{set(key, value)}}{
+#'       Stores the \code{key}-\code{value} pair in the cache.
+#'     }
+#'     \item{\code{exists(key)}}{
+#'       Returns \code{TRUE} if the cache contains the key, otherwise
+#'       \code{FALSE}.
+#'     }
+#'     \item{\code{size()}}{
+#'       Returns the number of items currently in the cache.
+#'     }
+#'     \item{\code{keys()}}{
+#'       Returns a character vector of all keys currently in the cache.
+#'     }
+#'     \item{\code{reset()}}{
+#'       Clears all objects from the cache.
+#'     }
+#'     \item{\code{destroy()}}{
+#'       Clears all objects in the cache, and removes the cache directory from
+#'       disk.
+#'     }
+#'     \item{\code{prune()}}{
+#'       Prunes the cache, using the parameters specified by \code{max_size},
+#'       \code{max_age}, \code{max_n}, and \code{evict}.
+#'     }
+#'   }
+#'
+#' @param dir Directory to store files for the cache. If \code{NULL} (the
+#'   default) it will create and use a temporary directory.
+#' @param max_age Maximum age of files in cache before they are evicted, in
+#'   seconds. Use \code{Inf} for no age limit.
+#' @param max_size Maximum size of the cache, in bytes. If the cache exceeds
+#'   this size, cached objects will be removed according to the value of the
+#'   \code{evict}. Use \code{Inf} for no size limit.
+#' @param max_n Maximum number of objects in the cache. If the number of objects
+#'   exceeds this value, then cached objects will be removed according to the
+#'   value of \code{evict}. Use \code{Inf} for no limit of number of items.
+#' @param evict The eviction policy to use to decide which objects are removed
+#'   when a cache pruning occurs. Currently, \code{"lru"} and \code{"fifo"} are
+#'   supported.
+#' @param destroy_on_finalize If \code{TRUE}, then when the DiskCache object is
+#'   garbage collected, the cache directory and all objects inside of it will be
+#'   deleted from disk. If \code{FALSE} (the default), it will do nothing when
+#'   finalized.
+#' @param missing A value to return or a function to execute when
+#'   \code{get(key)} is called but the key is not present in the cache. The
+#'   default is a \code{\link{key_missing}} object. If it is a function to
+#'   execute, the function must take one argument (the key), and you must also
+#'   use \code{exec_missing = TRUE}. If it is a function, it is useful in most
+#'   cases for it to throw an error, although another option is to return a
+#'   value. If a value is returned, that value will in turn be returned by
+#'   \code{get()}. See section Missing keys for more information.
+#' @param exec_missing If \code{FALSE} (the default), then treat \code{missing}
+#'   as a value to return when \code{get()} results in a cache miss. If
+#'   \code{TRUE}, treat \code{missing} as a function to execute when
+#'   \code{get()} results in a cache miss.
+#' @param logfile An optional filename or connection object to where logging
+#'   information will be written. To log to the console, use \code{stdout()}.
+#'
+#' @export
+diskCache <- function(
+  dir = NULL,
+  max_size = 10 * 1024 ^ 2,
+  max_age = Inf,
+  max_n = Inf,
+  evict = c("lru", "fifo"),
+  destroy_on_finalize = FALSE,
+  missing = key_missing(),
+  exec_missing = FALSE,
+  logfile = NULL)
+{
+  DiskCache$new(dir, max_size, max_age, max_n, evict, destroy_on_finalize,
+                missing, exec_missing, logfile)
+}
+
+
+DiskCache <- R6Class("DiskCache",
+  public = list(
+    initialize = function(
+      dir = NULL,
+      max_size = 10 * 1024 ^ 2,
+      max_age = Inf,
+      max_n = Inf,
+      evict = c("lru", "fifo"),
+      destroy_on_finalize = FALSE,
+      missing = key_missing(),
+      exec_missing = FALSE,
+      logfile = NULL)
+    {
+      if (exec_missing && (!is.function(missing) || length(formals(missing)) == 0)) {
+        stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+      }
+      if (is.null(dir)) {
+        dir <- tempfile("DiskCache-")
+      }
+      if (!is.numeric(max_size)) stop("max_size must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_age))  stop("max_age must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_n))    stop("max_n must be a number. Use `Inf` for no limit.")
+
+      if (!dirExists(dir)) {
+        private$log(paste0("initialize: Creating ", dir))
+        dir.create(dir, recursive = TRUE)
+      }
+
+      private$dir                 <- normalizePath(dir)
+      private$max_size            <- max_size
+      private$max_age             <- max_age
+      private$max_n               <- max_n
+      private$evict               <- match.arg(evict)
+      private$destroy_on_finalize <- destroy_on_finalize
+      private$missing             <- missing
+      private$exec_missing        <- exec_missing
+      private$logfile             <- logfile
+
+      private$prune_last_time     <- as.numeric(Sys.time())
+    },
+
+    get = function(key, missing = private$missing, exec_missing = private$exec_missing) {
+      private$log(paste0('get: key "', key, '"'))
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+
+      private$maybe_prune_single(key)
+
+      filename <- private$key_to_filename(key)
+
+      # Instead of calling exists() before fetching the value, just try to
+      # fetch the value. This reduces the risk of a race condition when
+      # multiple processes share a cache.
+      read_error <- FALSE
+      tryCatch(
+        {
+          value <- suppressWarnings(readRDS(filename))
+          if (private$evict == "lru"){
+            Sys.setFileTime(filename, Sys.time())
+          }
+        },
+        error = function(e) {
+          read_error <<- TRUE
+        }
+      )
+      if (read_error) {
+        private$log(paste0('get: key "', key, '" is missing'))
+
+        if (exec_missing) {
+          if (!is.function(missing) || length(formals(missing)) == 0) {
+            stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+          }
+          return(missing(key))
+        } else {
+          return(missing)
+        }
+      }
+
+      private$log(paste0('get: key "', key, '" found'))
+      value
+    },
+
+    set = function(key, value) {
+      private$log(paste0('set: key "', key, '"'))
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+
+      file <- private$key_to_filename(key)
+      temp_file <- paste0(file, "-temp-", createUniqueId(8))
+
+      save_error <- FALSE
+      ref_object <- FALSE
+      tryCatch(
+        {
+          saveRDS(value, file = temp_file,
+            refhook = function(x) {
+              ref_object <<- TRUE
+              NULL
+            }
+          )
+          file.rename(temp_file, file)
+        },
+        error = function(e) {
+          save_error <<- TRUE
+          # Unlike file.remove(), unlink() does not raise warning if file does
+          # not exist.
+          unlink(temp_file)
+        }
+      )
+      if (save_error) {
+        private$log(paste0('set: key "', key, '" error'))
+        stop('Error setting value for key "', key, '".')
+      }
+      if (ref_object) {
+        private$log(paste0('set: value is a reference object'))
+        warning("A reference object was cached in a serialized format. The restored object may not work as expected.")
+      }
+
+      private$prune_throttled()
+      invisible(self)
+    },
+
+    exists = function(key) {
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+      file.exists(private$key_to_filename(key))
+    },
+
+    # Return all keys in the cache
+    keys = function() {
+      self$is_destroyed(throw = TRUE)
+      files <- dir(private$dir, "\\.rds$")
+      sub("\\.rds$", "", files)
+    },
+
+    remove = function(key) {
+      private$log(paste0('remove: key "', key, '"'))
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+      file.remove(private$key_to_filename(key))
+      invisible(self)
+    },
+
+    reset = function() {
+      private$log(paste0('reset'))
+      self$is_destroyed(throw = TRUE)
+      file.remove(dir(private$dir, "\\.rds$", full.names = TRUE))
+      invisible(self)
+    },
+
+    prune = function() {
+      # TODO: It would be good to add parameters `n` and `size`, so that the
+      # cache can be pruned to `max_n - n` and `max_size - size` before adding
+      # an object. Right now we prune after adding the object, so the cache
+      # can temporarily grow past the limits. The reason we don't do this now
+      # is because it is expensive to find the size of the serialized object
+      # before adding it.
+
+      private$log(paste0('prune'))
+      self$is_destroyed(throw = TRUE)
+
+      current_time <- Sys.time()
+
+      filenames <- dir(private$dir, "\\.rds$", full.names = TRUE)
+      info <- file.info(filenames)
+      info <- info[info$isdir == FALSE, ]
+      info$name <- rownames(info)
+      rownames(info) <- NULL
+      # Files could be removed between the dir() and file.info() calls. The
+      # entire row for such files will have NA values. Remove those rows.
+      info <- info[!is.na(info$size), ]
+
+      # 1. Remove any files where the age exceeds max age.
+      if (is.finite(private$max_age)) {
+        timediff <- as.numeric(current_time - info$mtime, units = "secs")
+        rm_idx <- timediff > private$max_age
+        if (any(rm_idx)) {
+          private$log(paste0("prune max_age: Removing ", paste(info$name[rm_idx], collapse = ", ")))
+          file.remove(info$name[rm_idx])
+          info <- info[!rm_idx, ]
+        }
+      }
+
+      # Sort objects by priority. The sorting is done in a function which can be
+      # called multiple times but only does the work the first time.
+      info_is_sorted <- FALSE
+      ensure_info_is_sorted <- function() {
+        if (info_is_sorted) return()
+
+        info <<- info[order(info$mtime, decreasing = TRUE), ]
+        info_is_sorted <<- TRUE
+      }
+
+      # 2. Remove files if there are too many.
+      if (is.finite(private$max_n) && nrow(info) > private$max_n) {
+        ensure_info_is_sorted()
+        rm_idx <- seq_len(nrow(info)) > private$max_n
+        private$log(paste0("prune max_n: Removing ", paste(info$name[rm_idx], collapse = ", ")))
+        rm_success <- file.remove(info$name[rm_idx])
+        info <- info[!rm_success, ]
+      }
+
+      # 3. Remove files if cache is too large.
+      if (is.finite(private$max_size) && sum(info$size) > private$max_size) {
+        ensure_info_is_sorted()
+        cum_size <- cumsum(info$size)
+        rm_idx <- cum_size > private$max_size
+        private$log(paste0("prune max_size: Removing ", paste(info$name[rm_idx], collapse = ", ")))
+        rm_success <- file.remove(info$name[rm_idx])
+        info <- info[!rm_success, ]
+      }
+
+      private$prune_last_time <- as.numeric(current_time)
+
+      invisible(self)
+    },
+
+    size = function() {
+      self$is_destroyed(throw = TRUE)
+      length(dir(private$dir, "\\.rds$"))
+    },
+
+    destroy = function() {
+      if (self$is_destroyed()) {
+        return(invisible(self))
+      }
+
+      private$log(paste0("destroy: Removing ", private$dir))
+      # First create a sentinel file so that other processes sharing this
+      # cache know that the cache is to be destroyed. This is needed because
+      # the recursive unlink is not atomic: another process can add a file to
+      # the directory after unlink starts removing files but before it removes
+      # the directory, and when that happens, the directory removal will fail.
+      file.create(file.path(private$dir, "__destroyed__"))
+      # Remove all the .rds files. This will not remove the setinel file.
+      file.remove(dir(private$dir, "\\.rds$", full.names = TRUE))
+      # Next remove dir recursively, including sentinel file.
+      unlink(private$dir, recursive = TRUE)
+      private$destroyed <- TRUE
+      invisible(self)
+    },
+
+    is_destroyed = function(throw = FALSE) {
+      if (!dirExists(private$dir) ||
+          file.exists(file.path(private$dir, "__destroyed__")))
+      {
+        # It's possible for another process to destroy a shared cache directory
+        private$destroyed <- TRUE
+      }
+
+      if (throw) {
+        if (private$destroyed) {
+          stop("Attempted to use cache which has been destroyed:\n  ", private$dir)
+        }
+
+      } else {
+        private$destroyed
+      }
+    },
+
+    finalize = function() {
+      if (private$destroy_on_finalize) {
+        self$destroy()
+      }
+    }
+  ),
+
+  private = list(
+    dir = NULL,
+    max_age = NULL,
+    max_size = NULL,
+    max_n = NULL,
+    evict = NULL,
+    destroy_on_finalize = NULL,
+    destroyed = FALSE,
+    missing = NULL,
+    exec_missing = FALSE,
+    logfile = NULL,
+
+    prune_throttle_counter = 0,
+    prune_last_time = NULL,
+
+    key_to_filename = function(key) {
+      validate_key(key)
+      # Additional validation. This 80-char limit is arbitrary, and is
+      # intended to avoid hitting a filename length limit on Windows.
+      if (nchar(key) > 80) {
+        stop("Invalid key: key must have fewer than 80 characters.")
+      }
+      file.path(private$dir, paste0(key, ".rds"))
+    },
+
+    # A wrapper for prune() that throttles it, because prune() can be
+    # expensive due to filesystem operations. This function will prune only
+    # once every 20 times it is called, or if it has been more than 5 seconds
+    # since the last time the cache was actually pruned, whichever is first.
+    # In the future, the behavior may be customizable.
+    prune_throttled = function() {
+      # Count the number of times prune() has been called.
+      private$prune_throttle_counter <- private$prune_throttle_counter + 1
+
+      if (private$prune_throttle_counter > 20 ||
+          private$prune_last_time - as.numeric(Sys.time()) > 5)
+      {
+        self$prune()
+        private$prune_throttle_counter <- 0
+      }
+    },
+
+    # Prunes a single object if it exceeds max_age. If the object does not
+    # exceed max_age, or if the object doesn't exist, do nothing.
+    maybe_prune_single = function(key) {
+      obj <- private$cache[[key]]
+      if (is.null(obj)) return()
+
+      timediff <- as.numeric(Sys.time()) - obj$mtime
+      if (timediff > private$max_age) {
+        private$log(paste0("pruning single object exceeding max_age: Removing ", key))
+        rm(list = key, envir = private$cache)
+      }
+    },
+
+    log = function(text) {
+      if (is.null(private$logfile)) return()
+
+      text <- paste0(format(Sys.time(), "[%Y-%m-%d %H:%M:%OS3] DiskCache "), text)
+      writeLines(text, private$logfile)
+    }
+  )
+)

R/cache-memory.R

@@ -0,0 +1,366 @@
+#' Create a memory cache object
+#'
+#' A memory cache object is a key-value store that saves the values in an
+#' environment. Objects can be stored and retrieved using the \code{get()} and
+#' \code{set()} methods. Objects are automatically pruned from the cache
+#' according to the parameters \code{max_size}, \code{max_age}, \code{max_n},
+#' and \code{evict}.
+#'
+#' In a \code{MemoryCache}, R objects are stored directly in the cache; they are
+#' not \emph{not} serialized before being stored in the cache. This contrasts
+#' with other cache types, like \code{\link{diskCache}}, where objects are
+#' serialized, and the serialized object is cached. This can result in some
+#' differences of behavior. For example, as long as an object is stored in a
+#' MemoryCache, it will not be garbage collected.
+#'
+#'
+#' @section Missing keys:
+#'   The \code{missing} and \code{exec_missing} parameters controls what happens
+#'   when \code{get()} is called with a key that is not in the cache (a cache
+#'   miss). The default behavior is to return a \code{\link{key_missing}}
+#'   object. This is a \emph{sentinel value} that indicates that the key was not
+#'   present in the cache. You can test if the returned value represents a
+#'   missing key by using the \code{\link{is.key_missing}} function. You can
+#'   also have \code{get()} return a different sentinel value, like \code{NULL}.
+#'   If you want to throw an error on a cache miss, you can do so by providing a
+#'   function for \code{missing} that takes one argument, the key, and also use
+#'   \code{exec_missing=TRUE}.
+#'
+#'   When the cache is created, you can supply a value for \code{missing}, which
+#'   sets the default value to be returned for missing values. It can also be
+#'   overridden when \code{get()} is called, by supplying a \code{missing}
+#'   argument. For example, if you use \code{cache$get("mykey", missing =
+#'   NULL)}, it will return \code{NULL} if the key is not in the cache.
+#'
+#'   If your cache is configured so that \code{get()} returns a sentinel value
+#'   to represent a cache miss, then \code{set} will also not allow you to store
+#'   the sentinel value in the cache. It will throw an error if you attempt to
+#'   do so.
+#'
+#'   Instead of returning the same sentinel value each time there is cache miss,
+#'   the cache can execute a function each time \code{get()} encounters missing
+#'   key. If the function returns a value, then \code{get()} will in turn return
+#'   that value. However, a more common use is for the function to throw an
+#'   error. If an error is thrown, then \code{get()} will not return a value.
+#'
+#'   To do this, pass a one-argument function to \code{missing}, and use
+#'   \code{exec_missing=TRUE}. For example, if you want to throw an error that
+#'   prints the missing key, you could do this:
+#'
+#'   \preformatted{
+#'   diskCache(
+#'     missing = function(key) {
+#'       stop("Attempted to get missing key: ", key)
+#'     },
+#'     exec_missing = TRUE
+#'   )
+#'   }
+#'
+#'   If you use this, the code that calls \code{get()} should be wrapped with
+#'   \code{\link{tryCatch}()} to gracefully handle missing keys.
+#'
+#' @section Cache pruning:
+#'
+#'   Cache pruning occurs when \code{set()} is called, or it can be invoked
+#'   manually by calling \code{prune()}.
+#'
+#'   When a pruning occurs, if there are any objects that are older than
+#'   \code{max_age}, they will be removed.
+#'
+#'   The \code{max_size} and \code{max_n} parameters are applied to the cache as
+#'   a whole, in contrast to \code{max_age}, which is applied to each object
+#'   individually.
+#'
+#'   If the number of objects in the cache exceeds \code{max_n}, then objects
+#'   will be removed from the cache according to the eviction policy, which is
+#'   set with the \code{evict} parameter. Objects will be removed so that the
+#'   number of items is \code{max_n}.
+#'
+#'   If the size of the objects in the cache exceeds \code{max_size}, then
+#'   objects will be removed from the cache. Objects will be removed from the
+#'   cache so that the total size remains under \code{max_size}. Note that the
+#'   size is calculated using the size of the files, not the size of disk space
+#'   used by the files -- these two values can differ because of files are
+#'   stored in blocks on disk. For example, if the block size is 4096 bytes,
+#'   then a file that is one byte in size will take 4096 bytes on disk.
+#'
+#'   Another time that objects can be removed from the cache is when
+#'   \code{get()} is called. If the target object is older than \code{max_age},
+#'   it will be removed and the cache will report it as a missing value.
+#'
+#' @section Eviction policies:
+#'
+#' If \code{max_n} or \code{max_size} are used, then objects will be removed
+#' from the cache according to an eviction policy. The available eviction
+#' policies are:
+#'
+#'   \describe{
+#'     \item{\code{"lru"}}{
+#'       Least Recently Used. The least recently used objects will be removed.
+#'       This uses the filesystem's atime property. Some filesystems do not
+#'       support atime, or have a very low atime resolution. The DiskCache will
+#'       check for atime support, and if the filesystem does not support atime,
+#'       a warning will be issued and the "fifo" policy will be used instead.
+#'     }
+#'     \item{\code{"fifo"}}{
+#'       First-in-first-out. The oldest objects will be removed.
+#'     }
+#'   }
+#'
+#' @section Methods:
+#'
+#'  A disk cache object has the following methods:
+#'
+#'   \describe{
+#'     \item{\code{get(key, missing, exec_missing)}}{
+#'       Returns the value associated with \code{key}. If the key is not in the
+#'       cache, then it returns the value specified by \code{missing} or,
+#'       \code{missing} is a function and \code{exec_missing=TRUE}, then
+#'       executes \code{missing}. The function can throw an error or return the
+#'       value. If either of these parameters are specified here, then they
+#'       will override the defaults that were set when the DiskCache object was
+#'       created. See section Missing Keys for more information.
+#'     }
+#'     \item{\code{set(key, value)}}{
+#'       Stores the \code{key}-\code{value} pair in the cache.
+#'     }
+#'     \item{\code{exists(key)}}{
+#'       Returns \code{TRUE} if the cache contains the key, otherwise
+#'       \code{FALSE}.
+#'     }
+#'     \item{\code{size()}}{
+#'       Returns the number of items currently in the cache.
+#'     }
+#'     \item{\code{keys()}}{
+#'       Returns a character vector of all keys currently in the cache.
+#'     }
+#'     \item{\code{reset()}}{
+#'       Clears all objects from the cache.
+#'     }
+#'     \item{\code{destroy()}}{
+#'       Clears all objects in the cache, and removes the cache directory from
+#'       disk.
+#'     }
+#'     \item{\code{prune()}}{
+#'       Prunes the cache, using the parameters specified by \code{max_size},
+#'       \code{max_age}, \code{max_n}, and \code{evict}.
+#'     }
+#'   }
+#'
+#' @inheritParams diskCache
+#'
+#' @export
+memoryCache <- function(
+  max_size = 10 * 1024 ^ 2,
+  max_age = Inf,
+  max_n = Inf,
+  evict = c("lru", "fifo"),
+  missing = key_missing(),
+  exec_missing = FALSE,
+  logfile = NULL)
+{
+  MemoryCache$new(max_size, max_age, max_n, evict, missing, exec_missing, logfile)
+}
+
+MemoryCache <- R6Class("MemoryCache",
+  public = list(
+    initialize = function(
+      max_size = 10 * 1024 ^ 2,
+      max_age = Inf,
+      max_n = Inf,
+      evict = c("lru", "fifo"),
+      missing = key_missing(),
+      exec_missing = FALSE,
+      logfile = NULL)
+    {
+      if (exec_missing && (!is.function(missing) || length(formals(missing)) == 0)) {
+        stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+      }
+      if (!is.numeric(max_size)) stop("max_size must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_age))  stop("max_age must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_n))    stop("max_n must be a number. Use `Inf` for no limit.")
+      private$cache        <- new.env(parent = emptyenv())
+      private$max_size     <- max_size
+      private$max_age      <- max_age
+      private$max_n        <- max_n
+      private$evict        <- match.arg(evict)
+      private$missing      <- missing
+      private$exec_missing <- exec_missing
+      private$logfile      <- logfile
+    },
+
+    get = function(key, missing = private$missing, exec_missing = private$exec_missing) {
+      private$log(paste0('get: key "', key, '"'))
+      validate_key(key)
+
+      private$maybe_prune_single(key)
+
+      if (!self$exists(key)) {
+        private$log(paste0('get: key "', key, '" is missing'))
+        if (exec_missing) {
+          if (!is.function(missing) || length(formals(missing)) == 0) {
+            stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+          }
+          return(missing(key))
+        } else {
+          return(missing)
+        }
+      }
+
+      private$log(paste0('get: key "', key, '" found'))
+      value <- private$cache[[key]]$value
+      value
+    },
+
+    set = function(key, value) {
+      private$log(paste0('set: key "', key, '"'))
+      validate_key(key)
+
+      time <- as.numeric(Sys.time())
+
+      # Only record size if we're actually using max_size for pruning.
+      if (is.finite(private$max_size)) {
+        # Reported size is rough! See ?object.size.
+        size <- as.numeric(object.size(value))
+      } else {
+        size <- NULL
+      }
+
+      private$cache[[key]] <- list(
+        key = key,
+        value = value,
+        size = size,
+        mtime = time,
+        atime = time
+      )
+      self$prune()
+      invisible(self)
+    },
+
+    exists = function(key) {
+      validate_key(key)
+      # Faster than `exists(key, envir = private$cache, inherits = FALSE)
+      !is.null(private$cache[[key]])
+    },
+
+    keys = function() {
+      ls(private$cache, sorted = FALSE)  # Faster with sorted=FALSE
+    },
+
+    remove = function(key) {
+      private$log(paste0('remove: key "', key, '"'))
+      validate_key(key)
+      rm(list = key, envir = private$cache)
+      invisible(self)
+    },
+
+    reset = function() {
+      private$log(paste0('reset'))
+      rm(list = self$keys(), envir = private$cache)
+      invisible(self)
+    },
+
+    prune = function() {
+      private$log(paste0('prune'))
+      info <- private$object_info()
+
+      # 1. Remove any objects where the age exceeds max age.
+      if (is.finite(private$max_age)) {
+        time <- as.numeric(Sys.time())
+        timediff <- time - info$mtime
+        rm_idx <- timediff > private$max_age
+        if (any(rm_idx)) {
+          private$log(paste0("prune max_age: Removing ", paste(info$key[rm_idx], collapse = ", ")))
+          rm(list = info$key[rm_idx], envir = private$cache)
+          info <- info[!rm_idx, ]
+        }
+      }
+
+      # Sort objects by priority, according to eviction policy. The sorting is
+      # done in a function which can be called multiple times but only does
+      # the work the first time.
+      info_is_sorted <- FALSE
+      ensure_info_is_sorted <- function() {
+        if (info_is_sorted) return()
+
+        if (private$evict == "lru") {
+          info <<- info[order(info$atime, decreasing = TRUE), ]
+        } else if (private$evict == "fifo") {
+          info <<- info[order(info$mtime, decreasing = TRUE), ]
+        } else {
+          stop('Unknown eviction policy "', private$evict, '"')
+        }
+        info_is_sorted <<- TRUE
+      }
+
+      # 2. Remove objects if there are too many.
+      if (is.finite(private$max_n) && nrow(info) > private$max_n) {
+        ensure_info_is_sorted()
+        rm_idx <- seq_len(nrow(info)) > private$max_n
+        private$log(paste0("prune max_n: Removing ", paste(info$key[rm_idx], collapse = ", ")))
+        rm(list = info$key[rm_idx], envir = private$cache)
+        info <- info[!rm_idx, ]
+      }
+
+      # 3. Remove objects if cache is too large.
+      if (is.finite(private$max_size) && sum(info$size) > private$max_size) {
+        ensure_info_is_sorted()
+        cum_size <- cumsum(info$size)
+        rm_idx <- cum_size > private$max_size
+        private$log(paste0("prune max_size: Removing ", paste(info$key[rm_idx], collapse = ", ")))
+        rm(list = info$key[rm_idx], envir = private$cache)
+        info <- info[!rm_idx, ]
+      }
+
+      invisible(self)
+    },
+
+    size = function() {
+      length(self$keys())
+    }
+  ),
+
+  private = list(
+    cache = NULL,
+    max_age = NULL,
+    max_size = NULL,
+    max_n = NULL,
+    evict = NULL,
+    missing = NULL,
+    exec_missing = NULL,
+    logfile = NULL,
+
+    # Prunes a single object if it exceeds max_age. If the object does not
+    # exceed max_age, or if the object doesn't exist, do nothing.
+    maybe_prune_single = function(key) {
+      if (!is.finite(private$max_age)) return()
+
+      obj <- private$cache[[key]]
+      if (is.null(obj)) return()
+
+      timediff <- as.numeric(Sys.time()) - obj$mtime
+      if (timediff > private$max_age) {
+        private$log(paste0("pruning single object exceeding max_age: Removing ", key))
+        rm(list = key, envir = private$cache)
+      }
+    },
+
+    object_info = function() {
+      keys <- ls(private$cache, sorted = FALSE)
+      data.frame(
+        key   = keys,
+        size  = vapply(keys, function(key) private$cache[[key]]$size,  0),
+        mtime = vapply(keys, function(key) private$cache[[key]]$mtime, 0),
+        atime = vapply(keys, function(key) private$cache[[key]]$atime, 0),
+        stringsAsFactors = FALSE
+      )
+    },
+
+    log = function(text) {
+      if (is.null(private$logfile)) return()
+
+      text <- paste0(format(Sys.time(), "[%Y-%m-%d %H:%M:%OS3] MemoryCache "), text)
+      writeLines(text, private$logfile)
+    }
+  )
+)

R/cache-utils.R

@@ -0,0 +1,33 @@
+#' A Key Missing object
+#'
+#' A \code{key_missing} object represents a cache miss.
+#'
+#' @param x An object to test.
+#'
+#' @seealso \code{\link{diskCache}}, \code{\link{memoryCache}}.
+#'
+#' @export
+key_missing <- function() {
+  structure(list(), class = "key_missing")
+}
+
+#' @rdname key_missing
+#' @export
+is.key_missing <- function(x) {
+  inherits(x, "key_missing")
+}
+
+#' @export
+print.key_missing <- function(x, ...) {
+  cat("<Key Missing>\n")
+}
+
+
+validate_key <- function(key) {
+  if (!is.character(key) || length(key) != 1 || nchar(key) == 0) {
+    stop("Invalid key: key must be single non-empty string.")
+  }
+  if (grepl("[^a-z0-9]", key)) {
+    stop("Invalid key: ", key, ". Only lowercase letters and numbers are allowed.")
+  }
+}

R/conditions.R

@@ -0,0 +1,627 @@
+#' Stack trace manipulation functions
+#'
+#' Advanced (borderline internal) functions for capturing, printing, and
+#' manipulating stack traces.
+#'
+#' @return \code{printError} and \code{printStackTrace} return
+#'   \code{invisible()}. The other functions pass through the results of
+#'   \code{expr}.
+#'
+#' @examples
+#' # Keeps tryCatch and withVisible related calls off the
+#' # pretty-printed stack trace
+#'
+#' visibleFunction1 <- function() {
+#'   stop("Kaboom!")
+#' }
+#'
+#' visibleFunction2 <- function() {
+#'   visibleFunction1()
+#' }
+#'
+#' hiddenFunction <- function(expr) {
+#'   expr
+#' }
+#'
+#' # An example without ..stacktraceon/off.. manipulation.
+#' # The outer "try" is just to prevent example() from stopping.
+#' try({
+#'   # The withLogErrors call ensures that stack traces are captured
+#'   # and that errors that bubble up are logged using warning().
+#'   withLogErrors({
+#'     # tryCatch and withVisible are just here to add some noise to
+#'     # the stack trace.
+#'     tryCatch(
+#'       withVisible({
+#'         hiddenFunction(visibleFunction2())
+#'       })
+#'     )
+#'   })
+#' })
+#'
+#' # Now the same example, but with ..stacktraceon/off.. to hide some
+#' # of the less-interesting bits (tryCatch and withVisible).
+#' ..stacktraceoff..({
+#'   try({
+#'     withLogErrors({
+#'       tryCatch(
+#'         withVisible(
+#'           hiddenFunction(
+#'             ..stacktraceon..(visibleFunction2())
+#'           )
+#'         )
+#'       )
+#'     })
+#'   })
+#' })
+#'
+#'
+#' @name stacktrace
+#' @rdname stacktrace
+#' @keywords internal
+NULL
+
+getCallNames <- function(calls) {
+  sapply(calls, function(call) {
+    if (is.function(call[[1]])) {
+      "<Anonymous>"
+    } else if (inherits(call[[1]], "call")) {
+      paste0(format(call[[1]]), collapse = " ")
+    } else if (typeof(call[[1]]) == "promise") {
+      "<Promise>"
+    } else {
+      paste0(as.character(call[[1]]), collapse = " ")
+    }
+  })
+}
+
+getLocs <- function(calls) {
+  vapply(calls, function(call) {
+    srcref <- attr(call, "srcref", exact = TRUE)
+    if (!is.null(srcref)) {
+      srcfile <- attr(srcref, "srcfile", exact = TRUE)
+      if (!is.null(srcfile) && !is.null(srcfile$filename)) {
+        loc <- paste0(srcfile$filename, "#", srcref[[1]])
+        return(paste0(" [", loc, "]"))
+      }
+    }
+    return("")
+  }, character(1))
+}
+
+getCallCategories <- function(calls) {
+  vapply(calls, function(call) {
+    srcref <- attr(call, "srcref", exact = TRUE)
+    if (!is.null(srcref)) {
+      srcfile <- attr(srcref, "srcfile", exact = TRUE)
+      if (!is.null(srcfile)) {
+        if (!is.null(srcfile$original)) {
+          return("pkg")
+        } else {
+          return("user")
+        }
+      }
+    }
+    return("")
+  }, character(1))
+}
+
+#' @details \code{captureStackTraces} runs the given \code{expr} and if any
+#'   \emph{uncaught} errors occur, annotates them with stack trace info for use
+#'   by \code{printError} and \code{printStackTrace}. It is not necessary to use
+#'   \code{captureStackTraces} around the same expression as
+#'   \code{withLogErrors}, as the latter includes a call to the former. Note
+#'   that if \code{expr} contains calls (either directly or indirectly) to
+#'   \code{try}, or \code{tryCatch} with an error handler, stack traces therein
+#'   cannot be captured unless another \code{captureStackTraces} call is
+#'   inserted in the interior of the \code{try} or \code{tryCatch}. This is
+#'   because these calls catch the error and prevent it from traveling up to the
+#'   condition handler installed by \code{captureStackTraces}.
+#'
+#' @param expr The expression to wrap.
+#' @rdname stacktrace
+#' @export
+captureStackTraces <- function(expr) {
+  promises::with_promise_domain(createStackTracePromiseDomain(),
+    expr
+  )
+}
+
+#' @include globals.R
+.globals$deepStack <- NULL
+
+createStackTracePromiseDomain <- function() {
+  # These are actually stateless, we wouldn't have to create a new one each time
+  # if we didn't want to. They're pretty cheap though.
+  
+  d <- promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      # Subscription time
+      if (deepStacksEnabled()) {
+        currentStack <- sys.calls()
+        currentParents <- sys.parents()
+        attr(currentStack, "parents") <- currentParents
+        currentDeepStack <- .globals$deepStack
+      }
+      function(...) {
+        # Fulfill time
+        if (deepStacksEnabled()) {
+          origDeepStack <- .globals$deepStack
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
+        }
+
+        withCallingHandlers(
+          onFulfilled(...),
+          error = doCaptureStack
+        )
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      # Subscription time
+      if (deepStacksEnabled()) {
+        currentStack <- sys.calls()
+        currentParents <- sys.parents()
+        attr(currentStack, "parents") <- currentParents
+        currentDeepStack <- .globals$deepStack
+      }
+      function(...) {
+        # Fulfill time
+        if (deepStacksEnabled()) {
+          origDeepStack <- .globals$deepStack
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
+        }
+
+        withCallingHandlers(
+          onRejected(...),
+          error = doCaptureStack
+        )
+      }
+    },
+    wrapSync = function(expr) {
+      withCallingHandlers(expr,
+        error = doCaptureStack
+      )
+    },
+    onError = doCaptureStack
+  )
+}
+
+deepStacksEnabled <- function() {
+  getOption("shiny.deepstacktrace", TRUE)
+}
+
+doCaptureStack <- function(e) {
+  if (is.null(attr(e, "stack.trace", exact = TRUE))) {
+    calls <- sys.calls()
+    parents <- sys.parents()
+    attr(calls, "parents") <- parents
+    attr(e, "stack.trace") <- calls
+  }
+  if (deepStacksEnabled()) {
+    if (is.null(attr(e, "deep.stack.trace", exact = TRUE)) && !is.null(.globals$deepStack)) {
+      attr(e, "deep.stack.trace") <- .globals$deepStack
+    }
+  }
+  stop(e)
+}
+
+#' @details \code{withLogErrors} captures stack traces and logs errors that
+#'   occur in \code{expr}, but does allow errors to propagate beyond this point
+#'   (i.e. it doesn't catch the error). The same caveats that apply to
+#'   \code{captureStackTraces} with regard to \code{try}/\code{tryCatch} apply
+#'   to \code{withLogErrors}.
+#' @rdname stacktrace
+#' @export
+withLogErrors <- function(expr,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  withCallingHandlers(
+    {
+      result <- captureStackTraces(expr)
+
+      # Handle expr being an async operation
+      if (promises::is.promise(result)) {
+        result <- promises::catch(result, 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)
+          }
+        })
+      }
+
+      result
+    },
+    error = function(cond) {
+      # Don't print shiny.silent.error (i.e. validation errors)
+      if (inherits(cond, "shiny.silent.error")) return()
+      if (isTRUE(getOption("show.error.messages"))) {
+        printError(cond, full = full, offset = offset)
+      }
+    }
+  )
+}
+
+#' @details \code{printError} prints the error and stack trace (if any) using
+#'   \code{warning(immediate.=TRUE)}. \code{printStackTrace} prints the stack
+#'   trace only.
+#'
+#' @param cond An condition object (generally, an error).
+#' @param full If \code{TRUE}, then every element of \code{sys.calls()} will be
+#'   included in the stack trace. By default (\code{FALSE}), calls that Shiny
+#'   deems uninteresting will be hidden.
+#' @param offset If \code{TRUE} (the default), srcrefs will be reassigned from
+#'   the calls they originated from, to the destinations of those calls. If
+#'   you're used to stack traces from other languages, this feels more
+#'   intuitive, as the definition of the function indicated in the call and the
+#'   location specified by the srcref match up. If \code{FALSE}, srcrefs will be
+#'   left alone (traditional R treatment where the srcref is of the callsite).
+#' @rdname stacktrace
+#' @export
+printError <- function(cond,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+  
+  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s", 
+    getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
+  
+  printStackTrace(cond, full = full, offset = offset)
+}
+
+#' @rdname stacktrace
+#' @export
+printStackTrace <- function(cond,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  should_drop <- !full
+  should_strip <- !full
+  should_prune <- !full
+  
+  stackTraceCalls <- c(
+    attr(cond, "deep.stack.trace", exact = TRUE),
+    list(attr(cond, "stack.trace", exact = TRUE))
+  )
+  
+  stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
+  stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
+  stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
+  
+  # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
+  if (should_drop) {
+    # toKeep is a list of logical vectors, of which elements (stack frames) to keep
+    toKeep <- lapply(stackTraceCallNames, dropTrivialFrames)
+    # We apply the list of logical vector indices to each data structure
+    stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+    stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+    stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+  }
+  
+  delayedAssign("all_true", {
+    # List of logical vectors that are all TRUE, the same shape as
+    # stackTraceCallNames. Delay the evaluation so we don't create it unless
+    # we need it, but if we need it twice then we don't pay to create it twice.
+    lapply(stackTraceCallNames, function(st) {
+      rep_len(TRUE, length(st))
+    })
+  })
+  
+  # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
+  # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
+  # logical vectors.
+  toShow <- mapply(
+    if (should_strip) stripStackTraces(stackTraceCallNames) else all_true,
+    if (should_prune) lapply(stackTraceParents, pruneStackTrace) else all_true,
+    FUN = `&`,
+    SIMPLIFY = FALSE
+  )
+  
+  dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
+    st <- data.frame(
+      num = rev(which(index)),
+      call = rev(nms[index]),
+      loc = rev(getLocs(calls[index])),
+      category = rev(getCallCategories(calls[index])),
+      stringsAsFactors = FALSE
+    )
+    
+    if (i != 1) {
+      message("From earlier call:")
+    }
+
+    if (nrow(st) == 0) {
+      message("  [No stack trace available]")
+    } else {
+      width <- floor(log10(max(st$num))) + 1
+      formatted <- paste0(
+        "  ",
+        formatC(st$num, width = width),
+        ": ",
+        mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+          if (category == "pkg")
+            crayon::silver(name)
+          else if (category == "user")
+            crayon::blue$bold(name)
+          else
+            crayon::white(name)
+        }),
+        "\n"
+      )
+      cat(file = stderr(), formatted, sep = "")
+    }
+
+    st
+  }, SIMPLIFY = FALSE)
+  
+  invisible()
+}
+
+#' @details \code{extractStackTrace} takes a list of calls (e.g. as returned
+#'   from \code{conditionStackTrace(cond)}) and returns a data frame with one
+#'   row for each stack frame and the columns \code{num} (stack frame number),
+#'   \code{call} (a function name or similar), and \code{loc} (source file path
+#'   and line number, if available). It was deprecated after shiny 1.0.5 because
+#'   it doesn't support deep stack traces.
+#' @rdname stacktrace
+#' @export
+extractStackTrace <- function(calls,
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+  
+  shinyDeprecated(NULL,
+    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
+    version = "1.0.5")
+
+  srcrefs <- getSrcRefs(calls)
+  if (offset) {
+    # Offset calls vs. srcrefs by 1 to make them more intuitive.
+    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
+    # the definition of foo().
+    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
+  }
+  calls <- setSrcRefs(calls, srcrefs)
+
+  callnames <- getCallNames(calls)
+
+  # Hide and show parts of the callstack based on ..stacktrace(on|off)..
+  if (full) {
+    toShow <- rep.int(TRUE, length(calls))
+  } else {
+    # Remove stop(), .handleSimpleError(), and h() calls from the end of
+    # the calls--they don't add any helpful information. But only remove
+    # the last *contiguous* block of them, and then, only if they are the
+    # last thing in the calls list.
+    hideable <- callnames %in% c("stop", ".handleSimpleError", "h")
+    # What's the last that *didn't* match stop/.handleSimpleError/h?
+    lastGoodCall <- max(which(!hideable))
+    toRemove <- length(calls) - lastGoodCall
+    # But don't remove more than 5 levels--that's an indication we might
+    # have gotten it wrong, I guess
+    if (toRemove > 0 && toRemove < 5) {
+      calls <- utils::head(calls, -toRemove)
+      callnames <- utils::head(callnames, -toRemove)
+    }
+
+    # This uses a ref-counting scheme. It might make sense to switch this
+    # to a toggling scheme, so the most recent ..stacktrace(on|off)..
+    # directive wins, regardless of what came before it.
+    # Also explicitly remove ..stacktraceon.. because it can appear with
+    # score > 0 but still should never be shown.
+    score <- rep.int(0, length(callnames))
+    score[callnames == "..stacktraceoff.."] <- -1
+    score[callnames == "..stacktraceon.."] <- 1
+    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
+
+    # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're
+    # just internals for tryCatch
+    toShow <- toShow & !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList"))
+  }
+  calls <- calls[toShow]
+
+  calls <- rev(calls) # Show in traceback() order
+  index <- rev(which(toShow))
+  width <- floor(log10(max(index))) + 1
+
+  data.frame(
+    num = index,
+    call = getCallNames(calls),
+    loc = getLocs(calls),
+    category = getCallCategories(calls),
+    stringsAsFactors = FALSE
+  )
+}
+
+stripStackTraces <- function(stackTraces, values = FALSE) {
+  score <- 1L  # >=1: show, <=0: hide
+  lapply(seq_along(stackTraces), function(i) {
+    res <- stripOneStackTrace(stackTraces[[i]], i != 1, score)
+    score <<- res$score
+    toShow <- as.logical(res$trace)
+    if (values) {
+      as.character(stackTraces[[i]][toShow])
+    } else {
+      as.logical(toShow)
+    }
+  })
+}
+
+stripOneStackTrace <- function(stackTrace, truncateFloor, startingScore) {
+  prefix <- logical(0)
+  if (truncateFloor) {
+    indexOfFloor <- utils::tail(which(stackTrace == "..stacktracefloor.."), 1)
+    if (length(indexOfFloor)) {
+      stackTrace <- stackTrace[(indexOfFloor+1L):length(stackTrace)]
+      prefix <- rep_len(FALSE, indexOfFloor)
+    }
+  }
+  
+  if (length(stackTrace) == 0) {
+    return(list(score = startingScore, character(0)))
+  }
+  
+  score <- rep.int(0L, length(stackTrace))
+  score[stackTrace == "..stacktraceon.."] <- 1L
+  score[stackTrace == "..stacktraceoff.."] <- -1L
+  score <- startingScore + cumsum(score)
+  
+  toShow <- score > 0 & !(stackTrace %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
+  
+  
+  list(score = utils::tail(score, 1), trace = c(prefix, toShow))
+}
+
+# Given sys.parents() (which corresponds to sys.calls()), return a logical index
+# that prunes each subtree so that only the final branch remains. The result,
+# when applied to sys.calls(), is a linear list of calls without any "wrapper"
+# functions like tryCatch, try, with, hybrid_chain, etc. While these are often
+# part of the active call stack, they rarely are helpful when trying to identify
+# a broken bit of code.
+pruneStackTrace <- function(parents) {
+  # Detect nodes that are not the last child. This is necessary, but not
+  # sufficient; we also need to drop nodes that are the last child, but one of
+  # their ancestors is not.
+  is_dupe <- duplicated(parents, fromLast = TRUE)
+  
+  # The index of the most recently seen node that was actually kept instead of
+  # dropped.
+  current_node <- 0
+  
+  # Loop over the parent indices. Anything that is not parented by current_node
+  # (a.k.a. last-known-good node), or is a dupe, can be discarded. Anything that
+  # is kept becomes the new current_node.
+  include <- vapply(seq_along(parents), function(i) {
+    if (!is_dupe[[i]] && parents[[i]] == current_node) {
+      current_node <<- i
+      TRUE
+    } else {
+      FALSE
+    }
+  }, FUN.VALUE = logical(1))
+  
+  include
+}
+
+dropTrivialFrames <- function(callnames) {
+  # Remove stop(), .handleSimpleError(), and h() calls from the end of
+  # the calls--they don't add any helpful information. But only remove
+  # the last *contiguous* block of them, and then, only if they are the
+  # last thing in the calls list.
+  hideable <- callnames %in% c(".handleSimpleError", "h", "base$wrapOnFulfilled")
+  # What's the last that *didn't* match stop/.handleSimpleError/h?
+  lastGoodCall <- max(which(!hideable))
+  toRemove <- length(callnames) - lastGoodCall
+  
+  c(
+    rep_len(TRUE, length(callnames) - toRemove),
+    rep_len(FALSE, toRemove)
+  )
+}
+
+offsetSrcrefs <- function(calls, offset = TRUE) {
+  if (offset) {
+    srcrefs <- getSrcRefs(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))
+    
+    calls <- setSrcRefs(calls, srcrefs)
+  }
+  
+  calls
+}
+
+#' @details \code{formatStackTrace} is similar to \code{extractStackTrace}, but
+#'   it returns a preformatted character vector instead of a data frame. It was
+#'   deprecated after shiny 1.0.5 because it doesn't support deep stack traces.
+#' @param indent A string to prefix every line of the stack trace.
+#' @rdname stacktrace
+#' @export
+formatStackTrace <- function(calls, indent = "    ",
+  full = getOption("shiny.fullstacktrace", FALSE),
+  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+
+  shinyDeprecated(NULL,
+    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
+    version = "1.0.5")
+  
+  st <- extractStackTrace(calls, full = full, offset = offset)
+  if (nrow(st) == 0) {
+    return(character(0))
+  }
+
+  width <- floor(log10(max(st$num))) + 1
+  paste0(
+    indent,
+    formatC(st$num, width = width),
+    ": ",
+    mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+      if (category == "pkg")
+        crayon::silver(name)
+      else if (category == "user")
+        crayon::blue$bold(name)
+      else
+        crayon::white(name)
+    })
+  )
+}
+
+getSrcRefs <- function(calls) {
+  lapply(calls, function(call) {
+    attr(call, "srcref", exact = TRUE)
+  })
+}
+
+setSrcRefs <- function(calls, srcrefs) {
+  mapply(function(call, srcref) {
+    structure(call, srcref = srcref)
+  }, calls, srcrefs)
+}
+
+stripStackTrace <- function(cond) {
+  conditionStackTrace(cond) <- NULL
+}
+
+#' @details \code{conditionStackTrace} and \code{conditionStackTrace<-} are
+#'   accessor functions for getting/setting stack traces on conditions.
+#'
+#' @param cond A condition that may have previously been annotated by
+#'   \code{captureStackTraces} (or \code{withLogErrors}).
+#' @rdname stacktrace
+#' @export
+conditionStackTrace <- function(cond) {
+  attr(cond, "stack.trace", exact = TRUE)
+}
+
+#' @param value The stack trace value to assign to the condition.
+#' @rdname stacktrace
+#' @export
+`conditionStackTrace<-` <- function(cond, value) {
+  attr(cond, "stack.trace") <- value
+  invisible(cond)
+}
+
+#' @details The two functions \code{..stacktraceon..} and
+#'   \code{..stacktraceoff..} have no runtime behavior during normal execution;
+#'   they exist only to create artifacts on the stack trace (sys.call()) that
+#'   instruct the stack trace pretty printer what parts of the stack trace are
+#'   interesting or not. The initial state is 1 and we walk from the outermost
+#'   call inwards. Each ..stacktraceoff.. decrements the state by one, and each
+#'   ..stacktraceon.. increments the state by one. Any stack trace frame whose
+#'   value is less than 1 is hidden, and finally, the ..stacktraceon.. and
+#'   ..stacktraceoff.. calls themselves are hidden too.
+#'
+#' @rdname stacktrace
+#' @export
+..stacktraceon.. <- function(expr) expr
+#' @rdname stacktrace
+#' @export
+..stacktraceoff.. <- function(expr) expr
+
+..stacktracefloor.. <- function(expr) expr

R/diagnose.R

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

R/fileupload.R

@@ -20,6 +20,18 @@
 # form upload, i.e. traditional HTTP POST-based file upload) doesn't work with
 # the websockets package's HTTP server at the moment.
 
+# @description Returns a file's extension, with a leading dot, if one can be
+#   found. A valid extension contains only alphanumeric characters. If there is
+#   no extension, or if it contains non-alphanumeric characters, an empty
+#   string is returned.
+# @param x character vector giving file paths.
+# @return The extension of \code{x}, with a leading dot, if one was found.
+#   Otherwise, an empty character vector.
+maybeGetExtension <- function(x) {
+  ext <- tools::file_ext(x)
+  ifelse(ext == "", ext, paste0(".", ext))
+}
+
 FileUploadOperation <- R6Class(
   'FileUploadOperation',
   portable = FALSE,
@@ -52,8 +64,9 @@ FileUploadOperation <- R6Class(
       .currentFileInfo <<- file
       .pendingFileInfos <<- tail(.pendingFileInfos, -1)
 
-      filename <- file.path(.dir, as.character(length(.files$name)))
-      row <- data.frame(name=file$name, size=file$size, type=file$type,
+      fileBasename <- basename(.currentFileInfo$name)
+      filename <- file.path(.dir, paste0(as.character(length(.files$name)), maybeGetExtension(fileBasename)))
+      row <- data.frame(name=fileBasename, size=file$size, type=file$type,
                         datapath=filename, stringsAsFactors=FALSE)
 
       if (length(.files$name) == 0)
@@ -81,33 +94,47 @@ FileUploadOperation <- R6Class(
 #' @include map.R
 FileUploadContext <- R6Class(
   'FileUploadContext',
-  portable = FALSE,
   class = FALSE,
+  private = list(
+    basedir = character(0),
+    operations = 'Map',
+    ids = character(0)  # Keep track of all ids used for file uploads
+  ),
   public = list(
-    .basedir = character(0),
-    .operations = 'Map',
-
     initialize = function(dir=tempdir()) {
-      .basedir <<- dir
-      .operations <<- Map$new()
+      private$basedir <- dir
+      private$operations <- Map$new()
     },
     createUploadOperation = function(fileInfos) {
       while (TRUE) {
-        id <- paste(as.raw(p_runif(12, min=0, max=0xFF)), collapse='')
-        dir <- file.path(.basedir, id)
+        id <- createUniqueId(12)
+        private$ids <- c(private$ids, id)
+        dir <- file.path(private$basedir, id)
         if (!dir.create(dir))
           next
 
         op <- FileUploadOperation$new(self, id, dir, fileInfos)
-        .operations$set(id, op)
+        private$operations$set(id, op)
         return(id)
       }
     },
     getUploadOperation = function(jobId) {
-      .operations$get(jobId)
+      private$operations$get(jobId)
     },
     onJobFinished = function(jobId) {
-      .operations$remove(jobId)
+      private$operations$remove(jobId)
+    },
+    # Remove the directories containing file uploads; this is to be called when
+    # a session ends.
+    rmUploadDirs = function() {
+      # Make sure all_paths is underneath the tempdir()
+      if (!grepl(normalizePath(tempdir()), normalizePath(private$basedir), fixed = TRUE)) {
+        stop("Won't remove upload path ", private$basedir,
+          "because it is not under tempdir(): ", tempdir())
+      }
+
+      all_paths <- file.path(private$basedir, private$ids)
+      unlink(all_paths, recursive = TRUE)
     }
   )
 )

R/globals.R

@@ -5,5 +5,19 @@
   # R's lazy-loading package scheme causes the private seed to be cached in the
   # package itself, making our PRNG completely deterministic. This line resets
   # the private seed during load.
-  withPrivateSeed(reinitializeSeed())
+  withPrivateSeed(set.seed(NULL))
+}
+
+.onAttach <- function(libname, pkgname) {
+  # Check for htmlwidgets version, if installed. As of Shiny 0.12.0 and
+  # htmlwidgets 0.4, both packages switched from RJSONIO to jsonlite. Because of
+  # this change, Shiny 0.12.0 will work only with htmlwidgets >= 0.4, and vice
+  # versa.
+  if (system.file(package = "htmlwidgets") != "" &&
+      utils::packageVersion("htmlwidgets") < "0.4") {
+    packageStartupMessage(
+      "This version of Shiny is designed to work with htmlwidgets >= 0.4. ",
+      "Please upgrade your version of htmlwidgets."
+    )
+  }
 }

R/graph.R

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

R/history.R

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

R/html-deps.R

@@ -6,13 +6,18 @@
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link{htmlDependency}}. If the \code{src} value is named, then
-#'   \code{href} and/or \code{file} names must be present.
+#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named,
+#'   then \code{href} and/or \code{file} names must be present.
+#' @param scrubFile If TRUE (the default), remove \code{src$file} for the
+#'   dependency. This prevents the local file path from being sent to the client
+#'   when dynamic web dependencies are used. If FALSE, don't remove
+#'   \code{src$file}. Setting it to FALSE should be needed only in very unusual
+#'   cases.
 #'
 #' @return A single HTML dependency object that has an \code{href}-named element
 #'   in its \code{src}.
 #' @export
-createWebDependency <- function(dependency) {
+createWebDependency <- function(dependency, scrubFile = TRUE) {
   if (is.null(dependency))
     return(NULL)
 
@@ -25,5 +30,27 @@ createWebDependency <- function(dependency) {
     dependency$src$href <- prefix
   }
 
+  # Don't leak local file path to client
+  if (scrubFile)
+    dependency$src$file <- NULL
+
   return(dependency)
 }
+
+
+# Given a Shiny tag object, process singletons and dependencies. Returns a list
+# with rendered HTML and dependency objects.
+processDeps <- function(tags, session) {
+  ui <- takeSingletons(tags, session$singletons, desingleton=FALSE)$ui
+  ui <- surroundSingletons(ui)
+  dependencies <- lapply(
+    resolveDependencies(findDependencies(ui)),
+    createWebDependency
+  )
+  names(dependencies) <- NULL
+
+  list(
+    html = doRenderTags(ui),
+    deps = dependencies
+  )
+}

R/htmltools.R

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

R/image-interact-opts.R

@@ -0,0 +1,139 @@
+#' Create an object representing click options
+#'
+#' This generates an object representing click options, to be passed as the
+#' \code{click} argument of \code{\link{imageOutput}} or
+#' \code{\link{plotOutput}}.
+#'
+#' @param id Input value name. For example, if the value is \code{"plot_click"},
+#'   then the click coordinates will be available as \code{input$plot_click}.
+#' @param clip Should the click area be clipped to the plotting area? If FALSE,
+#'   then the server will receive click events even when the mouse is outside
+#'   the plotting area, as long as it is still inside the image.
+#' @export
+clickOpts <- function(id = NULL, clip = TRUE) {
+  if (is.null(id))
+    stop("id must not be NULL")
+
+  list(
+    id = id,
+    clip = clip
+  )
+}
+
+
+#' Create an object representing double-click options
+#'
+#' This generates an object representing dobule-click options, to be passed as
+#' the \code{dblclick} argument of \code{\link{imageOutput}} or
+#' \code{\link{plotOutput}}.
+#'
+#' @param id Input value name. For example, if the value is
+#'   \code{"plot_dblclick"}, then the click coordinates will be available as
+#'   \code{input$plot_dblclick}.
+#' @param clip Should the click area be clipped to the plotting area? If FALSE,
+#'   then the server will receive double-click events even when the mouse is
+#'   outside the plotting area, as long as it is still inside the image.
+#' @param delay Maximum delay (in ms) between a pair clicks for them to be
+#'   counted as a double-click.
+#' @export
+dblclickOpts <- function(id = NULL, clip = TRUE, delay = 400) {
+  if (is.null(id))
+    stop("id must not be NULL")
+
+  list(
+    id = id,
+    clip = clip,
+    delay = delay
+  )
+}
+
+#' Create an object representing hover options
+#'
+#' This generates an object representing hovering options, to be passed as the
+#' \code{hover} argument of \code{\link{imageOutput}} or
+#' \code{\link{plotOutput}}.
+#'
+#' @param id Input value name. For example, if the value is \code{"plot_hover"},
+#'   then the hover coordinates will be available as \code{input$plot_hover}.
+#' @param delay How long to delay (in milliseconds) when debouncing or
+#'   throttling, before sending the mouse location to the server.
+#' @param delayType The type of algorithm for limiting the number of hover
+#'   events. Use \code{"throttle"} to limit the number of hover events to one
+#'   every \code{delay} milliseconds. Use \code{"debounce"} to suspend events
+#'   while the cursor is moving, and wait until the cursor has been at rest for
+#'   \code{delay} milliseconds before sending an event.
+#' @param clip Should the hover area be clipped to the plotting area? If FALSE,
+#'   then the server will receive hover events even when the mouse is outside
+#'   the plotting area, as long as it is still inside the image.
+#' @param nullOutside If \code{TRUE} (the default), the value will be set to
+#'   \code{NULL} when the mouse exits the plotting area. If \code{FALSE}, the
+#'   value will stop changing when the cursor exits the plotting area.
+#' @export
+hoverOpts <- function(id = NULL, delay = 300,
+                      delayType = c("debounce", "throttle"), clip = TRUE,
+                      nullOutside = TRUE) {
+  if (is.null(id))
+    stop("id must not be NULL")
+
+  list(
+    id = id,
+    delay = delay,
+    delayType = match.arg(delayType),
+    clip = clip,
+    nullOutside = nullOutside
+  )
+}
+
+#' Create an object representing brushing options
+#'
+#' This generates an object representing brushing options, to be passed as the
+#' \code{brush} argument of \code{\link{imageOutput}} or
+#' \code{\link{plotOutput}}.
+#'
+#' @param id Input value name. For example, if the value is \code{"plot_brush"},
+#'   then the coordinates will be available as \code{input$plot_brush}. Multiple
+#'   \code{imageOutput}/\code{plotOutput} calls may share the same \code{id}
+#'   value; brushing one image or plot will cause any other brushes with the
+#'   same \code{id} to disappear.
+#' @param fill Fill color of the brush.
+#' @param stroke Outline color of the brush.
+#' @param opacity Opacity of the brush
+#' @param delay How long to delay (in milliseconds) when debouncing or
+#'   throttling, before sending the brush data to the server.
+#' @param delayType The type of algorithm for limiting the number of brush
+#'   events. Use \code{"throttle"} to limit the number of brush events to one
+#'   every \code{delay} milliseconds. Use \code{"debounce"} to suspend events
+#'   while the cursor is moving, and wait until the cursor has been at rest for
+#'   \code{delay} milliseconds before sending an event.
+#' @param clip Should the brush area be clipped to the plotting area? If FALSE,
+#'   then the user will be able to brush outside the plotting area, as long as
+#'   it is still inside the image.
+#' @param direction The direction for brushing. If \code{"xy"}, the brush can be
+#'   drawn and moved in both x and y directions. If \code{"x"}, or \code{"y"},
+#'   the brush wil work horizontally or vertically.
+#' @param resetOnNew When a new image is sent to the browser (via
+#'   \code{\link{renderImage}}), should the brush be reset? The default,
+#'   \code{FALSE}, is useful if you want to update the plot while keeping the
+#'   brush. Using \code{TRUE} is useful if you want to clear the brush whenever
+#'   the plot is updated.
+#' @export
+brushOpts <- function(id = NULL, fill = "#9cf", stroke = "#036",
+                      opacity = 0.25, delay = 300,
+                      delayType = c("debounce", "throttle"), clip = TRUE,
+                      direction = c("xy", "x", "y"),
+                      resetOnNew = FALSE) {
+  if (is.null(id))
+    stop("id must not be NULL")
+
+  list(
+    id = id,
+    fill = fill,
+    stroke = stroke,
+    opacity = opacity,
+    delay = delay,
+    delayType = match.arg(delayType),
+    clip = clip,
+    direction = match.arg(direction),
+    resetOnNew = resetOnNew
+  )
+}

R/image-interact.R

@@ -0,0 +1,496 @@
+#' Find rows of data that are selected by a brush
+#'
+#' This function returns rows from a data frame which are under a brush used
+#' with \code{\link{plotOutput}}.
+#'
+#' It is also possible for this function to return all rows from the input data
+#' frame, but with an additional column \code{selected_}, which indicates which
+#' rows of the input data frame are selected by the brush (\code{TRUE} for
+#' selected, \code{FALSE} for not-selected). This is enabled by setting
+#' \code{allRows=TRUE} option.
+#'
+#' The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2}
+#' arguments specify which columns in the data correspond to the x variable, y
+#' variable, and panel variables of the plot. For example, if your plot is
+#' \code{plot(x=cars$speed, y=cars$dist)}, and your brush is named
+#' \code{"cars_brush"}, then you would use \code{brushedPoints(cars,
+#' input$cars_brush, "speed", "dist")}.
+#'
+#' For plots created with ggplot2, it should not be necessary to specify the
+#' column names; that information will already be contained in the brush,
+#' provided that variables are in the original data, and not computed. For
+#' example, with \code{ggplot(cars, aes(x=speed, y=dist)) + geom_point()}, you
+#' could use \code{brushedPoints(cars, input$cars_brush)}. If, however, you use
+#' a computed column, like \code{ggplot(cars, aes(x=speed/2, y=dist)) +
+#' geom_point()}, then it will not be able to automatically extract column names
+#' and filter on them. If you want to use this function to filter data, it is
+#' recommended that you not use computed columns; instead, modify the data
+#' first, and then make the plot with "raw" columns in the modified data.
+#'
+#' If a specified x or y column is a factor, then it will be coerced to an
+#' integer vector. If it is a character vector, then it will be coerced to a
+#' factor and then integer vector. This means that the brush will be considered
+#' to cover a given character/factor value when it covers the center value.
+#'
+#' If the brush is operating in just the x or y directions (e.g., with
+#' \code{brushOpts(direction = "x")}, then this function will filter out points
+#' using just the x or y variable, whichever is appropriate.
+#'
+#' @param brush The data from a brush, such as \code{input$plot_brush}.
+#' @param df A data frame from which to select rows.
+#' @param xvar,yvar A string with the name of the variable on the x or y axis.
+#'   This must also be the name of a column in \code{df}. If absent, then this
+#'   function will try to infer the variable from the brush (only works for
+#'   ggplot2).
+#' @param panelvar1,panelvar2 Each of these is a string with the name of a panel
+#'   variable. For example, if with ggplot2, you facet on a variable called
+#'   \code{cyl}, then you can use \code{"cyl"} here. However, specifying the
+#'   panel variable should not be necessary with ggplot2; Shiny should be able
+#'   to auto-detect the panel variable.
+#' @param allRows If \code{FALSE} (the default) return a data frame containing
+#'   the selected rows. If \code{TRUE}, the input data frame will have a new
+#'   column, \code{selected_}, which indicates whether the row was inside the
+#'   brush (\code{TRUE}) or outside the brush (\code{FALSE}).
+#'
+#' @seealso \code{\link{plotOutput}} for example usage.
+#' @export
+brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
+                          panelvar1 = NULL, panelvar2 = NULL,
+                          allRows = FALSE) {
+  if (is.null(brush)) {
+    if (allRows)
+      df$selected_ <- FALSE
+    else
+      df <- df[0, , drop = FALSE]
+
+    return(df)
+  }
+
+  if (is.null(brush$xmin)) {
+    stop("brushedPoints requires a brush object with xmin, xmax, ymin, and ymax.")
+  }
+
+  # Which direction(s) the brush is selecting over. Direction can be 'x', 'y',
+  # or 'xy'.
+  use_x <- grepl("x", brush$direction)
+  use_y <- grepl("y", brush$direction)
+
+  # Try to extract vars from brush object
+  xvar      <- xvar      %OR% brush$mapping$x
+  yvar      <- yvar      %OR% brush$mapping$y
+  panelvar1 <- panelvar1 %OR% brush$mapping$panelvar1
+  panelvar2 <- panelvar2 %OR% brush$mapping$panelvar2
+
+  # Filter out x and y values
+  keep_rows <- rep(TRUE, nrow(df))
+  if (use_x) {
+    if (is.null(xvar))
+      stop("brushedPoints: not able to automatically infer `xvar` from brush")
+    if (!(xvar %in% names(df)))
+      stop("brushedPoints: `xvar` ('", xvar ,"')  not in names of input")
+    # Extract data values from the data frame
+    x <- asNumber(df[[xvar]])
+    keep_rows <- keep_rows & (x >= brush$xmin & x <= brush$xmax)
+  }
+  if (use_y) {
+    if (is.null(yvar))
+      stop("brushedPoints: not able to automatically infer `yvar` from brush")
+    if (!(yvar %in% names(df)))
+      stop("brushedPoints: `yvar` ('", yvar ,"') not in names of input")
+    y <- asNumber(df[[yvar]])
+    keep_rows <- keep_rows & (y >= brush$ymin & y <= brush$ymax)
+  }
+
+  # Find which rows are matches for the panel vars (if present)
+  if (!is.null(panelvar1))
+    keep_rows <- keep_rows & panelMatch(brush$panelvar1, df[[panelvar1]])
+  if (!is.null(panelvar2))
+    keep_rows <- keep_rows & panelMatch(brush$panelvar2, df[[panelvar2]])
+
+  if (allRows) {
+    df$selected_ <- keep_rows
+    df
+  } else {
+    df[keep_rows, , drop = FALSE]
+  }
+}
+
+# The `brush` data structure will look something like the examples below.
+# For base graphics, `mapping` is empty, and there are no panelvars:
+# List of 8
+#  $ xmin   : num 3.73
+#  $ xmax   : num 4.22
+#  $ ymin   : num 13.9
+#  $ ymax   : num 19.8
+#  $ coords_css:List of 4
+#   ..$ xmin: int 260
+#   ..$ xmax: int 298
+#   ..$ ymin: num 112
+#   ..$ ymax: num 205
+#  $ coords_img:List of 4
+#   ..$ xmin: int 325
+#   ..$ xmax: num 372
+#   ..$ ymin: num 140
+#   ..$ ymax: num 257
+#  $ img_css_ratio:List of 2
+#   ..$ x: num 1.25
+#   ..$ y: num 1.25
+#  $ mapping: Named list()
+#  $ domain :List of 4
+#   ..$ left  : num 1.36
+#   ..$ right : num 5.58
+#   ..$ bottom: num 9.46
+#   ..$ top   : num 34.8
+#  $ range  :List of 4
+#   ..$ left  : num 58
+#   ..$ right : num 429
+#   ..$ bottom: num 226
+#   ..$ top   : num 58
+#  $ log    :List of 2
+#   ..$ x: NULL
+#   ..$ y: NULL
+#  $ direction: chr "y"
+#
+# For ggplot2, the mapping vars usually will be included, and if faceting is
+# used, they will be listed as panelvars:
+# List of 10
+#  $ xmin     : num 3.18
+#  $ xmax     : num 3.78
+#  $ ymin     : num 17.1
+#  $ ymax     : num 20.4
+#  $ panelvar1: int 6
+#  $ panelvar2: int 0
+#  $ coords_css:List of 4
+#   ..$ xmin: int 260
+#   ..$ xmax: int 298
+#   ..$ ymin: num 112
+#   ..$ ymax: num 205
+#  $ coords_img:List of 4
+#   ..$ xmin: int 325
+#   ..$ xmax: num 372
+#   ..$ ymin: num 140
+#   ..$ ymax: num 257
+#  $ img_css_ratio:List of 2
+#   ..$ x: num 1.25
+#   ..$ y: num 1.25
+#  $ mapping  :List of 4
+#   ..$ x        : chr "wt"
+#   ..$ y        : chr "mpg"
+#   ..$ panelvar1: chr "cyl"
+#   ..$ panelvar2: chr "am"
+#  $ domain   :List of 4
+#   ..$ left  : num 1.32
+#   ..$ right : num 5.62
+#   ..$ bottom: num 9.22
+#   ..$ top   : num 35.1
+#  $ range    :List of 4
+#   ..$ left  : num 172
+#   ..$ right : num 300
+#   ..$ bottom: num 144
+#   ..$ top   : num 28.5
+#  $ log      :List of 2
+#   ..$ x: NULL
+#   ..$ y: NULL
+#  $ direction: chr "y"
+
+
+#'Find rows of data that are near a click/hover/double-click
+#'
+#'This function returns rows from a data frame which are near a click, hover, or
+#'double-click, when used with \code{\link{plotOutput}}. The rows will be sorted
+#'by their distance to the mouse event.
+#'
+#'It is also possible for this function to return all rows from the input data
+#'frame, but with an additional column \code{selected_}, which indicates which
+#'rows of the input data frame are selected by the brush (\code{TRUE} for
+#'selected, \code{FALSE} for not-selected). This is enabled by setting
+#'\code{allRows=TRUE} option. If this is used, the resulting data frame will not
+#'be sorted by distance to the mouse event.
+#'
+#'The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2} arguments
+#'specify which columns in the data correspond to the x variable, y variable,
+#'and panel variables of the plot. For example, if your plot is
+#'\code{plot(x=cars$speed, y=cars$dist)}, and your click variable is named
+#'\code{"cars_click"}, then you would use \code{nearPoints(cars,
+#'input$cars_brush, "speed", "dist")}.
+#'
+#'@inheritParams brushedPoints
+#'@param coordinfo The data from a mouse event, such as \code{input$plot_click}.
+#'@param threshold A maxmimum distance to the click point; rows in the data
+#'  frame where the distance to the click is less than \code{threshold} will be
+#'  returned.
+#'@param maxpoints Maximum number of rows to return. If NULL (the default),
+#'  return all rows that are within the threshold distance.
+#'@param addDist If TRUE, add a column named \code{dist_} that contains the
+#'  distance from the coordinate to the point, in pixels. When no mouse event
+#'  has yet occured, the value of \code{dist_} will be \code{NA}.
+#'@param allRows If \code{FALSE} (the default) return a data frame containing
+#'  the selected rows. If \code{TRUE}, the input data frame will have a new
+#'  column, \code{selected_}, which indicates whether the row was inside the
+#'  selected by the mouse event (\code{TRUE}) or not (\code{FALSE}).
+#'
+#'@seealso \code{\link{plotOutput}} for more examples.
+#'
+#' @examples
+#' \dontrun{
+#' # Note that in practice, these examples would need to go in reactives
+#' # or observers.
+#'
+#' # This would select all points within 5 pixels of the click
+#' nearPoints(mtcars, input$plot_click)
+#'
+#' # Select just the nearest point within 10 pixels of the click
+#' nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
+#'
+#' }
+#'@export
+nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
+                       panelvar1 = NULL, panelvar2 = NULL,
+                       threshold = 5, maxpoints = NULL, addDist = FALSE,
+                       allRows = FALSE) {
+  if (is.null(coordinfo)) {
+    if (addDist)
+      df$dist_ <- NA_real_
+
+    if (allRows)
+      df$selected_ <- FALSE
+    else
+      df <- df[0, , drop = FALSE]
+
+    return(df)
+  }
+
+  if (is.null(coordinfo$x)) {
+    stop("nearPoints requires a click/hover/double-click object with x and y values.")
+  }
+
+  # Try to extract vars from coordinfo object
+  xvar      <- xvar      %OR% coordinfo$mapping$x
+  yvar      <- yvar      %OR% coordinfo$mapping$y
+  panelvar1 <- panelvar1 %OR% coordinfo$mapping$panelvar1
+  panelvar2 <- panelvar2 %OR% coordinfo$mapping$panelvar2
+
+  if (is.null(xvar))
+    stop("nearPoints: not able to automatically infer `xvar` from coordinfo")
+  if (is.null(yvar))
+    stop("nearPoints: not able to automatically infer `yvar` from coordinfo")
+
+  if (!(xvar %in% names(df)))
+    stop("nearPoints: `xvar` ('", xvar ,"')  not in names of input")
+  if (!(yvar %in% names(df)))
+    stop("nearPoints: `yvar` ('", yvar ,"')  not in names of input")
+
+  # Extract data values from the data frame
+  x <- asNumber(df[[xvar]])
+  y <- asNumber(df[[yvar]])
+
+  # Get the coordinates of the point (in img pixel coordinates)
+  point_img <- coordinfo$coords_img
+
+  # Get coordinates of data points (in img pixel coordinates)
+  data_img <- scaleCoords(x, y, coordinfo)
+
+  # Get x/y distances (in css coordinates)
+  dist_css <- list(
+    x = (data_img$x - point_img$x) / coordinfo$img_css_ratio$x,
+    y = (data_img$y - point_img$y) / coordinfo$img_css_ratio$y
+  )
+
+  # Distances of data points to the target point, in css pixels.
+  dists <- sqrt(dist_css$x^2 + dist_css$y^2)
+
+  if (addDist)
+    df$dist_ <- dists
+
+  keep_rows <- (dists <= threshold)
+
+  # Find which rows are matches for the panel vars (if present)
+  if (!is.null(panelvar1))
+    keep_rows <- keep_rows & panelMatch(coordinfo$panelvar1, df[[panelvar1]])
+  if (!is.null(panelvar2))
+    keep_rows <- keep_rows & panelMatch(coordinfo$panelvar2, df[[panelvar2]])
+
+  # Track the indices to keep
+  keep_idx <- which(keep_rows)
+
+  # Order by distance
+  dists <- dists[keep_idx]
+  keep_idx <- keep_idx[order(dists)]
+
+  # Keep max number of rows
+  if (!is.null(maxpoints) && length(keep_idx) > maxpoints) {
+    keep_idx <- keep_idx[seq_len(maxpoints)]
+  }
+
+  if (allRows) {
+    # Add selected_ column if needed
+    df$selected_ <- FALSE
+    df$selected_[keep_idx] <- TRUE
+
+  } else {
+    # If we don't keep all rows, return just the selected rows, sorted by
+    # distance.
+    df <- df[keep_idx, , drop = FALSE]
+  }
+
+  df
+}
+
+# The coordinfo data structure will look something like the examples below.
+# For base graphics, `mapping` is empty, and there are no panelvars:
+# List of 7
+#  $ x         : num 4.37
+#  $ y         : num 12
+#  $ coords_css:List of 2
+#   ..$ x: int 286
+#   ..$ y: int 192
+#  $ coords_img:List of 2
+#   ..$ x: num 358
+#   ..$ y: int 240
+#  $ img_css_ratio:List of 2
+#   ..$ x: num 1.25
+#   ..$ y: num 1.25
+#  $ mapping   : Named list()
+#  $ domain    :List of 4
+#   ..$ left  : num 1.36
+#   ..$ right : num 5.58
+#   ..$ bottom: num 9.46
+#   ..$ top   : num 34.8
+#  $ range     :List of 4
+#   ..$ left  : num 58
+#   ..$ right : num 429
+#   ..$ bottom: num 226
+#   ..$ top   : num 58
+#  $ log       :List of 2
+#   ..$ x: NULL
+#   ..$ y: NULL
+#  $ .nonce    : num 0.343
+#
+# For ggplot2, the mapping vars usually will be included, and if faceting is
+# used, they will be listed as panelvars:
+# List of 9
+#  $ x         : num 3.78
+#  $ y         : num 17.1
+#  $ coords_css:List of 2
+#   ..$ x: int 286
+#   ..$ y: int 192
+#  $ coords_img:List of 2
+#   ..$ x: num 358
+#   ..$ y: int 240
+#  $ img_css_ratio:List of 2
+#   ..$ x: num 1.25
+#   ..$ y: num 1.25
+#  $ panelvar1 : int 6
+#  $ panelvar2 : int 0
+#  $ mapping   :List of 4
+#   ..$ x        : chr "wt"
+#   ..$ y        : chr "mpg"
+#   ..$ panelvar1: chr "cyl"
+#   ..$ panelvar2: chr "am"
+#  $ domain    :List of 4
+#   ..$ left  : num 1.32
+#   ..$ right : num 5.62
+#   ..$ bottom: num 9.22
+#   ..$ top   : num 35.1
+#  $ range     :List of 4
+#   ..$ left  : num 172
+#   ..$ right : num 300
+#   ..$ bottom: num 144
+#   ..$ top   : num 28.5
+#  $ log       :List of 2
+#   ..$ x: NULL
+#   ..$ y: NULL
+#  $ .nonce    : num 0.603
+
+
+
+# Coerce various types of variables to numbers. This works for Date, POSIXt,
+# characters, and factors. Used because the mouse coords are numeric.
+asNumber <- function(x) {
+  if (is.character(x)) x <- as.factor(x)
+  if (is.factor(x)) x <- as.integer(x)
+  as.numeric(x)
+}
+
+# Given a panelvar value and a vector x, return logical vector indicating which
+# items match the panelvar value. Because the panelvar value is always a
+# string but the vector could be numeric, it might be necessary to coerce the
+# panelvar to a number before comparing to the vector.
+panelMatch <- function(search_value, x) {
+  if (is.numeric(x)) search_value <- as.numeric(search_value)
+  x == search_value
+}
+
+#  ----------------------------------------------------------------------------
+# Scaling functions
+# These functions have direct analogs in Javascript code, except these are
+# vectorized for x and y.
+
+# Map a value x from a domain to a range. If clip is true, clip it to the
+# range.
+mapLinear <- function(x, domainMin, domainMax, rangeMin, rangeMax, clip = TRUE) {
+  factor <- (rangeMax - rangeMin) / (domainMax - domainMin)
+  val <- x - domainMin
+  newval <- (val * factor) + rangeMin
+
+  if (clip) {
+    maxval <- max(rangeMax, rangeMin)
+    minval <- min(rangeMax, rangeMin)
+    newval[newval > maxval] <- maxval
+    newval[newval < minval] <- minval
+  }
+  newval
+}
+
+# Scale val from domain to range. If logbase is present, use log scaling.
+scale1D <- function(val, domainMin, domainMax, rangeMin, rangeMax,
+                    logbase = NULL, clip = TRUE) {
+  if (!is.null(logbase))
+    val <- log(val, logbase)
+  mapLinear(val, domainMin, domainMax, rangeMin, rangeMax, clip)
+}
+
+# Inverse scale val, from range to domain. If logbase is present, use inverse
+# log (power) transformation.
+scaleInv1D <- function(val, domainMin, domainMax, rangeMin, rangeMax,
+                       logbase = NULL, clip = TRUE) {
+    res <- mapLinear(val, rangeMin, rangeMax, domainMin, domainMax, clip)
+    if (!is.null(logbase))
+      res <- logbase ^ res
+    res
+}
+
+# Scale x and y coordinates from domain to range, using information in
+# scaleinfo. scaleinfo must contain items $domain, $range, and $log. The
+# scaleinfo object corresponds to one element from the coordmap object generated
+# by getPrevPlotCoordmap or getGgplotCoordmap; it is the scaling information for
+# one panel in a plot.
+scaleCoords <- function(x, y, scaleinfo) {
+  if (is.null(scaleinfo))
+    return(NULL)
+
+  domain <- scaleinfo$domain
+  range <- scaleinfo$range
+  log <- scaleinfo$log
+
+  list(
+    x = scale1D(x, domain$left, domain$right, range$left, range$right, log$x),
+    y = scale1D(y, domain$bottom, domain$top, range$bottom, range$top, log$y)
+  )
+}
+
+# Inverse scale x and y coordinates from range to domain, using information in
+# scaleinfo.
+scaleInvCoords <- function(x, y, scaleinfo) {
+  if (is.null(scaleinfo))
+    return(NULL)
+
+  domain <- scaleinfo$domain
+  range <- scaleinfo$range
+  log <- scaleinfo$log
+
+  list(
+    x = scaleInv1D(x, domain$left, domain$right, range$left, range$right, log$x),
+    y = scaleInv1D(y, domain$bottom, domain$top, range$bottom, range$top, log$y)
+  )
+}

R/imageutils.R

@@ -1,3 +1,33 @@
+startPNG <- function(filename, width, height, res, ...) {
+  # If quartz is available, use png() (which will default to quartz).
+  # Otherwise, if the Cairo package is installed, use CairoPNG().
+  # Finally, if neither quartz nor Cairo, use png().
+  if (capabilities("aqua")) {
+    pngfun <- grDevices::png
+  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
+      nchar(system.file(package = "Cairo"))) {
+    pngfun <- Cairo::CairoPNG
+  } else {
+    pngfun <- grDevices::png
+  }
+
+  pngfun(filename=filename, width=width, height=height, res=res, ...)
+  # Call plot.new() so that even if no plotting operations are performed at
+  # least we have a blank background. N.B. we need to set the margin to 0
+  # temporarily before plot.new() because when the plot size is small (e.g.
+  # 200x50), we will get an error "figure margin too large", which is triggered
+  # by plot.new() with the default (large) margin. However, this does not
+  # guarantee user's code in func() will not trigger the error -- they may have
+  # to set par(mar = smaller_value) before they draw base graphics.
+  op <- graphics::par(mar = rep(0, 4))
+  tryCatch(
+    graphics::plot.new(),
+    finally = graphics::par(op)
+  )
+
+  grDevices::dev.cur()
+}
+
 #' Run a plotting function and save the output as a PNG
 #'
 #' This function returns the name of the PNG file that it generates. In
@@ -21,38 +51,51 @@
 #' @param width Width in pixels.
 #' @param height Height in pixels.
 #' @param res Resolution in pixels per inch. This value is passed to
-#'   \code{\link{png}}. Note that this affects the resolution of PNG rendering in
+#'   \code{\link[grDevices]{png}}. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
 #' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
 #'   These can be used to set the width, height, background color, etc.
-#'
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
-  # If quartz is available, use png() (which will default to quartz).
-  # Otherwise, if the Cairo package is installed, use CairoPNG().
-  # Finally, if neither quartz nor Cairo, use png().
-  if (capabilities("aqua")) {
-    pngfun <- png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
-             nchar(system.file(package = "Cairo"))) {
-    pngfun <- Cairo::CairoPNG
-  } else {
-    pngfun <- png
-  }
-
-  pngfun(filename=filename, width=width, height=height, res=res, ...)
-  # Call plot.new() so that even if no plotting operations are performed at
-  # least we have a blank background. N.B. we need to set the margin to 0
-  # temporarily before plot.new() because when the plot size is small (e.g.
-  # 200x50), we will get an error "figure margin too large", which is triggered
-  # by plot.new() with the default (large) margin. However, this does not
-  # guarantee user's code in func() will not trigger the error -- they may have
-  # to set par(mar = smaller_value) before they draw base graphics.
-  op <- par(mar = rep(0, 4))
-  tryCatch(plot.new(), finally = par(op))
-  dv <- dev.cur()
-  tryCatch(shinyCallingHandlers(func()), finally = dev.off(dv))
+  dv <- startPNG(filename, width, height, res, ...)
+  on.exit(grDevices::dev.off(dv), add = TRUE)
+  func()
 
   filename
 }
+
+#' @importFrom grDevices dev.set dev.cur
+createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
+  force(which)
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(...) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(...) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      old <- dev.cur()
+      dev.set(which)
+      on.exit(dev.set(old))
+
+      force(expr)
+    }
+  )
+}

R/input-action.R

@@ -0,0 +1,86 @@
+#' Action button/link
+#'
+#' Creates an action button or link whose value is initially zero, and increments by one
+#' each time it is pressed.
+#'
+#' @inheritParams textInput
+#' @param label The contents of the button or link--usually a text label, but
+#'   you could also use any other HTML, like an image.
+#' @param icon An optional \code{\link{icon}} to appear on the button.
+#' @param ... Named attributes to be applied to the button or link.
+#'
+#' @family input elements
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("obs", "Number of observations", 0, 1000, 500),
+#'   actionButton("goButton", "Go!"),
+#'   plotOutput("distPlot")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     # Take a dependency on input$goButton. This will run once initially,
+#'     # because the value changes from NULL to 0.
+#'     input$goButton
+#'
+#'     # Use isolate() to avoid dependency on input$obs
+#'     dist <- isolate(rnorm(input$obs))
+#'     hist(dist)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
+#'
+#' @seealso \code{\link{observeEvent}} and \code{\link{eventReactive}}
+#' @export
+actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
+
+  value <- restoreInput(id = inputId, default = NULL)
+
+  tags$button(id=inputId,
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    type="button",
+    class="btn btn-default action-button",
+    `data-val` = value,
+    list(validateIcon(icon), label),
+    ...
+  )
+}
+
+#' @rdname actionButton
+#' @export
+actionLink <- function(inputId, label, icon = NULL, ...) {
+  value <- restoreInput(id = inputId, default = NULL)
+
+  tags$a(id=inputId,
+    href="#",
+    class="action-button",
+    `data-val` = value,
+    list(validateIcon(icon), label),
+    ...
+  )
+}
+
+
+# Check that the icon parameter is valid:
+# 1) Check  if the user wants to actually add an icon:
+#    -- if icon=NULL, it means leave the icon unchanged
+#    -- if icon=character(0), it means don't add an icon or, more usefully,
+#       remove the previous icon
+# 2) If so, check that the icon has the right format (this does not check whether
+# it is a *real* icon - currently that would require a massive cross reference
+# with the "font-awesome" and the "glyphicon" libraries)
+validateIcon <- function(icon) {
+  if (is.null(icon) || identical(icon, character(0))) {
+    return(icon)
+  } else if (inherits(icon, "shiny.tag") && icon$name == "i") {
+    return(icon)
+  } else {
+    stop("Invalid icon. Use Shiny's 'icon()' function to generate a valid icon")
+  }
+}

R/input-checkbox.R

@@ -0,0 +1,40 @@
+#' Checkbox Input Control
+#'
+#' Create a checkbox that can be used to specify logical values.
+#'
+#' @inheritParams textInput
+#' @param value Initial value (\code{TRUE} or \code{FALSE}).
+#' @return A checkbox control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{checkboxGroupInput}}, \code{\link{updateCheckboxInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   checkboxInput("somevalue", "Some value", FALSE),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$somevalue })
+#' }
+#' shinyApp(ui, server)
+#' }
+#' @export
+checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
+
+  value <- restoreInput(id = inputId, default = value)
+
+  inputTag <- tags$input(id = inputId, type="checkbox")
+  if (!is.null(value) && value)
+    inputTag$attribs$checked <- "checked"
+
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    div(class = "checkbox",
+      tags$label(inputTag, tags$span(label))
+    )
+  )
+}

R/input-checkboxgroup.R

@@ -0,0 +1,100 @@
+#' Checkbox Group Input Control
+#'
+#' Create a group of checkboxes that can be used to toggle multiple choices
+#' independently. The server will receive the input as a character vector of the
+#' selected values.
+#'
+#' @inheritParams textInput
+#' @param choices List of values to show checkboxes for. If elements of the list
+#'   are named then that name rather than the value is displayed to the user. If
+#'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
+#'   must not be provided, and vice-versa. The values should be strings; other
+#'   types (such as logicals and numbers) will be coerced to strings.
+#' @param selected The values that should be initially selected, if any.
+#' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
+#' @param choiceNames,choiceValues List of names and values, respectively,
+#'   that are displayed to the user in the app and correspond to the each
+#'   choice (for this reason, \code{choiceNames} and \code{choiceValues}
+#'   must have the same length). If either of these arguments is
+#'   provided, then the other \emph{must} be provided and \code{choices}
+#'   \emph{must not} be provided. The advantage of using both of these over
+#'   a named list for \code{choices} is that \code{choiceNames} allows any
+#'   type of UI object to be passed through (tag objects, icons, HTML code,
+#'   ...), instead of just simple text. See Examples.
+#'
+#' @return A list of HTML elements that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{checkboxInput}}, \code{\link{updateCheckboxGroupInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   checkboxGroupInput("variable", "Variables to show:",
+#'                      c("Cylinders" = "cyl",
+#'                        "Transmission" = "am",
+#'                        "Gears" = "gear")),
+#'   tableOutput("data")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   output$data <- renderTable({
+#'     mtcars[, c("mpg", input$variable), drop = FALSE]
+#'   }, rownames = TRUE)
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' ui <- fluidPage(
+#'   checkboxGroupInput("icons", "Choose icons:",
+#'     choiceNames =
+#'       list(icon("calendar"), icon("bed"),
+#'            icon("cog"), icon("bug")),
+#'     choiceValues =
+#'       list("calendar", "bed", "cog", "bug")
+#'   ),
+#'   textOutput("txt")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   output$txt <- renderText({
+#'     icons <- paste(input$icons, collapse = ", ")
+#'     paste("You chose", icons)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
+
+  # keep backward compatibility with Shiny < 1.0.1 (see #1649)
+  if (is.null(choices) && is.null(choiceNames) && is.null(choiceValues)) {
+    choices <- character(0)
+  }
+
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
+
+  selected <- restoreInput(id = inputId, default = selected)
+
+  # default value if it's not specified
+  if (!is.null(selected)) selected <- as.character(selected)
+
+  options <- generateOptions(inputId, selected, inline,
+    'checkbox', args$choiceNames, args$choiceValues)
+
+  divClass <- "form-group shiny-input-checkboxgroup shiny-input-container"
+  if (inline)
+    divClass <- paste(divClass, "shiny-input-container-inline")
+
+  # return label and select tag
+  tags$div(id = inputId,
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    class = divClass,
+    controlLabel(inputId, label),
+    options
+  )
+}

R/input-date.R

@@ -0,0 +1,142 @@
+#' Create date input
+#'
+#' Creates a text input which, when clicked on, brings up a calendar that
+#' the user can click on to select dates.
+#'
+#' The date \code{format} string specifies how the date will be displayed in
+#' the browser. It allows the following values:
+#'
+#' \itemize{
+#'   \item \code{yy} Year without century (12)
+#'   \item \code{yyyy} Year with century (2012)
+#'   \item \code{mm} Month number, with leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (1-12)
+#'   \item \code{M} Abbreviated month name
+#'   \item \code{MM} Full month name
+#'   \item \code{dd} Day of month with leading zero
+#'   \item \code{d} Day of month without leading zero
+#'   \item \code{D} Abbreviated weekday name
+#'   \item \code{DD} Full weekday name
+#' }
+#'
+#' @inheritParams textInput
+#' @param value The starting date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current date
+#'   in the client's time zone.
+#' @param min The minimum allowed date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#' @param max The maximum allowed date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format.
+#' @param format The format of the date to display in the browser. Defaults to
+#'   \code{"yyyy-mm-dd"}.
+#' @param startview The date range shown when the input object is first clicked.
+#'   Can be "month" (the default), "year", or "decade".
+#' @param weekstart Which day is the start of the week. Should be an integer
+#'   from 0 (Sunday) to 6 (Saturday).
+#' @param language The language used for month and day names. Default is "en".
+#'   Other valid values include "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".
+#' @param autoclose Whether or not to close the datepicker immediately when a
+#'   date is selected.
+#' @param datesdisabled Which dates should be disabled. Either a Date object,
+#' or a string in \code{yyyy-mm-dd} format.
+#' @param daysofweekdisabled Days of the week that should be disabled. Should be
+#'   a integer vector with values from 0 (Sunday) to 6 (Saturday).
+#'
+#' @family input elements
+#' @seealso \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   dateInput("date1", "Date:", value = "2012-02-29"),
+#'
+#'   # Default value is the date in client's time zone
+#'   dateInput("date2", "Date:"),
+#'
+#'   # value is always yyyy-mm-dd, even if the display format is different
+#'   dateInput("date3", "Date:", value = "2012-02-29", format = "mm/dd/yy"),
+#'
+#'   # Pass in a Date object
+#'   dateInput("date4", "Date:", value = Sys.Date()-10),
+#'
+#'   # Use different language and different first day of week
+#'   dateInput("date5", "Date:",
+#'           language = "ru",
+#'           weekstart = 1),
+#'
+#'   # Start with decade view instead of default month view
+#'   dateInput("date6", "Date:",
+#'             startview = "decade"),
+#'
+#'   # Disable Mondays and Tuesdays.
+#'   dateInput("date7", "Date:", daysofweekdisabled = c(1,2)),
+#'   
+#'   # Disable specific dates.
+#'   dateInput("date8", "Date:", value = "2012-02-29",
+#'             datesdisabled = c("2012-03-01", "2012-03-02"))
+#' )
+#'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
+#' @export
+dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
+  format = "yyyy-mm-dd", startview = "month", weekstart = 0,
+  language = "en", width = NULL, autoclose = TRUE,
+  datesdisabled = NULL, daysofweekdisabled = NULL) {
+
+  # If value is a date object, convert it to a string with yyyy-mm-dd format
+  # Same for min and max
+  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
+  if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
+  if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
+  if (inherits(datesdisabled, "Date")) {
+      datesdisabled <- format(datesdisabled,   "%Y-%m-%d")
+  }
+
+  value <- restoreInput(id = inputId, default = value)
+
+  tags$div(id = inputId,
+    class = "shiny-date-input form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+
+    controlLabel(inputId, label),
+    tags$input(type = "text",
+               class = "form-control",
+               `data-date-language` = language,
+               `data-date-week-start` = weekstart,
+               `data-date-format` = format,
+               `data-date-start-view` = startview,
+               `data-min-date` = min,
+               `data-max-date` = max,
+               `data-initial-date` = value,
+               `data-date-autoclose` = if (autoclose) "true" else "false",
+               `data-date-dates-disabled` =
+                   # Ensure NULL is not sent as `{}` but as 'null'
+                   jsonlite::toJSON(datesdisabled, null = 'null'),
+               `data-date-days-of-week-disabled` =
+                   jsonlite::toJSON(daysofweekdisabled, null = 'null')
+    ),
+    datePickerDependency
+  )
+}
+
+datePickerDependency <- htmlDependency(
+  "bootstrap-datepicker", "1.6.4", 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>"
+)

R/input-daterange.R

@@ -0,0 +1,127 @@
+#' Create date range input
+#'
+#' Creates a pair of text inputs which, when clicked on, bring up calendars that
+#' the user can click on to select dates.
+#'
+#' The date \code{format} string specifies how the date will be displayed in
+#' the browser. It allows the following values:
+#'
+#' \itemize{
+#'   \item \code{yy} Year without century (12)
+#'   \item \code{yyyy} Year with century (2012)
+#'   \item \code{mm} Month number, with leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (1-12)
+#'   \item \code{M} Abbreviated month name
+#'   \item \code{MM} Full month name
+#'   \item \code{dd} Day of month with leading zero
+#'   \item \code{d} Day of month without leading zero
+#'   \item \code{D} Abbreviated weekday name
+#'   \item \code{DD} Full weekday name
+#' }
+#'
+#' @inheritParams dateInput
+#' @param start The initial start date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current
+#'   date in the client's time zone.
+#' @param end The initial end date. Either a Date object, or a string in
+#'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current
+#'   date in the client's time zone.
+#' @param separator String to display between the start and end input boxes.
+#'
+#' @family input elements
+#' @seealso \code{\link{dateInput}}, \code{\link{updateDateRangeInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   dateRangeInput("daterange1", "Date range:",
+#'                  start = "2001-01-01",
+#'                  end   = "2010-12-31"),
+#'
+#'   # Default start and end is the current date in the client's time zone
+#'   dateRangeInput("daterange2", "Date range:"),
+#'
+#'   # start and end are always specified in yyyy-mm-dd, even if the display
+#'   # format is different
+#'   dateRangeInput("daterange3", "Date range:",
+#'                  start  = "2001-01-01",
+#'                  end    = "2010-12-31",
+#'                  min    = "2001-01-01",
+#'                  max    = "2012-12-21",
+#'                  format = "mm/dd/yy",
+#'                  separator = " - "),
+#'
+#'   # Pass in Date objects
+#'   dateRangeInput("daterange4", "Date range:",
+#'                  start = Sys.Date()-10,
+#'                  end = Sys.Date()+10),
+#'
+#'   # Use different language and different first day of week
+#'   dateRangeInput("daterange5", "Date range:",
+#'                  language = "de",
+#'                  weekstart = 1),
+#'
+#'   # Start with decade view instead of default month view
+#'   dateRangeInput("daterange6", "Date range:",
+#'                  startview = "decade")
+#' )
+#'
+#' shinyApp(ui, server = function(input, output) { })
+#' }
+#' @export
+dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
+    min = NULL, max = NULL, format = "yyyy-mm-dd", startview = "month",
+    weekstart = 0, language = "en", separator = " to ", width = NULL,
+    autoclose = TRUE) {
+
+  # If start and end are date objects, convert to a string with yyyy-mm-dd format
+  # Same for min and max
+  if (inherits(start, "Date"))  start <- format(start, "%Y-%m-%d")
+  if (inherits(end,   "Date"))  end   <- format(end,   "%Y-%m-%d")
+  if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
+  if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
+
+  restored <- restoreInput(id = inputId, default = list(start, end))
+  start <- restored[[1]]
+  end <- restored[[2]]
+
+  attachDependencies(
+    div(id = inputId,
+      class = "shiny-date-range-input form-group shiny-input-container",
+      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+
+      controlLabel(inputId, label),
+      # input-daterange class is needed for dropdown behavior
+      div(class = "input-daterange input-group",
+        tags$input(
+          class = "input-sm form-control",
+          type = "text",
+          `data-date-language` = language,
+          `data-date-week-start` = weekstart,
+          `data-date-format` = format,
+          `data-date-start-view` = startview,
+          `data-min-date` = min,
+          `data-max-date` = max,
+          `data-initial-date` = start,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
+        ),
+        span(class = "input-group-addon", separator),
+        tags$input(
+          class = "input-sm form-control",
+          type = "text",
+          `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` = end,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
+        )
+      )
+    ),
+    datePickerDependency
+  )
+}

R/input-file.R

@@ -0,0 +1,126 @@
+#' File Upload Control
+#'
+#' Create a file upload control that can be used to upload one or more files.
+#'
+#' Whenever a file upload completes, the corresponding input variable is set
+#' to a dataframe. This dataframe contains one row for each selected file, and
+#' the following columns:
+#' \describe{
+#'   \item{\code{name}}{The filename provided by the web browser. This is
+#'   \strong{not} the path to read to get at the actual data that was uploaded
+#'   (see
+#'   \code{datapath} column).}
+#'   \item{\code{size}}{The size of the uploaded data, in
+#'   bytes.}
+#'   \item{\code{type}}{The MIME type reported by the browser (for example,
+#'   \code{text/plain}), or empty string if the browser didn't know.}
+#'   \item{\code{datapath}}{The path to a temp file that contains the data that was
+#'   uploaded. This file may be deleted if the user performs another upload
+#'   operation.}
+#' }
+#'
+#' @family input elements
+#'
+#' @inheritParams textInput
+#' @param multiple Whether the user should be allowed to select and upload
+#'   multiple files at once. \bold{Does not work on older browsers, including
+#'   Internet Explorer 9 and earlier.}
+#' @param accept A character vector of MIME types; gives the browser a hint of
+#'   what kind of files the server is expecting.
+#' @param buttonLabel The label used on the button. Can be text or an HTML tag
+#'   object.
+#' @param placeholder The text to show before a file has been uploaded.
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sidebarLayout(
+#'     sidebarPanel(
+#'       fileInput("file1", "Choose CSV File",
+#'         accept = c(
+#'           "text/csv",
+#'           "text/comma-separated-values,text/plain",
+#'           ".csv")
+#'         ),
+#'       tags$hr(),
+#'       checkboxInput("header", "Header", TRUE)
+#'     ),
+#'     mainPanel(
+#'       tableOutput("contents")
+#'     )
+#'   )
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$contents <- renderTable({
+#'     # input$file1 will be NULL initially. After the user selects
+#'     # and uploads a file, it will be a data frame with 'name',
+#'     # 'size', 'type', and 'datapath' columns. The 'datapath'
+#'     # column will contain the local filenames where the data can
+#'     # be found.
+#'     inFile <- input$file1
+#'
+#'     if (is.null(inFile))
+#'       return(NULL)
+#'
+#'     read.csv(inFile$datapath, header = input$header)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
+  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
+
+  restoredValue <- restoreInput(id = inputId, default = NULL)
+
+  # Catch potential edge case - ensure that it's either NULL or a data frame.
+  if (!is.null(restoredValue) && !is.data.frame(restoredValue)) {
+    warning("Restored value for ", inputId, " has incorrect format.")
+    restoredValue <- NULL
+  }
+
+  if (!is.null(restoredValue)) {
+    restoredValue <- toJSON(restoredValue, strict_atomic = FALSE)
+  }
+
+  inputTag <- tags$input(
+    id = inputId,
+    name = inputId,
+    type = "file",
+    style = "display: none;",
+    `data-restore` = restoredValue
+  )
+
+  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",
+          buttonLabel,
+          inputTag
+        )
+      ),
+      tags$input(type = "text", class = "form-control",
+        placeholder = placeholder, readonly = "readonly"
+      )
+    ),
+
+    tags$div(
+      id=paste(inputId, "_progress", sep=""),
+      class="progress progress-striped active shiny-file-input-progress",
+      tags$div(class="progress-bar")
+    )
+  )
+}

R/input-numeric.R

@@ -0,0 +1,48 @@
+#' Create a numeric input control
+#'
+#' Create an input control for entry of numeric values
+#'
+#' @inheritParams textInput
+#' @param min Minimum allowed value
+#' @param max Maximum allowed value
+#' @param step Interval to use when stepping between min and max
+#' @return A numeric input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateNumericInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   numericInput("obs", "Observations:", 10, min = 1, max = 100),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$obs })
+#' }
+#' shinyApp(ui, server)
+#' }
+#' @export
+numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
+  width = NULL) {
+
+  value <- restoreInput(id = inputId, default = value)
+
+  # build input tag
+  inputTag <- tags$input(id = inputId, type = "number", class="form-control",
+                         value = formatNoSci(value))
+  if (!is.na(min))
+    inputTag$attribs$min = min
+  if (!is.na(max))
+    inputTag$attribs$max = max
+  if (!is.na(step))
+    inputTag$attribs$step = step
+
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    label %AND% tags$label(label, `for` = inputId),
+    inputTag
+  )
+}

R/input-password.R

@@ -0,0 +1,37 @@
+#' Create a password input control
+#'
+#' Create an password control for entry of passwords.
+#'
+#' @inheritParams textInput
+#' @return A text input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateTextInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   passwordInput("password", "Password:"),
+#'   actionButton("go", "Go"),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({
+#'     req(input$go)
+#'     isolate(input$password)
+#'   })
+#' }
+#' shinyApp(ui, server)
+#' }
+#' @export
+passwordInput <- function(inputId, label, value = "", width = NULL,
+                          placeholder = NULL) {
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    label %AND% tags$label(label, `for` = inputId),
+    tags$input(id = inputId, type="password", class="form-control", value=value,
+               placeholder = placeholder)
+  )
+}

R/input-radiobuttons.R

@@ -0,0 +1,108 @@
+#' Create radio buttons
+#'
+#' Create a set of radio buttons used to select an item from a list.
+#'
+#' If you need to represent a "None selected" state, it's possible to default
+#' the radio buttons to have no options selected by using \code{selected =
+#' character(0)}. However, this is not recommended, as it gives the user no way
+#' to return to that state once they've made a selection. Instead, consider
+#' having the first of your choices be \code{c("None selected" = "")}.
+#'
+#' @inheritParams textInput
+#' @param choices List of values to select from (if elements of the list are
+#'   named then that name rather than the value is displayed to the user). If
+#'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
+#'   must not be provided, and vice-versa. The values should be strings; other
+#'   types (such as logicals and numbers) will be coerced to strings.
+#' @param selected The initially selected value (if not specified then defaults
+#'   to the first value)
+#' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
+#' @return A set of radio buttons that can be added to a UI definition.
+#' @param choiceNames,choiceValues List of names and values, respectively, that
+#'   are displayed to the user in the app and correspond to the each choice (for
+#'   this reason, \code{choiceNames} and \code{choiceValues} must have the same
+#'   length). If either of these arguments is provided, then the other
+#'   \emph{must} be provided and \code{choices} \emph{must not} be provided. The
+#'   advantage of using both of these over a named list for \code{choices} is
+#'   that \code{choiceNames} allows any type of UI object to be passed through
+#'   (tag objects, icons, HTML code, ...), instead of just simple text. See
+#'   Examples.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateRadioButtons}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   radioButtons("dist", "Distribution type:",
+#'                c("Normal" = "norm",
+#'                  "Uniform" = "unif",
+#'                  "Log-normal" = "lnorm",
+#'                  "Exponential" = "exp")),
+#'   plotOutput("distPlot")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$distPlot <- renderPlot({
+#'     dist <- switch(input$dist,
+#'                    norm = rnorm,
+#'                    unif = runif,
+#'                    lnorm = rlnorm,
+#'                    exp = rexp,
+#'                    rnorm)
+#'
+#'     hist(dist(500))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' ui <- fluidPage(
+#'   radioButtons("rb", "Choose one:",
+#'                choiceNames = list(
+#'                  icon("calendar"),
+#'                  HTML("<p style='color:red;'>Red Text</p>"),
+#'                  "Normal text"
+#'                ),
+#'                choiceValues = list(
+#'                  "icon", "html", "text"
+#'                )),
+#'   textOutput("txt")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$txt <- renderText({
+#'     paste("You chose", input$rb)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
+
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
+
+  selected <- restoreInput(id = inputId, default = selected)
+
+  # default value if it's not specified
+  selected <- if (is.null(selected)) args$choiceValues[[1]] else as.character(selected)
+
+  if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
+
+  options <- generateOptions(inputId, selected, inline,
+    'radio', args$choiceNames, args$choiceValues)
+
+  divClass <- "form-group shiny-input-radiogroup shiny-input-container"
+  if (inline) divClass <- paste(divClass, "shiny-input-container-inline")
+
+  tags$div(id = inputId,
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    class = divClass,
+    controlLabel(inputId, label),
+    options
+  )
+}

R/input-select.R

@@ -0,0 +1,346 @@
+#' Create a select list input control
+#'
+#' Create a select list that can be used to choose a single or multiple items
+#' from a list of values.
+#'
+#' By default, \code{selectInput()} and \code{selectizeInput()} use the
+#' JavaScript library \pkg{selectize.js}
+#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
+#' select input element. To use the standard HTML select input element, use
+#' \code{selectInput()} with \code{selectize=FALSE}.
+#'
+#' In selectize mode, if the first element in \code{choices} has a value of
+#' \code{""}, its name will be treated as a placeholder prompt. For example:
+#' \code{selectInput("letter", "Letter", c("Choose one" = "", LETTERS))}
+#'
+#' @inheritParams textInput
+#' @param choices List of values to select from. If elements of the list are
+#'   named, then that name rather than the value is displayed to the user.
+#'   This can also be a named list whose elements are (either named or
+#'   unnamed) lists or vectors. If this is the case, the outermost names
+#'   will be used as the "optgroup" label for the elements in the respective
+#'   sublist. This allows you to group and label similar choices. See the
+#'   example section for a small demo of this feature.
+#' @param selected The initially selected value (or multiple values if
+#'   \code{multiple = TRUE}). If not specified then defaults to the first value
+#'   for single-select lists and no values for multiple select lists.
+#' @param multiple Is selection of multiple items allowed?
+#' @param selectize Whether to use \pkg{selectize.js} or not.
+#' @param size Number of items to show in the selection box; a larger number
+#'   will result in a taller box. Not compatible with \code{selectize=TRUE}.
+#'   Normally, when \code{multiple=FALSE}, a select input will be a drop-down
+#'   list, but when \code{size} is set, it will be a box instead.
+#' @return A select list control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateSelectInput}} \code{\link{varSelectInput}}
+#'
+#' @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` = list("NY", "NJ", "CT"),
+#'            `West Coast` = list("WA", "OR", "CA"),
+#'            `Midwest` = list("MN", "WI", "IA"))
+#'     ),
+#'     textOutput("result")
+#'   ),
+#'   server = function(input, output) {
+#'     output$result <- renderText({
+#'       paste("You chose", input$state)
+#'     })
+#'   }
+#' )
+#' }
+#' @export
+selectInput <- function(inputId, label, choices, selected = NULL,
+  multiple = FALSE, selectize = TRUE, width = NULL,
+  size = NULL) {
+
+  selected <- restoreInput(id = inputId, default = selected)
+
+  # resolve names
+  choices <- choicesWithNames(choices)
+
+  # default value if it's not specified
+  if (is.null(selected)) {
+    if (!multiple) selected <- firstChoice(choices)
+  } else selected <- as.character(selected)
+
+  if (!is.null(size) && selectize) {
+    stop("'size' argument is incompatible with 'selectize=TRUE'.")
+  }
+
+  # create select tag and add options
+  selectTag <- tags$select(
+    id = inputId,
+    class = if (!selectize) "form-control",
+    size = size,
+    selectOptions(choices, selected)
+  )
+  if (multiple)
+    selectTag$attribs$multiple <- "multiple"
+
+  # return label and select tag
+  res <- div(
+    class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    controlLabel(inputId, label),
+    div(selectTag)
+  )
+
+  if (!selectize) return(res)
+
+  selectizeIt(inputId, res, NULL, nonempty = !multiple && !("" %in% choices))
+}
+
+firstChoice <- function(choices) {
+  if (length(choices) == 0L) return()
+  choice <- choices[[1]]
+  if (is.list(choice)) firstChoice(choice) else choice
+}
+
+# Create tags for each of the options; use <optgroup> if necessary.
+# This returns a HTML string instead of tags, because of the 'selected'
+# attribute.
+selectOptions <- function(choices, selected = NULL) {
+  html <- mapply(choices, names(choices), FUN = function(choice, label) {
+    if (is.list(choice)) {
+      # If sub-list, create an optgroup and recurse into the sublist
+      sprintf(
+        '<optgroup label="%s">\n%s\n</optgroup>',
+        htmlEscape(label, TRUE),
+        selectOptions(choice, selected)
+      )
+
+    } else {
+      # If single item, just return option string
+      sprintf(
+        '<option value="%s"%s>%s</option>',
+        htmlEscape(choice, TRUE),
+        if (choice %in% selected) ' selected' else '',
+        htmlEscape(label)
+      )
+    }
+  })
+
+  HTML(paste(html, collapse = '\n'))
+}
+
+# need <optgroup> when choices contains sub-lists
+needOptgroup <- function(choices) {
+  any(vapply(choices, is.list, logical(1)))
+}
+
+#' @rdname selectInput
+#' @param ... Arguments passed to \code{selectInput()}.
+#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#'   for possible options (character option values inside \code{\link[base]{I}()} will
+#'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
+#'   for details).
+#' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @note The selectize input created from \code{selectizeInput()} allows
+#'   deletion of the selected option even in a single select input, which will
+#'   return an empty string as its value. This is the default behavior of
+#'   \pkg{selectize.js}. However, the selectize input created from
+#'   \code{selectInput(..., selectize = TRUE)} will ignore the empty string
+#'   value when it is a single choice input and the empty string is not in the
+#'   \code{choices} argument. This is to keep compatibility with
+#'   \code{selectInput(..., selectize = FALSE)}.
+#' @export
+selectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
+  selectizeIt(
+    inputId,
+    selectInput(inputId, ..., selectize = FALSE, width = width),
+    options
+  )
+}
+
+# given a select input and its id, selectize it
+selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
+  res <- checkAsIs(options)
+
+  selectizeDep <- htmlDependency(
+    "selectize", "0.11.2", c(href = "shared/selectize"),
+    stylesheet = "css/selectize.bootstrap3.css",
+    head = format(tagList(
+      HTML('<!--[if lt IE 9]>'),
+      tags$script(src = 'shared/selectize/js/es5-shim.min.js'),
+      HTML('<![endif]-->'),
+      tags$script(src = 'shared/selectize/js/selectize.min.js')
+    ))
+  )
+
+  if ('drag_drop' %in% options$plugins) {
+    selectizeDep <- list(selectizeDep, htmlDependency(
+      'jqueryui', '1.12.1', c(href = 'shared/jqueryui'),
+      script = 'jquery-ui.min.js'
+    ))
+  }
+
+  # Insert script on same level as <select> tag
+  select$children[[2]] <- tagAppendChild(
+    select$children[[2]],
+    tags$script(
+      type = 'application/json',
+      `data-for` = inputId, `data-nonempty` = if (nonempty) '',
+      `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
+      if (length(res$options)) HTML(toJSON(res$options)) else '{}'
+    )
+  )
+
+  attachDependencies(select, selectizeDep)
+}
+
+
+
+
+
+
+
+
+#' Select variables from a data frame
+#'
+#' Create a select list that can be used to choose a single or multiple items
+#' from the column names of a data frame.
+#'
+#' The resulting server \code{input} value will be returned as:
+#' \itemize{
+#'   \item a symbol if \code{multiple = FALSE}.  The \code{input} value should be
+#'         used with rlang's \code{\link[rlang]{!!}}. For example,
+#'         \code{ggplot2::aes(!!input$variable)}.
+#'   \item a list of symbols if \code{multiple = TRUE}. The \code{input} value
+#'         should be used with rlang's \code{\link[rlang]{!!!}} to expand
+#'         the symbol list as individual arguments. For example,
+#'         \code{dplyr::select(mtcars, !!!input$variabls)} which is
+#'         equivalent to \code{dplyr::select(mtcars, !!input$variabls[[1]], !!input$variabls[[2]], ..., !!input$variabls[[length(input$variabls)]])}.
+#' }
+#'
+#' By default, \code{varSelectInput()} and \code{selectizeInput()} use the
+#' JavaScript library \pkg{selectize.js}
+#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
+#' select input element. To use the standard HTML select input element, use
+#' \code{selectInput()} with \code{selectize=FALSE}.
+#'
+#' @inheritParams selectInput
+#' @param data A data frame. Used to retrieve the column names as choices for a \code{\link{selectInput}}
+#' @return A variable select list control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateSelectInput}}
+#' @examples
+#'
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' library(ggplot2)
+#'
+#' # single selection
+#' shinyApp(
+#'   ui = fluidPage(
+#'     varSelectInput("variable", "Variable:", mtcars),
+#'     plotOutput("data")
+#'   ),
+#'   server = function(input, output) {
+#'     output$data <- renderPlot({
+#'       ggplot(mtcars, aes(!!input$variable)) + geom_histogram()
+#'     })
+#'   }
+#' )
+#'
+#'
+#' # multiple selections
+#' \dontrun{
+#' shinyApp(
+#'  ui = fluidPage(
+#'    varSelectInput("variables", "Variable:", mtcars, multiple = TRUE),
+#'    tableOutput("data")
+#'  ),
+#'  server = function(input, output) {
+#'    output$data <- renderTable({
+#'       if (length(input$variables) == 0) return(mtcars)
+#'       mtcars %>% dplyr::select(!!!input$variables)
+#'    }, rownames = TRUE)
+#'  }
+#' )}
+#'
+#' }
+#' @export
+varSelectInput <- function(
+  inputId, label, data, selected = NULL,
+  multiple = FALSE, selectize = TRUE, width = NULL,
+  size = NULL
+) {
+  # no place holders
+  choices <- colnames(data)
+
+  selectInputVal <- selectInput(
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected,
+    multiple = multiple,
+    selectize = selectize,
+    width = width,
+    size = size
+  )
+
+  # set the select tag class to be "symbol"
+  selectClass <- selectInputVal$children[[2]]$children[[1]]$attribs$class
+  if (is.null(selectClass)) {
+    newClass <- "symbol"
+  } else {
+    newClass <- paste(selectClass, "symbol", sep = " ")
+  }
+  selectInputVal$children[[2]]$children[[1]]$attribs$class <- newClass
+
+  selectInputVal
+}
+
+
+
+#' @rdname varSelectInput
+#' @param ... Arguments passed to \code{varSelectInput()}.
+#' @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
+#'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
+#'   for details).
+#' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @note The variable selectize input created from \code{varSelectizeInput()} allows
+#'   deletion of the selected option even in a single select input, which will
+#'   return an empty string as its value. This is the default behavior of
+#'   \pkg{selectize.js}. However, the selectize input created from
+#'   \code{selectInput(..., selectize = TRUE)} will ignore the empty string
+#'   value when it is a single choice input and the empty string is not in the
+#'   \code{choices} argument. This is to keep compatibility with
+#'   \code{selectInput(..., selectize = FALSE)}.
+#' @export
+varSelectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
+  selectizeIt(
+    inputId,
+    varSelectInput(inputId, ..., selectize = FALSE, width = width),
+    options
+  )
+}

R/input-slider.R

@@ -0,0 +1,272 @@
+#' Slider Input Widget
+#'
+#' Constructs a slider widget to select a numeric value from a range.
+#'
+#' @inheritParams textInput
+#' @param min The minimum value (inclusive) that can be selected.
+#' @param max The maximum value (inclusive) that can be selected.
+#' @param value The initial value of the slider. A numeric vector of length one
+#'   will create a regular slider; a numeric vector of length two will create a
+#'   double-ended range slider. A warning will be issued if the value doesn't
+#'   fit between \code{min} and \code{max}.
+#' @param step Specifies the interval between each selectable value on the
+#'   slider (if \code{NULL}, a heuristic is used to determine the step size). If
+#'   the values are dates, \code{step} is in days; if the values are times
+#'   (POSIXt), \code{step} is in seconds.
+#' @param round \code{TRUE} to round all values to the nearest integer;
+#'   \code{FALSE} if no rounding is desired; or an integer to round to that
+#'   number of digits (for example, 1 will round to the nearest 10, and -2 will
+#'   round to the nearest .01). Any rounding will be applied after snapping to
+#'   the nearest step.
+#' @param format Deprecated.
+#' @param locale Deprecated.
+#' @param ticks \code{FALSE} to hide tick marks, \code{TRUE} to show them
+#'   according to some simple heuristics.
+#' @param animate \code{TRUE} to show simple animation controls with default
+#'   settings; \code{FALSE} not to; or a custom settings list, such as those
+#'   created using \code{\link{animationOptions}}.
+#' @param sep Separator between thousands places in numbers.
+#' @param pre A prefix string to put in front of the value.
+#' @param post A suffix string to put after the value.
+#' @param dragRange This option is used only if it is a range slider (with two
+#'   values). If \code{TRUE} (the default), the range can be dragged. In other
+#'   words, the min and max can be dragged together. If \code{FALSE}, the range
+#'   cannot be dragged.
+#' @param timeFormat Only used if the values are Date or POSIXt objects. A time
+#'   format string, to be passed to the Javascript strftime library. See
+#'   \url{https://github.com/samsonjs/strftime} for more details. The allowed
+#'   format specifications are very similar, but not identical, to those for R's
+#'   \code{\link[base]{strftime}} function. For Dates, the default is \code{"\%F"}
+#'   (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"}
+#'   (like \code{"2015-07-01 15:32:10"}).
+#' @param timezone Only used if the values are POSIXt objects. A string
+#'   specifying the time zone offset for the displayed times, in the format
+#'   \code{"+HHMM"} or \code{"-HHMM"}. If \code{NULL} (the default), times will
+#'   be displayed in the browser's time zone. The value \code{"+0000"} will
+#'   result in UTC time.
+#' @inheritParams selectizeInput
+#' @family input elements
+#' @seealso \code{\link{updateSliderInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' 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,
+                        ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
+                        pre = NULL, post = NULL, timeFormat = NULL,
+                        timezone = NULL, dragRange = TRUE)
+{
+  if (!missing(format)) {
+    shinyDeprecated(msg = "The `format` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
+                    version = "0.10.2.2")
+  }
+  if (!missing(locale)) {
+    shinyDeprecated(msg = "The `locale` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
+                    version = "0.10.2.2")
+  }
+
+  dataType <- getSliderType(min, max, value)
+
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
+  }
+
+  # Restore bookmarked values here, after doing the type checking, because the
+  # restored value will be a character vector instead of Date or POSIXct, and we can do
+  # the conversion to correct type next.
+  value <- restoreInput(id = inputId, default = value)
+
+  if (is.character(value)) {
+    # If we got here, the value was restored from a URL-encoded bookmark.
+    if (dataType == "date") {
+      value <- as.Date(value, format = "%Y-%m-%d")
+    } else if (dataType == "datetime") {
+      # Date-times will have a format like "2018-02-28T03:46:26Z"
+      value <- as.POSIXct(value, format = "%Y-%m-%dT%H:%M:%SZ", tz = "UTC")
+    }
+  }
+
+  step <- findStepSize(min, max, step)
+
+  if (dataType %in% c("date", "datetime")) {
+    # For Dates, this conversion uses midnight on that date in UTC
+    to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
+
+    # Convert values to milliseconds since epoch (this is the value JS uses)
+    # Find step size in ms
+    step  <- to_ms(max) - to_ms(max - step)
+    min   <- to_ms(min)
+    max   <- to_ms(max)
+    value <- to_ms(value)
+  }
+
+  range <- max - min
+
+  # Try to get a sane number of tick marks
+  if (ticks) {
+    n_steps <- range / step
+
+    # Make sure there are <= 10 steps.
+    # n_ticks can be a noninteger, which is good when the range is not an
+    # integer multiple of the step size, e.g., min=1, max=10, step=4
+    scale_factor <- ceiling(n_steps / 10)
+    n_ticks <- n_steps / scale_factor
+
+  } else {
+    n_ticks <- NULL
+  }
+
+  sliderProps <- dropNulls(list(
+    class = "js-range-slider",
+    id = inputId,
+    `data-type` = if (length(value) > 1) "double",
+    `data-min` = formatNoSci(min),
+    `data-max` = formatNoSci(max),
+    `data-from` = formatNoSci(value[1]),
+    `data-to` = if (length(value) > 1) formatNoSci(value[2]),
+    `data-step` = formatNoSci(step),
+    `data-grid` = ticks,
+    `data-grid-num` = n_ticks,
+    `data-grid-snap` = FALSE,
+    `data-prettify-separator` = sep,
+    `data-prettify-enabled` = (sep != ""),
+    `data-prefix` = pre,
+    `data-postfix` = post,
+    `data-keyboard` = TRUE,
+    # This value is only relevant for range sliders; for non-range sliders it
+    # causes problems since ion.RangeSlider 2.1.2 (issue #1605).
+    `data-drag-interval` = if (length(value) > 1) dragRange,
+    # The following are ignored by the ion.rangeSlider, but are used by Shiny.
+    `data-data-type` = dataType,
+    `data-time-format` = timeFormat,
+    `data-timezone` = timezone
+  ))
+
+  # Replace any TRUE and FALSE with "true" and "false"
+  sliderProps <- lapply(sliderProps, function(x) {
+    if (identical(x, TRUE)) "true"
+    else if (identical(x, FALSE)) "false"
+    else x
+  })
+
+  sliderTag <- div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    if (!is.null(label)) controlLabel(inputId, label),
+    do.call(tags$input, sliderProps)
+  )
+
+  # Add animation buttons
+  if (identical(animate, TRUE))
+    animate <- animationOptions()
+
+  if (!is.null(animate) && !identical(animate, FALSE)) {
+    if (is.null(animate$playButton))
+      animate$playButton <- icon('play', lib = 'glyphicon')
+    if (is.null(animate$pauseButton))
+      animate$pauseButton <- icon('pause', lib = 'glyphicon')
+
+    sliderTag <- tagAppendChild(
+      sliderTag,
+      tags$div(class='slider-animate-container',
+        tags$a(href='#',
+          class='slider-animate-button',
+          'data-target-id'=inputId,
+          'data-interval'=animate$interval,
+          'data-loop'=animate$loop,
+          span(class = 'play', animate$playButton),
+          span(class = 'pause', animate$pauseButton)
+        )
+      )
+    )
+  }
+
+  dep <- list(
+    htmlDependency("ionrangeslider", "2.1.6", c(href="shared/ionrangeslider"),
+      script = "js/ion.rangeSlider.min.js",
+      # ion.rangeSlider also needs normalize.css, which is already included in
+      # Bootstrap.
+      stylesheet = c("css/ion.rangeSlider.css",
+                     "css/ion.rangeSlider.skinShiny.css")
+    ),
+    htmlDependency("strftime", "0.9.2", c(href="shared/strftime"),
+      script = "strftime-min.js"
+    )
+  )
+
+  attachDependencies(sliderTag, dep)
+}
+
+hasDecimals <- function(value) {
+  truncatedValue <- round(value)
+  return (!identical(value, truncatedValue))
+}
+
+
+# If step is NULL, use heuristic to set the step size.
+findStepSize <- function(min, max, step) {
+  if (!is.null(step)) return(step)
+
+  range <- max - min
+  # If short range or decimals, use continuous decimal with ~100 points
+  if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
+    # Workaround for rounding errors (#1006): the intervals between the items
+    # returned by pretty() can have rounding errors. To avoid this, we'll use
+    # pretty() to find the min, max, and number of steps, and then use those
+    # values to calculate the step size.
+    pretty_steps <- pretty(c(min, max), n = 100)
+    n_steps <- length(pretty_steps) - 1
+
+    # Fix for #2061: Windows has low-significance digits (like 17 digits out)
+    # even at the boundaries of pretty()'s output. Use signif(digits = 10),
+    # which should be way way less significant than any data we'd want to keep.
+    # It might make sense to use signif(steps[2] - steps[1], 10) instead, but
+    # for now trying to make the minimal change.
+    signif(digits = 10, (max(pretty_steps) - min(pretty_steps)) / n_steps)
+
+  } else {
+    1
+  }
+}
+
+
+#' @rdname sliderInput
+#'
+#' @param interval The interval, in milliseconds, between each animation step.
+#' @param loop \code{TRUE} to automatically restart the animation when it
+#'   reaches the end.
+#' @param playButton Specifies the appearance of the play button. Valid values
+#'   are a one-element character vector (for a simple text label), an HTML tag
+#'   or list of tags (using \code{\link{tag}} and friends), or raw HTML (using
+#'   \code{\link{HTML}}).
+#' @param pauseButton Similar to \code{playButton}, but for the pause button.
+#' @export
+animationOptions <- function(interval=1000,
+                             loop=FALSE,
+                             playButton=NULL,
+                             pauseButton=NULL) {
+  list(interval=interval,
+       loop=loop,
+       playButton=playButton,
+       pauseButton=pauseButton)
+}

R/input-submit.R

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

R/input-text.R

@@ -0,0 +1,43 @@
+#' Create a text input control
+#'
+#' Create an input control for entry of unstructured text values
+#'
+#' @param inputId The \code{input} slot that will be used to access the value.
+#' @param label Display label for the control, or \code{NULL} for no label.
+#' @param value Initial value.
+#' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @param placeholder A character string giving the user a hint as to what can
+#'   be entered into the control. Internet Explorer 8 and 9 do not support this
+#'   option.
+#' @return A text input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateTextInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   textInput("caption", "Caption", "Data Summary"),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$caption })
+#' }
+#' shinyApp(ui, server)
+#' }
+#' @export
+textInput <- function(inputId, label, value = "", width = NULL,
+  placeholder = NULL) {
+
+  value <- restoreInput(id = inputId, default = value)
+
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    label %AND% tags$label(label, `for` = inputId),
+    tags$input(id = inputId, type="text", class="form-control", value=value,
+      placeholder = placeholder)
+  )
+}

R/input-textarea.R

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

R/input-utils.R

@@ -0,0 +1,129 @@
+controlLabel <- function(controlName, label) {
+  label %AND% tags$label(class = "control-label", `for` = controlName, label)
+}
+
+# This function takes in either a list or vector for `choices` (and
+# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
+# in a list or vector for both `choiceNames` and `choiceValues` (and
+# `choices` is passed as NULL) and returns a list of two elements:
+#    - `choiceNames` is a vector or list that holds the options names
+#      (each element can be arbitrary UI, or simple text)
+#    - `choiceValues` is a vector or list that holds the options values
+#       (each element must be simple text)
+normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
+  mustExist = TRUE) {
+  # if-else to check that either choices OR (choiceNames + choiceValues)
+  # were correctly provided
+  if (is.null(choices)) {
+    if (is.null(choiceNames) || is.null(choiceValues)) {
+      if (mustExist) {
+        stop("Please specify a non-empty vector for `choices` (or, ",
+             "alternatively, for both `choiceNames` AND `choiceValues`).")
+      } else {
+        if (is.null(choiceNames) && is.null(choiceValues)) {
+          # this is useful when we call this function from `updateInputOptions()`
+          # in which case, all three `choices`, `choiceNames` and `choiceValues`
+          # may legitimately be NULL
+          return(list(choiceNames = NULL, choiceValues = NULL))
+        } else {
+          stop("One of `choiceNames` or `choiceValues` was set to ",
+               "NULL, but either both or none should be NULL.")
+        }
+      }
+    }
+    if (length(choiceNames) != length(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must have the same length.")
+    }
+    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must not be named.")
+    }
+  } else {
+    if (!is.null(choiceNames) || !is.null(choiceValues)) {
+      warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
+    }
+    choices <- choicesWithNames(choices) # resolve names if not specified
+    choiceNames <- names(choices)
+    choiceValues <- unname(choices)
+  }
+
+  return(list(choiceNames = as.list(choiceNames),
+              choiceValues = as.list(as.character(choiceValues))))
+}
+
+# generate options for radio buttons and checkbox groups (type = 'checkbox' or
+# 'radio')
+generateOptions <- function(inputId, selected, inline, type = 'checkbox',
+                            choiceNames, choiceValues,
+                            session = getDefaultReactiveDomain()) {
+  # generate a list of <input type=? [checked] />
+  options <- mapply(
+    choiceValues, choiceNames,
+    FUN = function(value, name) {
+      inputTag <- tags$input(
+        type = type, name = inputId, value = value
+      )
+      if (value %in% selected)
+        inputTag$attribs$checked <- "checked"
+
+      # in case, the options include UI code other than text
+      # (arbitrary HTML using the tags() function or equivalent)
+      pd <- processDeps(name, session)
+
+      # If inline, there's no wrapper div, and the label needs a class like
+      # checkbox-inline.
+      if (inline) {
+        tags$label(class = paste0(type, "-inline"), inputTag,
+                   tags$span(pd$html, pd$deps))
+      } else {
+        tags$div(class = type, tags$label(inputTag,
+                 tags$span(pd$html, pd$deps)))
+      }
+    },
+    SIMPLIFY = FALSE, USE.NAMES = FALSE
+  )
+
+  div(class = "shiny-options-group", options)
+}
+
+
+# Takes a vector or list, and adds names (same as the value) to any entries
+# without names. Coerces all leaf nodes to `character`.
+choicesWithNames <- function(choices) {
+  # Take a vector or list, and convert to list. Also, if any children are
+  # vectors with length > 1, convert those to list. If the list is unnamed,
+  # convert it to a named list with blank names.
+  listify <- function(obj) {
+    # If a list/vector is unnamed, give it blank names
+    makeNamed <- function(x) {
+      if (is.null(names(x))) names(x) <- character(length(x))
+      x
+    }
+
+    res <- lapply(obj, function(val) {
+      if (is.list(val))
+        listify(val)
+      else if (length(val) == 1 && is.null(names(val)))
+        as.character(val)
+      else
+        makeNamed(as.list(val))
+    })
+
+    makeNamed(res)
+  }
+
+  choices <- listify(choices)
+  if (length(choices) == 0) return(choices)
+
+  # Recurse into any subgroups
+  choices <- mapply(choices, names(choices), FUN = function(choice, name) {
+    if (!is.list(choice)) return(choice)
+    if (name == "") stop('All sub-lists in "choices" must be named.')
+    choicesWithNames(choice)
+  }, SIMPLIFY = FALSE)
+
+  # default missing names to choice values
+  missing <- names(choices) == ""
+  names(choices)[missing] <- as.character(choices)[missing]
+
+  choices
+}

R/insert-tab.R

@@ -0,0 +1,325 @@
+#' Dynamically insert/remove a tabPanel
+#'
+#' Dynamically insert or remove a \code{\link{tabPanel}} (or a
+#' \code{\link{navbarMenu}}) from an existing \code{\link{tabsetPanel}},
+#' \code{\link{navlistPanel}} or \code{\link{navbarPage}}.
+#'
+#' When you want to insert a new tab before or after an existing tab, you
+#' should use \code{insertTab}. When you want to prepend a tab (i.e. add a
+#' tab to the beginning of the \code{tabsetPanel}), use \code{prependTab}.
+#' When you want to append a tab (i.e. add a tab to the end of the
+#' \code{tabsetPanel}), use \code{appendTab}.
+#'
+#' For \code{navbarPage}, you can insert/remove conventional
+#' \code{tabPanel}s (whether at the top level or nested inside a
+#' \code{navbarMenu}), as well as an entire \code{\link{navbarMenu}}.
+#' For the latter case, \code{target} should be the \code{menuName} that
+#' you gave your \code{navbarMenu} when you first created it (by default,
+#' this is equal to the value of the \code{title} argument).
+#'
+#' @param inputId The \code{id} of the \code{tabsetPanel} (or
+#'   \code{navlistPanel} or \code{navbarPage}) into which \code{tab} will
+#'   be inserted/removed.
+#'
+#' @param tab The item to be added (must be created with \code{tabPanel},
+#'   or with \code{navbarMenu}).
+#'
+#' @param target If inserting: the \code{value} of an existing
+#'   \code{tabPanel}, next to which \code{tab} will be added.
+#'   If removing: the \code{value} of the \code{tabPanel} that
+#'   you want to remove. See Details if you want to insert next to/remove
+#'   an entire \code{navbarMenu} instead.
+#'
+#' @param position Should \code{tab} be added before or after the
+#'   \code{target} tab?
+#'
+#' @param select Should \code{tab} be selected upon being inserted?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso \code{\link{showTab}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#' # example app for inserting/removing a tab
+#' ui <- fluidPage(
+#'   sidebarLayout(
+#'     sidebarPanel(
+#'       actionButton("add", "Add 'Dynamic' tab"),
+#'       actionButton("remove", "Remove 'Foo' tab")
+#'     ),
+#'     mainPanel(
+#'       tabsetPanel(id = "tabs",
+#'         tabPanel("Hello", "This is the hello tab"),
+#'         tabPanel("Foo", "This is the foo tab"),
+#'         tabPanel("Bar", "This is the bar tab")
+#'       )
+#'     )
+#'   )
+#' )
+#' server <- function(input, output, session) {
+#'   observeEvent(input$add, {
+#'     insertTab(inputId = "tabs",
+#'       tabPanel("Dynamic", "This a dynamically-added tab"),
+#'       target = "Bar"
+#'     )
+#'   })
+#'   observeEvent(input$remove, {
+#'     removeTab(inputId = "tabs", target = "Foo")
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#'
+#' # example app for prepending/appending a navbarMenu
+#' ui <- navbarPage("Navbar page", id = "tabs",
+#'   tabPanel("Home",
+#'     actionButton("prepend", "Prepend a navbarMenu"),
+#'     actionButton("append", "Append a navbarMenu")
+#'   )
+#' )
+#' server <- function(input, output, session) {
+#'   observeEvent(input$prepend, {
+#'     id <- paste0("Dropdown", input$prepend, "p")
+#'     prependTab(inputId = "tabs",
+#'       navbarMenu(id,
+#'         tabPanel("Drop1", paste("Drop1 page from", id)),
+#'         tabPanel("Drop2", paste("Drop2 page from", id)),
+#'         "------",
+#'         "Header",
+#'         tabPanel("Drop3", paste("Drop3 page from", id))
+#'       )
+#'     )
+#'   })
+#'   observeEvent(input$append, {
+#'     id <- paste0("Dropdown", input$append, "a")
+#'     appendTab(inputId = "tabs",
+#'       navbarMenu(id,
+#'         tabPanel("Drop1", paste("Drop1 page from", id)),
+#'         tabPanel("Drop2", paste("Drop2 page from", id)),
+#'         "------",
+#'         "Header",
+#'         tabPanel("Drop3", paste("Drop3 page from", id))
+#'       )
+#'     )
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
+#' @export
+insertTab <- function(inputId, tab, target,
+                      position = c("before", "after"), select = FALSE,
+                      session = getDefaultReactiveDomain()) {
+  force(target)
+  force(select)
+  position <- match.arg(position)
+  inputId <- session$ns(inputId)
+
+  # Barbara -- August 2017
+  # Note: until now, the number of tabs in a tabsetPanel (or navbarPage
+  # or navlistPanel) was always fixed. So, an easy way to give an id to
+  # a tab was simply incrementing a counter. (Just like it was easy to
+  # give a random 4-digit number to identify the tabsetPanel). Since we
+  # can only know this in the client side, we'll just pass `id` and
+  # `tsid` (TabSetID) as dummy values that will be fixed in the JS code.
+  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
+    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
+
+  callback <- function() {
+    session$sendInsertTab(
+      inputId = inputId,
+      liTag = processDeps(item$liTag, session),
+      divTag = processDeps(item$divTag, session),
+      menuName = NULL,
+      target = target,
+      position = position,
+      select = select)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @param menuName This argument should only be used when you want to
+#'   prepend (or append) \code{tab} to the beginning (or end) of an
+#'   existing \code{\link{navbarMenu}} (which must itself be part of
+#'   an existing \code{\link{navbarPage}}). In this case, this argument
+#'   should be the \code{menuName} that you gave your \code{navbarMenu}
+#'   when you first created it (by default, this is equal to the value
+#'   of the \code{title} argument). Note that you still need to set the
+#'   \code{inputId} argument to whatever the \code{id} of the parent
+#'   \code{navbarPage} is. If \code{menuName} is left as \code{NULL},
+#'   \code{tab} will be prepended (or appended) to whatever
+#'   \code{inputId} is.
+#'
+#' @rdname insertTab
+#' @export
+prependTab <- function(inputId, tab, select = FALSE, menuName = NULL,
+                       session = getDefaultReactiveDomain()) {
+  force(select)
+  force(menuName)
+  inputId <- session$ns(inputId)
+
+  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
+    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
+
+  callback <- function() {
+    session$sendInsertTab(
+      inputId = inputId,
+      liTag = processDeps(item$liTag, session),
+      divTag = processDeps(item$divTag, session),
+      menuName = menuName,
+      target = NULL,
+      position = "after",
+      select = select)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @rdname insertTab
+#' @export
+appendTab <- function(inputId, tab, select = FALSE, menuName = NULL,
+                      session = getDefaultReactiveDomain()) {
+  force(select)
+  force(menuName)
+  inputId <- session$ns(inputId)
+
+  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
+    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
+
+  callback <- function() {
+    session$sendInsertTab(
+      inputId = inputId,
+      liTag = processDeps(item$liTag, session),
+      divTag = processDeps(item$divTag, session),
+      menuName = menuName,
+      target = NULL,
+      position = "before",
+      select = select)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @rdname insertTab
+#' @export
+removeTab <- function(inputId, target,
+                      session = getDefaultReactiveDomain()) {
+  force(target)
+  inputId <- session$ns(inputId)
+
+  callback <- function() {
+    session$sendRemoveTab(
+      inputId = inputId,
+      target = target)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+
+#' Dynamically hide/show a tabPanel
+#'
+#' Dynamically hide or show a \code{\link{tabPanel}} (or a
+#' \code{\link{navbarMenu}})from an existing \code{\link{tabsetPanel}},
+#' \code{\link{navlistPanel}} or \code{\link{navbarPage}}.
+#'
+#' For \code{navbarPage}, you can hide/show conventional
+#' \code{tabPanel}s (whether at the top level or nested inside a
+#' \code{navbarMenu}), as well as an entire \code{\link{navbarMenu}}.
+#' For the latter case, \code{target} should be the \code{menuName} that
+#' you gave your \code{navbarMenu} when you first created it (by default,
+#' this is equal to the value of the \code{title} argument).
+#'
+#' @param inputId The \code{id} of the \code{tabsetPanel} (or
+#'   \code{navlistPanel} or \code{navbarPage}) in which to find
+#'   \code{target}.
+#'
+#' @param target The \code{value} of the \code{tabPanel} to be
+#'   hidden/shown. See Details if you want to hide/show an entire
+#'   \code{navbarMenu} instead.
+#'
+#' @param select Should \code{target} be selected upon being shown?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso \code{\link{insertTab}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- navbarPage("Navbar page", id = "tabs",
+#'   tabPanel("Home",
+#'     actionButton("hideTab", "Hide 'Foo' tab"),
+#'     actionButton("showTab", "Show 'Foo' tab"),
+#'     actionButton("hideMenu", "Hide 'More' navbarMenu"),
+#'     actionButton("showMenu", "Show 'More' navbarMenu")
+#'   ),
+#'   tabPanel("Foo", "This is the foo tab"),
+#'   tabPanel("Bar", "This is the bar tab"),
+#'   navbarMenu("More",
+#'     tabPanel("Table", "Table page"),
+#'     tabPanel("About", "About page"),
+#'     "------",
+#'     "Even more!",
+#'     tabPanel("Email", "Email page")
+#'   )
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observeEvent(input$hideTab, {
+#'     hideTab(inputId = "tabs", target = "Foo")
+#'   })
+#'
+#'   observeEvent(input$showTab, {
+#'     showTab(inputId = "tabs", target = "Foo")
+#'   })
+#'
+#'   observeEvent(input$hideMenu, {
+#'     hideTab(inputId = "tabs", target = "More")
+#'   })
+#'
+#'   observeEvent(input$showMenu, {
+#'     showTab(inputId = "tabs", target = "More")
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#'
+#' @export
+showTab <- function(inputId, target, select = FALSE,
+                    session = getDefaultReactiveDomain()) {
+  force(target)
+
+  if (select) updateTabsetPanel(session, inputId, selected = target)
+  inputId <- session$ns(inputId)
+
+  callback <- function() {
+    session$sendChangeTabVisibility(
+      inputId = inputId,
+      target = target,
+      type = "show"
+    )
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @rdname showTab
+#' @export
+hideTab <- function(inputId, target,
+                    session = getDefaultReactiveDomain()) {
+  force(target)
+  inputId <- session$ns(inputId)
+
+  callback <- function() {
+    session$sendChangeTabVisibility(
+      inputId = inputId,
+      target = target,
+      type = "hide"
+    )
+  }
+  session$onFlush(callback, once = TRUE)
+}

R/insert-ui.R

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

R/jqueryui.R

@@ -53,7 +53,6 @@
 #'   over text). The default is \code{"auto"}, which is equivalent to
 #'   \code{ifelse(draggable, "move", "inherit")}.
 #' @return An HTML element or list of elements.
-#'
 #' @export
 absolutePanel <- function(...,
                           top = NULL, left = NULL, right = NULL, bottom = NULL,
@@ -80,9 +79,7 @@ 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/1.10.4/jquery-ui.min.js'))),
+      singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
       divTag,
       tags$script('$(".draggable").draggable();')
     ))
@@ -97,8 +94,8 @@ fixedPanel <- function(...,
                        top = NULL, left = NULL, right = NULL, bottom = NULL,
                        width = NULL, height = NULL,
                        draggable = FALSE,
-                       cursor = c('move', 'default', 'inherit')) {
+                       cursor = c('auto', 'move', 'default', 'inherit')) {
   absolutePanel(..., top=top, left=left, right=right, bottom=bottom,
-                width=width, height=height, draggable=draggable, cursor=cursor,
+                width=width, height=height, draggable=draggable, cursor=match.arg(cursor),
                 fixed=TRUE)
 }

R/map.R

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

R/middleware-shiny.R

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

R/middleware.R

@@ -21,7 +21,7 @@ httpResponse <- function(status = 200,
   # Make sure it's a list, not a vector
   headers <- as.list(headers)
   if (is.null(headers$`X-UA-Compatible`))
-    headers$`X-UA-Compatible` <- "chrome=1"
+    headers$`X-UA-Compatible` <- "IE=edge,chrome=1"
   resp <- list(status = status, content_type = content_type, content = content,
                headers = headers)
   class(resp) <- 'httpResponse'
@@ -191,7 +191,7 @@ staticHandler <- function(root) {
     if (!identical(req$REQUEST_METHOD, 'GET'))
       return(NULL)
 
-    path <- req$PATH_INFO
+    path <- URLdecode(req$PATH_INFO)
 
     if (is.null(path))
       return(httpResponse(400, content="<h1>Bad Request</h1>"))
@@ -203,8 +203,7 @@ staticHandler <- function(root) {
     if (is.null(abs.path))
       return(NULL)
 
-    ext <- tools::file_ext(abs.path)
-    content.type <- getContentType(ext)
+    content.type <- getContentType(abs.path)
     response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
     return(httpResponse(200, content.type, response.content))
   })
@@ -300,9 +299,7 @@ HandlerManager <- R6Class("HandlerManager",
 
           if (reqSize > maxSize) {
             return(list(status = 413L,
-              headers = list(
-                'Content-Type' = 'text/plain'
-              ),
+              headers = list('Content-Type' = 'text/plain'),
               body = 'Maximum upload size exceeded'))
           }
           else {
@@ -311,7 +308,18 @@ HandlerManager <- R6Class("HandlerManager",
         },
         call = .httpServer(
           function (req) {
-            return(handlers$invoke(req))
+            withCallingHandlers(withLogErrors(handlers$invoke(req)),
+              error = function(cond) {
+                sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
+                if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
+                  stop(cond$message, call. = FALSE)
+                } else {
+                  stop(paste("An error has occurred. Check your logs or",
+                             "contact the app author for clarification."),
+                       call. = FALSE)
+                }
+              }
+            )
           },
           getOption('shiny.sharedSecret')
         ),
@@ -333,27 +341,82 @@ HandlerManager <- R6Class("HandlerManager",
             headers=list('Content-Type' = 'text/html')))
         }
 
-        response <- handler(req)
-        if (is.null(response))
-          response <- httpResponse(404, content="<h1>Not Found</h1>")
-
-        if (inherits(response, "httpResponse")) {
-          headers <- as.list(response$headers)
-          headers$'Content-Type' <- response$content_type
-
-          response <- filter(req, response)
-          return(list(status=response$status,
-            body=response$content,
-            headers=headers))
-        } else {
-          # Assume it's a Rook-compatible response
-          return(response)
+        # Catch HEAD requests. For the purposes of handler functions, they
+        # should be treated like GET. The difference is that they shouldn't
+        # return a body in the http response.
+        head_request <- FALSE
+        if (identical(req$REQUEST_METHOD, "HEAD")) {
+          head_request <- TRUE
+          req$REQUEST_METHOD <- "GET"
         }
+
+        response <- handler(req)
+
+        res <- hybrid_chain(response, function(response) {
+          if (is.null(response))
+            response <- httpResponse(404, content="<h1>Not Found</h1>")
+
+          if (inherits(response, "httpResponse")) {
+            headers <- as.list(response$headers)
+            headers$'Content-Type' <- response$content_type
+
+            response <- filter(req, response)
+            if (head_request) {
+
+              headers$`Content-Length` <- getResponseContentLength(response, deleteOwnedContent = TRUE)
+
+              return(list(
+                status = response$status,
+                body = "",
+                headers = headers
+              ))
+            } else {
+              return(list(
+                status = response$status,
+                body = response$content,
+                headers = headers
+              ))
+            }
+
+          } else {
+            # Assume it's a Rook-compatible response
+            return(response)
+          }
+        })
       }
     }
   )
 )
 
+# Safely get the Content-Length of a Rook response, or NULL if the length cannot
+# be determined for whatever reason (probably malformed response$content).
+# If deleteOwnedContent is TRUE, then the function should delete response
+# content that is of the form list(file=..., owned=TRUE).
+getResponseContentLength <- function(response, deleteOwnedContent) {
+  force(deleteOwnedContent)
+
+  result <- if (is.character(response$content) && length(response$content) == 1) {
+    nchar(response$content, type = "bytes")
+  } else if (is.raw(response$content)) {
+    length(response$content)
+  } else if (is.list(response$content) && !is.null(response$content$file)) {
+    if (deleteOwnedContent && isTRUE(response$content$owned)) {
+      on.exit(unlink(response$content$file, recursive = FALSE, force = FALSE), add = TRUE)
+    }
+    file.info(response$content$file)$size
+  } else {
+    warning("HEAD request for unexpected content class ", class(response$content)[[1]])
+    NULL
+  }
+
+  if (is.na(result)) {
+    # Mostly for missing file case
+    return(NULL)
+  } else {
+    return(result)
+  }
+}
+
 #
 # ## Next steps
 #

R/modal.R

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

R/modules.R

@@ -0,0 +1,67 @@
+# Creates an object whose $ and [[ pass through to the parent
+# session, unless the name is matched in ..., in which case
+# that value is returned instead. (See Decorator pattern.)
+createSessionProxy <- function(parentSession, ...) {
+  e <- new.env(parent = emptyenv())
+  e$parent <- parentSession
+  e$overrides <- list(...)
+
+  structure(
+    e,
+    class = "session_proxy"
+  )
+}
+
+#' @export
+`$.session_proxy` <- function(x, name) {
+  if (name %in% names(.subset2(x, "overrides")))
+    .subset2(x, "overrides")[[name]]
+  else
+    .subset2(x, "parent")[[name]]
+}
+
+#' @export
+`[[.session_proxy` <- `$.session_proxy`
+
+
+#' @export
+`$<-.session_proxy` <- function(x, name, value) {
+  # this line allows users to write into session$userData
+  # (e.g. it allows something like `session$userData$x <- TRUE`,
+  # but not `session$userData <- TRUE`) from within a module
+  # without any hacks (see PR #1732)
+  if (identical(x[[name]], value)) return(x)
+  stop("Attempted to assign value on session proxy.")
+}
+
+`[[<-.session_proxy` <- `$<-.session_proxy`
+
+
+#' Invoke a Shiny module
+#'
+#' Shiny's module feature lets you break complicated UI and server logic into
+#' smaller, self-contained pieces. Compared to large monolithic Shiny apps,
+#' modules are easier to reuse and easier to reason about. See the article at
+#' \url{http://shiny.rstudio.com/articles/modules.html} to learn more.
+#'
+#' @param module A Shiny module server function
+#' @param id An ID string that corresponds with the ID used to call the module's
+#'   UI function
+#' @param ... Additional parameters to pass to module server function
+#' @param session Session from which to make a child scope (the default should
+#'   almost always be used)
+#'
+#' @return The return value, if any, from executing the module server function
+#' @seealso \url{http://shiny.rstudio.com/articles/modules.html}
+#' @export
+callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
+  childScope <- session$makeScope(id)
+
+  withReactiveDomain(childScope, {
+    if (!is.function(module)) {
+      stop("module argument must be a function")
+    }
+
+    module(childScope$input, childScope$output, childScope, ...)
+  })
+}

R/notifications.R

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

R/progress.R

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

R/react.R

@@ -1,3 +1,21 @@
+processId <- local({
+  # pid is not sufficient to uniquely identify a process, because
+  # distributed futures span machines which could introduce pid
+  # collisions.
+  cached <- NULL
+  function() {
+    if (is.null(cached)) {
+      cached <<- digest::digest(list(
+        Sys.info(),
+        Sys.time()
+      ))
+    }
+    # Sys.getpid() cannot be cached because forked children will
+    # then have the same processId as their parents.
+    paste(cached, Sys.getpid())
+  }
+})
+
 Context <- R6Class(
   'Context',
   portable = FALSE,
@@ -9,27 +27,37 @@ Context <- R6Class(
     .invalidateCallbacks = list(),
     .flushCallbacks = list(),
     .domain = NULL,
+    .pid = NULL,
 
     initialize = function(domain, label='', type='other', prevId='') {
       id <<- .getReactiveEnvironment()$nextId()
       .label <<- label
       .domain <<- domain
+      .pid <<- processId()
       .graphCreateContext(id, label, type, prevId, domain)
     },
     run = function(func) {
       "Run the provided function under this context."
-      withReactiveDomain(.domain, {
-        env <- .getReactiveEnvironment()
-        .graphEnterContext(id)
-        tryCatch(
-          env$runWith(self, func),
-          finally = .graphExitContext(id)
-        )
+
+      promises::with_promise_domain(reactivePromiseDomain(), {
+        withReactiveDomain(.domain, {
+          env <- .getReactiveEnvironment()
+          .graphEnterContext(id)
+          on.exit({
+            .graphExitContext(id, domain = .domain)
+          }, add = TRUE)
+          env$runWith(self, func)
+        })
       })
     },
     invalidate = function() {
       "Invalidate this context. It will immediately call the callbacks
         that have been registered with onInvalidate()."
+
+      if (!identical(.pid, processId())) {
+        stop("Reactive context was created in one process and invalidated from another")
+      }
+
       if (.invalidated)
         return()
       .invalidated <<- TRUE
@@ -45,6 +73,11 @@ Context <- R6Class(
       "Register a function to be called when this context is invalidated.
         If this context is already invalidated, the function is called
         immediately."
+
+      if (!identical(.pid, processId())) {
+        stop("Reactive context was created in one process and accessed from another")
+      }
+
       if (.invalidated)
         func()
       else
@@ -62,8 +95,9 @@ Context <- R6Class(
     },
     executeFlushCallbacks = function() {
       "For internal use only."
-      lapply(.flushCallbacks, function(func) {
-        func()
+
+      lapply(.flushCallbacks, function(flushCallback) {
+        flushCallback()
       })
     }
   )
@@ -98,25 +132,33 @@ ReactiveEnvironment <- R6Class(
       }
       return(.currentContext)
     },
-    runWith = function(ctx, func) {
+    runWith = function(ctx, contextFunc) {
       old.ctx <- .currentContext
       .currentContext <<- ctx
       on.exit(.currentContext <<- old.ctx)
-      shinyCallingHandlers(func())
+      contextFunc()
     },
     addPendingFlush = function(ctx, priority) {
       .pendingFlush$enqueue(ctx, priority)
     },
+    hasPendingFlush = function() {
+      return(!.pendingFlush$isEmpty())
+    },
+    # Returns TRUE if anything was actually called
     flush = function() {
+      # If nothing to flush, exit early
+      if (!hasPendingFlush()) return(invisible(FALSE))
       # If already in a flush, don't start another one
-      if (.inFlush) return()
+      if (.inFlush) return(invisible(FALSE))
       .inFlush <<- TRUE
       on.exit(.inFlush <<- FALSE)
 
-      while (!.pendingFlush$isEmpty()) {
+      while (hasPendingFlush()) {
         ctx <- .pendingFlush$dequeue()
         ctx$executeFlushCallbacks()
       }
+
+      invisible(TRUE)
     }
   )
 )
@@ -130,9 +172,10 @@ ReactiveEnvironment <- R6Class(
   }
 })
 
-# Causes any pending invalidations to run.
+# Causes any pending invalidations to run. Returns TRUE if any invalidations
+# were pending (i.e. if work was actually done).
 flushReact <- function() {
-  .getReactiveEnvironment()$flush()
+  return(.getReactiveEnvironment()$flush())
 }
 
 # Retrieves the current reactive context, or errors if there is no reactive
@@ -152,3 +195,31 @@ local({
     return(dummyContext)
   }
 })
+
+wrapForContext <- function(func, ctx) {
+  force(func)
+  force(ctx)
+
+  function(...) {
+    ctx$run(function() {
+      captureStackTraces(
+        func(...)
+      )
+    })
+  }
+}
+
+reactivePromiseDomain <- function() {
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      ctx <- getCurrentContext()
+      wrapForContext(onFulfilled, ctx)
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      ctx <- getCurrentContext()
+      wrapForContext(onRejected, ctx)
+    }
+  )
+}

R/reactive-domains.R

@@ -42,11 +42,11 @@ NULL
 #
 ## ------------------------------------------------------------------------
 createMockDomain <- function() {
-  callbacks <- list()
+  callbacks <- Callbacks$new()
   ended <- FALSE
   domain <- new.env(parent = emptyenv())
   domain$onEnded <- function(callback) {
-    callbacks <<- c(callbacks, callback)
+    return(callbacks$register(callback))
   }
   domain$isEnded <- function() {
     ended
@@ -55,10 +55,12 @@ createMockDomain <- function() {
   domain$end <- function() {
     if (!ended) {
       ended <<- TRUE
-      lapply(callbacks, do.call, list())
+      callbacks$invoke()
     }
     invisible()
   }
+  domain$incrementBusyCount <- function() NULL
+  domain$decrementBusyCount <- function() NULL
   return(domain)
 }
 
@@ -93,11 +95,7 @@ getDefaultReactiveDomain <- function() {
 #' @rdname domains
 #' @export
 withReactiveDomain <- function(domain, expr) {
-  oldValue <- .globals$domain
-  .globals$domain <- domain
-  on.exit(.globals$domain <- oldValue)
-
-  expr
+  promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
 }
 
 #

R/render-cached-plot.R

@@ -0,0 +1,588 @@
+#' Plot output with cached images
+#'
+#' Renders a reactive plot, with plot images cached to disk.
+#'
+#' \code{expr} is an expression that generates a plot, similar to that in
+#' \code{renderPlot}. Unlike with \code{renderPlot}, this expression does not
+#' take reactive dependencies. It is re-executed only when the cache key
+#' changes.
+#'
+#' \code{cacheKeyExpr} is an expression which, when evaluated, returns an object
+#' which will be serialized and hashed using the \code{\link[digest]{digest}}
+#' function to generate a string that will be used as a cache key. This key is
+#' used to identify the contents of the plot: if the cache key is the same as a
+#' previous time, it assumes that the plot is the same and can be retrieved from
+#' the cache.
+#'
+#' This \code{cacheKeyExpr} is reactive, and so it will be re-evaluated when any
+#' upstream reactives are invalidated. This will also trigger re-execution of
+#' the plotting expression, \code{expr}.
+#'
+#' The key should consist of "normal" R objects, like vectors and lists. Lists
+#' should in turn contain other normal R objects. If the key contains
+#' environments, external pointers, or reference objects -- or even if it has
+#' such objects attached as attributes -- then it is possible that it will
+#' change unpredictably even when you do not expect it to. Additionally, because
+#' the entire key is serialized and hashed, if it contains a very large object
+#' -- a large data set, for example -- there may be a noticeable performance
+#' penalty.
+#'
+#' If you face these issues with the cache key, you can work around them by
+#' extracting out the important parts of the objects, and/or by converting them
+#' to normal R objects before returning them. Your expression could even
+#' serialize and hash that information in an efficient way and return a string,
+#' which will in turn be hashed (very quickly) by the
+#' \code{\link[digest]{digest}} function.
+#'
+#' Internally, the result from \code{cacheKeyExpr} is combined with the name of
+#' the output (if you assign it to \code{output$plot1}, it will be combined
+#' with \code{"plot1"}) to form the actual key that is used. As a result, even
+#' if there are multiple plots that have the same \code{cacheKeyExpr}, they
+#' will not have cache key collisions.
+#'
+#' @section Cache scoping:
+#'
+#'   There are a number of different ways you may want to scope the cache. For
+#'   example, you may want each user session to have their own plot cache, or
+#'   you may want each run of the application to have a cache (shared among
+#'   possibly multiple simultaneous user sessions), or you may want to have a
+#'   cache that persists even after the application is shut down and started
+#'   again.
+#'
+#'   To control the scope of the cache, use the \code{cache} parameter. There
+#'   are two ways of having Shiny automatically create and clean up the disk
+#'   cache.
+#'
+#' \describe{
+#'   \item{1}{To scope the cache to one run of a Shiny application (shared
+#'     among possibly multiple user sessions), use \code{cache="app"}. This
+#'     is the default. The cache will be shared across multiple sessions, so
+#'     there is potentially a large performance benefit if there are many users
+#'     of the application. When the application stops running, the cache will
+#'     be deleted. If plots cannot be safely shared across users, this should
+#'     not be used.}
+#'   \item{2}{To scope the cache to one session, use \code{cache="session"}.
+#'     When a new user session starts -- in other words, when a web browser
+#'     visits the Shiny application -- a new cache will be created on disk
+#'     for that session. When the session ends, the cache will be deleted.
+#'     The cache will not be shared across multiple sessions.}
+#'  }
+#'
+#'   If either \code{"app"} or \code{"session"} is used, the cache will be 10 MB
+#'   in size, and will be stored stored in memory, using a
+#'   \code{\link{memoryCache}} object. Note that the cache space will be shared
+#'   among all cached plots within a single application or session.
+#'
+#'   In some cases, you may want more control over the caching behavior. For
+#'   example, you may want to use a larger or smaller cache, share a cache
+#'   among multiple R processes, or you may want the cache to persist across
+#'   multiple runs of an application, or even across multiple R processes.
+#'
+#'   To use different settings for an application-scoped cache, you can call
+#'   \code{\link{shinyOptions}()} at the top of your app.R, server.R, or
+#'   global.R. For example, this will create a cache with 20 MB of space
+#'   instead of the default 10 MB:
+#'   \preformatted{
+#'   shinyOptions(cache = memoryCache(size = 20e6))
+#'   }
+#'
+#'   To use different settings for a session-scoped cache, you can call
+#'   \code{\link{shinyOptions}()} at the top of your server function. To use
+#'   the session-scoped cache, you must also call \code{renderCachedPlot} with
+#'   \code{cache="session"}. This will create a 20 MB cache for the session:
+#'   \preformatted{
+#'   function(input, output, session) {
+#'     shinyOptions(cache = memoryCache(size = 20e6))
+#'
+#'     output$plot <- renderCachedPlot(
+#'       ...,
+#'       cache = "session"
+#'     )
+#'   }
+#'   }
+#'
+#'   If you want to create a cache that is shared across multiple concurrent
+#'   R processes, you can use a \code{\link{diskCache}}. You can create an
+#'   application-level shared cache by putting this at the top of your app.R,
+#'   server.R, or global.R:
+#'   \preformatted{
+#'   shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
+#'   }
+#'
+#'   This will create a subdirectory in your system temp directory named
+#'   \code{myapp-cache} (replace \code{myapp-cache} with a unique name of
+#'   your choosing). On most platforms, this directory will be removed when
+#'   your system reboots. This cache will persist across multiple starts and
+#'   stops of the R process, as long as you do not reboot.
+#'
+#'   To have the cache persist even across multiple reboots, you can create the
+#'   cache in a location outside of the temp directory. For example, it could
+#'   be a subdirectory of the application:
+#'   \preformatted{
+#'   shinyOptions(cache = diskCache("./myapp-cache"))
+#'   }
+#'
+#'   In this case, resetting the cache will have to be done manually, by deleting
+#'   the directory.
+#'
+#'   You can also scope a cache to just one plot, or selected plots. To do that,
+#'   create a \code{\link{memoryCache}} or \code{\link{diskCache}}, and pass it
+#'   as the \code{cache} argument of \code{renderCachedPlot}.
+#'
+#' @section Interactive plots:
+#'
+#'   \code{renderCachedPlot} can be used to create interactive plots. See
+#'   \code{\link{plotOutput}} for more information and examples.
+#'
+#'
+#' @inheritParams renderPlot
+#' @param cacheKeyExpr An expression that returns a cache key. This key should
+#'   be a unique identifier for a plot: the assumption is that if the cache key
+#'   is the same, then the plot will be the same.
+#' @param sizePolicy A function that takes two arguments, \code{width} and
+#'   \code{height}, and returns a list with \code{width} and \code{height}. The
+#'   purpose is to round the actual pixel dimensions from the browser to some
+#'   other dimensions, so that this will not generate and cache images of every
+#'   possible pixel dimension. See \code{\link{sizeGrowthRatio}} for more
+#'   information on the default sizing policy.
+#' @param res The resolution of the PNG, in pixels per inch.
+#' @param cache The scope of the cache, or a cache object. This can be
+#'   \code{"app"} (the default), \code{"session"}, or a cache object like
+#'   a \code{\link{diskCache}}. See the Cache Scoping section for more
+#'   information.
+#'
+#' @seealso See \code{\link{renderPlot}} for the regular, non-cached version of
+#'   this function. For more about configuring caches, see
+#'   \code{\link{memoryCache}} and \code{\link{diskCache}}.
+#'
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # A basic example that uses the default app-scoped memory cache.
+#' # The cache will be shared among all simultaneous users of the application.
+#' shinyApp(
+#'   fluidPage(
+#'     sidebarLayout(
+#'       sidebarPanel(
+#'         sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
+#'       ),
+#'       mainPanel(plotOutput("plot"))
+#'     )
+#'   ),
+#'   function(input, output, session) {
+#'     output$plot <- renderCachedPlot({
+#'         Sys.sleep(2)  # Add an artificial delay
+#'         seqn <- seq_len(input$n)
+#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+#'       },
+#'       cacheKeyExpr = { list(input$n) }
+#'     )
+#'   }
+#' )
+#'
+#'
+#'
+#' # An example uses a data object shared across sessions. mydata() is part of
+#' # the cache key, so when its value changes, plots that were previously
+#' # stored in the cache will no longer be used (unless mydata() changes back
+#' # to its previous value).
+#' mydata <- reactiveVal(data.frame(x = rnorm(400), y = rnorm(400)))
+#'
+#' ui <- fluidPage(
+#'   sidebarLayout(
+#'     sidebarPanel(
+#'       sliderInput("n", "Number of points", 50, 400, 100, step = 50),
+#'       actionButton("newdata", "New data")
+#'     ),
+#'     mainPanel(
+#'       plotOutput("plot")
+#'     )
+#'   )
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observeEvent(input$newdata, {
+#'     mydata(data.frame(x = rnorm(400), y = rnorm(400)))
+#'   })
+#'
+#'   output$plot <- renderCachedPlot(
+#'     {
+#'       Sys.sleep(2)
+#'       d <- mydata()
+#'       seqn <- seq_len(input$n)
+#'       plot(d$x[seqn], d$y[seqn], xlim = range(d$x), ylim = range(d$y))
+#'     },
+#'     cacheKeyExpr = { list(input$n, mydata()) },
+#'   )
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#'
+#' # A basic application with two plots, where each plot in each session has
+#' # a separate cache.
+#' shinyApp(
+#'   fluidPage(
+#'     sidebarLayout(
+#'       sidebarPanel(
+#'         sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
+#'       ),
+#'       mainPanel(
+#'         plotOutput("plot1"),
+#'         plotOutput("plot2")
+#'       )
+#'     )
+#'   ),
+#'   function(input, output, session) {
+#'     output$plot1 <- renderCachedPlot({
+#'         Sys.sleep(2)  # Add an artificial delay
+#'         seqn <- seq_len(input$n)
+#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+#'       },
+#'       cacheKeyExpr = { list(input$n) },
+#'       cache = memoryCache()
+#'     )
+#'     output$plot2 <- renderCachedPlot({
+#'         Sys.sleep(2)  # Add an artificial delay
+#'         seqn <- seq_len(input$n)
+#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+#'       },
+#'       cacheKeyExpr = { list(input$n) },
+#'       cache = memoryCache()
+#'     )
+#'   }
+#' )
+#'
+#' }
+#'
+#' \dontrun{
+#' # At the top of app.R, this set the application-scoped cache to be a memory
+#' # cache that is 20 MB in size, and where cached objects expire after one
+#' # hour.
+#' shinyOptions(cache = memoryCache(max_size = 20e6, max_age = 3600))
+#'
+#' # At the top of app.R, this set the application-scoped cache to be a disk
+#' # cache that can be shared among multiple concurrent R processes, and is
+#' # deleted when the system reboots.
+#' shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
+#'
+#' # At the top of app.R, this set the application-scoped cache to be a disk
+#' # cache that can be shared among multiple concurrent R processes, and
+#' # persists on disk across reboots.
+#' shinyOptions(cache = diskCache("./myapp-cache"))
+#'
+#' # At the top of the server function, this set the session-scoped cache to be
+#' # a memory cache that is 5 MB in size.
+#' server <- function(input, output, session) {
+#'   shinyOptions(cache = memoryCache(max_size = 5e6))
+#'
+#'   output$plot <- renderCachedPlot(
+#'     ...,
+#'     cache = "session"
+#'   )
+#' }
+#'
+#' }
+#' @export
+renderCachedPlot <- function(expr,
+  cacheKeyExpr,
+  sizePolicy = sizeGrowthRatio(width = 400, height = 400, growthRate = 1.2),
+  res = 72,
+  cache = "app",
+  ...,
+  outputArgs = list()
+) {
+
+  # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
+  # is called
+  installExprFunction(expr, "func", parent.frame(), quoted = FALSE, ..stacktraceon = TRUE)
+  # This is so that the expr doesn't re-execute by itself; it needs to be
+  # triggered by the cache key (or width/height) changing.
+  isolatedFunc <- function() isolate(func())
+
+  args <- list(...)
+
+  cacheKeyExpr <- substitute(cacheKeyExpr)
+  # The real cache key we'll use also includes width, height, res, pixelratio.
+  # This is just the part supplied by the user.
+  userCacheKey <- reactive(cacheKeyExpr, env = parent.frame(), quoted = TRUE, label = "userCacheKey")
+
+  ensureCacheSetup <- function() {
+    # For our purposes, cache objects must support these methods.
+    isCacheObject <- function(x) {
+      # Use tryCatch in case the object does not support `$`.
+      tryCatch(
+        is.function(x$get) && is.function(x$set),
+        error = function(e) FALSE
+      )
+    }
+
+    if (isCacheObject(cache)) {
+      # If `cache` is already a cache object, do nothing
+      return()
+
+    } else if (identical(cache, "app")) {
+      cache <<- getShinyOption("cache")
+
+    } else if (identical(cache, "session")) {
+      cache <<- session$cache
+
+    } else {
+      stop('`cache` must either be "app", "session", or a cache object with methods, `$get`, and `$set`.')
+    }
+  }
+
+  # The width and height of the plot to draw, given from sizePolicy. These
+  # values get filled by an observer below.
+  fitDims <- reactiveValues(width = NULL, height = NULL)
+
+  resizeObserver <- NULL
+  ensureResizeObserver <- function() {
+    if (!is.null(resizeObserver))
+      return()
+
+    # Given the actual width/height of the image in the browser, this gets the
+    # width/height from sizePolicy() and pushes those values into `fitDims`.
+    # It's done this way so that the `fitDims` only change (and cause
+    # invalidations) when the rendered image size changes, and not every time
+    # the browser's <img> tag changes size.
+    doResizeCheck <- function() {
+      width  <- session$clientData[[paste0('output_', outputName, '_width')]]
+      height <- session$clientData[[paste0('output_', outputName, '_height')]]
+
+      if (is.null(width)) width <- 0
+      if (is.null(height)) height <- 0
+
+      rect <- sizePolicy(c(width, height))
+      fitDims$width  <- rect[1]
+      fitDims$height <- rect[2]
+    }
+
+    # Run it once immediately, then set up the observer
+    isolate(doResizeCheck())
+
+    resizeObserver <<- observe(doResizeCheck())
+  }
+
+  # Vars to store session and output, so that they can be accessed from
+  # the plotObj() reactive.
+  session <- NULL
+  outputName <- NULL
+
+
+  drawReactive <- reactive(label = "plotObj", {
+    hybrid_chain(
+      # Depend on the user cache key, even though we don't use the value. When
+      # it changes, it can cause the drawReactive to re-execute. (Though
+      # drawReactive will not necessarily re-execute -- it must be called from
+      # renderFunc, which happens only if there's a cache miss.)
+      userCacheKey(),
+      function(userCacheKeyValue) {
+        # Get width/height, but don't depend on them.
+        isolate({
+          width  <- fitDims$width
+          height <- fitDims$height
+        })
+
+        pixelratio <- session$clientData$pixelratio %OR% 1
+
+        do.call("drawPlot", c(
+          list(
+            name = outputName,
+            session = session,
+            func = isolatedFunc,
+            width = width,
+            height = height,
+            pixelratio = pixelratio,
+            res = res
+          ),
+          args
+        ))
+      },
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        fitDims$width
+        fitDims$height
+
+        # Propagate the error
+        stop(reason)
+      }
+    )
+  })
+
+
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned.
+  renderFunc <- function(shinysession, name, ...) {
+    outputName <<- name
+    session <<- shinysession
+    ensureCacheSetup()
+    ensureResizeObserver()
+
+    hybrid_chain(
+      # This use of the userCacheKey() sets up the reactive dependency that
+      # causes plot re-draw events. These may involve pulling from the cache,
+      # replaying a display list, or re-executing user code.
+      userCacheKey(),
+      function(userCacheKeyResult) {
+        width  <- fitDims$width
+        height <- fitDims$height
+        pixelratio <- session$clientData$pixelratio %OR% 1
+
+        key <- digest::digest(list(outputName, userCacheKeyResult, width, height, res, pixelratio), "xxhash64")
+
+        plotObj <- cache$get(key)
+
+        # First look in cache.
+        # Case 1. cache hit.
+        if (!is.key_missing(plotObj)) {
+          return(list(
+            cacheHit = TRUE,
+            key = key,
+            plotObj = plotObj,
+            width = width,
+            height = height,
+            pixelratio = pixelratio
+          ))
+        }
+
+        # If not in cache, hybrid_chain call to drawReactive
+        #
+        # Two more possible cases:
+        #   2. drawReactive will re-execute and return a plot that's the
+        #      correct size.
+        #   3. It will not re-execute, but it will return the previous value,
+        #      which is the wrong size. It will include a valid display list
+        #      which can be used by resizeSavedPlot.
+        hybrid_chain(
+          drawReactive(),
+          function(drawReactiveResult) {
+            # Pass along the key for caching in the next stage
+            list(
+              cacheHit = FALSE,
+              key = key,
+              plotObj = drawReactiveResult,
+              width = width,
+              height = height,
+              pixelratio = pixelratio
+            )
+          }
+        )
+      },
+      function(result) {
+        width      <- result$width
+        height     <- result$height
+        pixelratio <- result$pixelratio
+
+        # Three possibilities when we get here:
+        # 1. There was a cache hit. No need to set a value in the cache.
+        # 2. There was a cache miss, and the plotObj is already the correct
+        #    size (because drawReactive re-executed). In this case, we need
+        #    to cache it.
+        # 3. There was a cache miss, and the plotObj was not the corect size.
+        #    In this case, we need to replay the display list, and then cache
+        #    the result.
+        if (!result$cacheHit) {
+          # If the image is already the correct size, this just returns the
+          # object unchanged.
+          result$plotObj <- do.call("resizeSavedPlot", c(
+            list(
+              name,
+              shinysession,
+              result$plotObj,
+              width,
+              height,
+              pixelratio,
+              res
+            ),
+            args
+          ))
+
+          # Save a cached copy of the plotObj. The recorded displaylist for
+          # the plot can't be serialized and restored properly within the same
+          # R session, so we NULL it out before saving. (The image data and
+          # other metadata be saved and restored just fine.) Displaylists can
+          # also be very large (~1.5MB for a basic ggplot), and they would not
+          # be commonly used. Note that displaylist serialization was fixed in
+          # revision 74506 (2e6c669), and should be in R 3.6. A MemoryCache
+          # doesn't need to serialize objects, so it could actually save a
+          # display list, but for the reasons listed previously, it's
+          # generally not worth it.
+          # The plotResult is not the same as the recordedPlot (it is used to
+          # retrieve coordmap information for ggplot2 objects) but it is only
+          # used in conjunction with the recordedPlot, and we'll remove it
+          # because it can be quite large.
+          result$plotObj$plotResult <- NULL
+          result$plotObj$recordedPlot <- NULL
+          cache$set(result$key, result$plotObj)
+        }
+
+        img <- result$plotObj$img
+        # Replace exact pixel dimensions; instead, the max-height and
+        # max-width will be set to 100% from CSS.
+        img$class <- "shiny-scalable"
+        img$width  <- NULL
+        img$height <- NULL
+
+        img
+      }
+    )
+  }
+
+  # If renderPlot isn't going to adapt to the height of the div, then the
+  # div needs to adapt to the height of renderPlot. By default, plotOutput
+  # sets the height to 400px, so to make it adapt we need to override it
+  # with NULL.
+  outputFunc <- plotOutput
+  formals(outputFunc)['height'] <- list(NULL)
+
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+}
+
+
+#' Create a sizing function that grows at a given ratio
+#'
+#' Returns a function which takes a two-element vector representing an input
+#' width and height, and returns a two-element vector of width and height. The
+#' possible widths are the base width times the growthRate to any integer power.
+#' For example, with a base width of 500 and growth rate of 1.25, the possible
+#' widths include 320, 400, 500, 625, 782, and so on, both smaller and larger.
+#' Sizes are rounded up to the next pixel. Heights are computed the same way as
+#' widths.
+#'
+#' @param width,height Base width and height.
+#' @param growthRate Growth rate multiplier.
+#'
+#' @seealso This is to be used with \code{\link{renderCachedPlot}}.
+#'
+#' @examples
+#' f <- sizeGrowthRatio(500, 500, 1.25)
+#' f(c(400, 400))
+#' f(c(500, 500))
+#' f(c(530, 550))
+#' f(c(625, 700))
+#'
+#' @export
+sizeGrowthRatio <- function(width = 400, height = 400, growthRate = 1.2) {
+  round_dim_up <- function(x, base, rate) {
+    power <- ceiling(log(x / base, rate))
+    ceiling(base * rate^power)
+  }
+
+  function(dims) {
+    if (length(dims) != 2) {
+      stop("dims must be a vector with two numbers, for width and height.")
+    }
+    c(
+      round_dim_up(dims[1], width,  growthRate),
+      round_dim_up(dims[2], height, growthRate)
+    )
+  }
+}

R/render-plot.R

@@ -0,0 +1,997 @@
+#' Plot Output
+#'
+#' Renders a reactive plot that is suitable for assigning to an \code{output}
+#' slot.
+#'
+#' 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}}.
+#'
+#' @param expr An expression that generates a plot.
+#' @param width,height The width/height of the rendered plot, in pixels; or
+#'   \code{'auto'} to use the \code{offsetWidth}/\code{offsetHeight} of the HTML
+#'   element that is bound to this plot. You can also pass in a function that
+#'   returns the width/height in pixels or \code{'auto'}; in the body of the
+#'   function you may reference reactive values and functions. When rendering an
+#'   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
+#'   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.
+#' @export
+renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
+                       env=parent.frame(), quoted=FALSE,
+                       execOnResize=FALSE, outputArgs=list()
+) {
+  # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
+  # is called
+  installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
+
+  args <- list(...)
+
+  if (is.reactive(width))
+    widthWrapper <- width
+  else if (is.function(width))
+    widthWrapper <- reactive({ width() })
+  else
+    widthWrapper <- function() { width }
+
+  if (is.reactive(height))
+    heightWrapper <- height
+  else if (is.function(height))
+    heightWrapper <- reactive({ height() })
+  else
+    heightWrapper <- function() { height }
+
+  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
+
+  # Calls drawPlot, invoking the user-provided `func` (which may or may not
+  # return a promise). The idea is that the (cached) return value from this
+  # reactive can be used for varying width/heights, as it includes the
+  # displaylist, which is resolution independent.
+  drawReactive <- reactive(label = "plotObj", {
+    hybrid_chain(
+      {
+        # If !execOnResize, don't invalidate when width/height changes.
+        dims <- if (execOnResize) getDims() else isolate(getDims())
+        pixelratio <- session$clientData$pixelratio %OR% 1
+        do.call("drawPlot", c(
+          list(
+            name = outputName,
+            session = session,
+            func = func,
+            width = dims$width,
+            height = dims$height,
+            pixelratio = pixelratio,
+            res = res
+          ), args))
+      },
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        getDims()
+
+        # Propagate the error
+        stop(reason)
+      }
+    )
+  })
+
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned.
+  renderFunc <- function(shinysession, name, ...) {
+    outputName <<- name
+    session <<- shinysession
+
+    hybrid_chain(
+      drawReactive(),
+      function(result) {
+        dims <- getDims()
+        pixelratio <- session$clientData$pixelratio %OR% 1
+        result <- do.call("resizeSavedPlot", c(
+          list(name, shinysession, result, dims$width, dims$height, pixelratio, res),
+          args
+        ))
+
+        result$img
+      }
+    )
+  }
+
+  # If renderPlot isn't going to adapt to the height of the div, then the
+  # div needs to adapt to the height of renderPlot. By default, plotOutput
+  # sets the height to 400px, so to make it adapt we need to override it
+  # with NULL.
+  outputFunc <- plotOutput
+  if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
+
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+}
+
+resizeSavedPlot <- function(name, session, result, width, height, pixelratio, res, ...) {
+  if (result$img$width == width && result$img$height == height &&
+      result$pixelratio == pixelratio && result$res == res) {
+    return(result)
+  }
+
+  coordmap <- NULL
+  outfile <- plotPNG(function() {
+    grDevices::replayPlot(result$recordedPlot)
+    coordmap <<- getCoordmap(result$plotResult, width*pixelratio, height*pixelratio, res*pixelratio)
+  }, width = width*pixelratio, height = height*pixelratio, res = res*pixelratio, ...)
+  on.exit(unlink(outfile), add = TRUE)
+
+  result$img <- list(
+    src = session$fileUrl(name, outfile, contentType = "image/png"),
+    width = width,
+    height = height,
+    coordmap = coordmap,
+    error = attr(coordmap, "error", exact = TRUE)
+  )
+
+  result
+}
+
+drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
+  #  1. Start PNG
+  #  2. Enable displaylist recording
+  #  3. Call user-defined func
+  #  4. Print/save result, if visible
+  #  5. Snapshot displaylist
+  #  6. Form coordmap
+  #  7. End PNG (in finally)
+  #  8. Form img tag
+  #  9. Return img, value, displaylist, coordmap
+  # 10. On error, take width and height dependency
+
+  outfile <- tempfile(fileext='.png') # If startPNG throws, this could leak. Shrug.
+  device <- startPNG(outfile, width*pixelratio, height*pixelratio, res = res*pixelratio, ...)
+  domain <- createGraphicsDevicePromiseDomain(device)
+  grDevices::dev.control(displaylist = "enable")
+
+  hybrid_chain(
+    hybrid_chain(
+      promises::with_promise_domain(domain, {
+        hybrid_chain(
+          func(),
+          function(value, .visible) {
+            if (.visible) {
+              # 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 <- custom_print.ggplot
+
+              # 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.
+                result <- ..stacktraceon..(print(value))
+                # TODO jcheng 2017-04-11: Verify above ..stacktraceon..
+              })
+              result
+            } else {
+              # Not necessary, but I wanted to make it explicit
+              NULL
+            }
+          },
+          function(value) {
+            list(
+              plotResult = value,
+              recordedPlot = grDevices::recordPlot(),
+              coordmap = getCoordmap(value, width*pixelratio, height*pixelratio, res*pixelratio),
+              pixelratio = pixelratio,
+              res = res
+            )
+          }
+        )
+      }),
+      finally = function() {
+        grDevices::dev.off(device)
+      }
+    ),
+    function(result) {
+      result$img <- dropNulls(list(
+        src = session$fileUrl(name, outfile, contentType='image/png'),
+        width = width,
+        height = height,
+        coordmap = result$coordmap,
+        # Get coordmap error message if present
+        error = attr(result$coordmap, "error", exact = TRUE)
+      ))
+
+      result
+    },
+    finally = function() {
+      unlink(outfile)
+    }
+  )
+}
+
+# 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
+custom_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")
+}
+
+# The coordmap extraction functions below return something like the examples
+# below. For base graphics:
+# plot(mtcars$wt, mtcars$mpg)
+# str(getPrevPlotCoordmap(400, 300))
+# List of 2
+#  $ panels:List of 1
+#   ..$ :List of 4
+#   .. ..$ domain :List of 4
+#   .. .. ..$ left  : num 1.36
+#   .. .. ..$ right : num 5.58
+#   .. .. ..$ bottom: num 9.46
+#   .. .. ..$ top   : num 34.8
+#   .. ..$ range  :List of 4
+#   .. .. ..$ left  : num 65.6
+#   .. .. ..$ right : num 366
+#   .. .. ..$ bottom: num 238
+#   .. .. ..$ top   : num 48.2
+#   .. ..$ log    :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ mapping: Named list()
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
+#
+# For ggplot2, first you need to define the print.ggplot function from inside
+# renderPlot, then use it to print the plot:
+# 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")
+# }
+#
+# p <- print(ggplot(mtcars, aes(wt, mpg)) + geom_point())
+# str(getGgplotCoordmap(p, 400, 300, 72))
+# List of 2
+#  $ panels:List of 1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 1
+#   .. ..$ row       : num 1
+#   .. ..$ col       : num 1
+#   .. ..$ panel_vars: Named list()
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 2
+#   .. .. ..$ x: chr "wt"
+#   .. .. ..$ y: chr "mpg"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 33.3
+#   .. .. ..$ right : num 355
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 5.48
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
+#
+# With a faceted ggplot2 plot, the outer list contains two objects, each of
+# which represents one panel. In this example, there is one panelvar, but there
+# can be up to two of them.
+# mtc <- mtcars
+# mtc$am <- factor(mtc$am)
+# p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am))
+# str(getGgplotCoordmap(p, 400, 300, 72))
+# List of 2
+#  $ panels:List of 2
+#   ..$ :List of 8
+#   .. ..$ panel     : num 1
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 1
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "wt"
+#   .. .. ..$ y        : chr "mpg"
+#   .. .. ..$ panelvar1: chr "am"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 33.3
+#   .. .. ..$ right : num 191
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 23.1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 2
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 2
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "wt"
+#   .. .. ..$ y        : chr "mpg"
+#   .. .. ..$ panelvar1: chr "am"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 197
+#   .. .. ..$ right : num 355
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 23.1
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
+
+
+getCoordmap <- function(x, width, height, res) {
+  if (inherits(x, "ggplot_build_gtable")) {
+    getGgplotCoordmap(x, width, height, res)
+  } else {
+    getPrevPlotCoordmap(width, height)
+  }
+}
+
+# Get a coordmap for the previous plot made with base graphics.
+# Requires width and height of output image, in pixels.
+# Must be called before the graphics device is closed.
+getPrevPlotCoordmap <- function(width, height) {
+  usrCoords <- graphics::par('usr')
+  usrBounds <- usrCoords
+  if (graphics::par('xlog')) {
+    usrBounds[c(1,2)] <- 10 ^ usrBounds[c(1,2)]
+  }
+  if (graphics::par('ylog')) {
+    usrBounds[c(3,4)] <- 10 ^ usrBounds[c(3,4)]
+  }
+
+  # Wrapped in double list because other types of plots can have multiple panels.
+  panel_info <- list(list(
+    # Bounds of the plot area, in data space
+    domain = list(
+      left = usrCoords[1],
+      right = usrCoords[2],
+      bottom = usrCoords[3],
+      top = usrCoords[4]
+    ),
+    # The bounds of the plot area, in DOM pixels
+    range = list(
+      left = graphics::grconvertX(usrBounds[1], 'user', 'ndc') * width,
+      right = graphics::grconvertX(usrBounds[2], 'user', 'ndc') * width,
+      bottom = (1-graphics::grconvertY(usrBounds[3], 'user', 'ndc')) * height - 1,
+      top = (1-graphics::grconvertY(usrBounds[4], 'user', 'ndc')) * height - 1
+    ),
+    log = list(
+      x = if (graphics::par('xlog')) 10 else NULL,
+      y = if (graphics::par('ylog')) 10 else NULL
+    ),
+    # We can't extract the original variable names from a base graphic.
+    # `mapping` is an empty _named_ list, so that it is converted to an object
+    # (not an array) in JSON.
+    mapping = list(x = NULL)[0]
+  ))
+
+  list(
+    panels = panel_info,
+    dims = list(
+      width = width,
+      height =height
+    )
+  )
+}
+
+# Given a ggplot_build_gtable object, return a coordmap for it.
+getGgplotCoordmap <- function(p, width, height, res) {
+  if (!inherits(p, "ggplot_build_gtable"))
+    return(NULL)
+
+  tryCatch({
+    # Get info from built ggplot object
+    panel_info <- find_panel_info(p$build)
+
+    # Get ranges from gtable - it's possible for this to return more elements than
+    # info, because it calculates positions even for panels that aren't present.
+    # This can happen with facet_wrap.
+    ranges <- find_panel_ranges(p$gtable, res)
+
+    for (i in seq_along(panel_info)) {
+      panel_info[[i]]$range <- ranges[[i]]
+    }
+
+    return(
+      list(
+        panels = panel_info,
+        dims = list(
+          width = width,
+          height = height
+        )
+      )
+    )
+
+  }, 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))
+  })
+}
+
+
+find_panel_info <- function(b) {
+  # Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
+  # an API for extracting the necessary information.
+  ggplot_ver <- utils::packageVersion("ggplot2")
+
+  if (ggplot_ver > "2.2.1") {
+    find_panel_info_api(b)
+  } else if (ggplot_ver > "2.1.0") {
+    find_panel_info_non_api(b, ggplot_format = "new")
+  } else {
+    find_panel_info_non_api(b, ggplot_format = "old")
+  }
+}
+
+# This is for ggplot2>2.2.1, after an API was introduced for extracting
+# information about the plot object.
+find_panel_info_api <- function(b) {
+  # Given a built ggplot object, return x and y domains (data space coords) for
+  # each panel.
+  layout <- ggplot2::summarise_layout(b)
+  coord  <- ggplot2::summarise_coord(b)
+  layers <- ggplot2::summarise_layers(b)
+
+  # Given x and y scale objects and a coord object, return a list that has
+  # the bases of log transformations for x and y, or NULL if it's not a
+  # log transform.
+  get_log_bases <- function(xscale, yscale, coord) {
+    # Given a transform object, find the log base; if the transform object is
+    # NULL, or if it's not a log transform, return NA.
+    get_log_base <- function(trans) {
+      if (!is.null(trans) && grepl("^log-", trans$name)) {
+        environment(trans$transform)$base
+      } else {
+        NA_real_
+      }
+    }
+
+    # First look for log base in scale, then coord; otherwise NULL.
+    list(
+      x = get_log_base(xscale$trans) %OR% coord$xlog %OR% NULL,
+      y = get_log_base(yscale$trans) %OR% coord$ylog %OR% NULL
+    )
+  }
+
+  # Given x/y min/max, and the x/y scale objects, create a list that
+  # represents the domain. Note that the x/y min/max should be taken from
+  # the layout summary table, not the scale objects.
+  get_domain <- function(xmin, xmax, ymin, ymax, xscale, yscale) {
+    is_reverse <- function(scale) {
+      identical(scale$trans$name, "reverse")
+    }
+
+    domain <- list(
+      left   = xmin,
+      right  = xmax,
+      bottom = ymin,
+      top    = ymax
+    )
+
+    if (is_reverse(xscale)) {
+      domain$left  <- -domain$left
+      domain$right <- -domain$right
+    }
+    if (is_reverse(yscale)) {
+      domain$top    <- -domain$top
+      domain$bottom <- -domain$bottom
+    }
+
+    domain
+  }
+
+  # Rename the items in vars to have names like panelvar1, panelvar2.
+  rename_panel_vars <- function(vars) {
+    for (i in seq_along(vars)) {
+      names(vars)[i] <- paste0("panelvar", i)
+    }
+    vars
+  }
+
+  get_mappings <- function(layers, layout, coord) {
+    # For simplicity, we'll just use the mapping from the first layer of the
+    # ggplot object. The original uses quoted expressions; convert to
+    # character.
+    mapping <- layers$mapping[[1]]
+    # In ggplot2 <=2.2.1, the mappings are expressions. In later versions, they
+    # are quosures. `deparse(quo_squash(x))` will handle both cases.
+    # as.character results in unexpected behavior for expressions like `wt/2`,
+    # which is why we use deparse.
+    mapping <- lapply(mapping, function(x) deparse(rlang::quo_squash(x)))
+
+    # If either x or y is not present, give it a NULL entry.
+    mapping <- mergeVectors(list(x = NULL, y = NULL), mapping)
+
+    # The names (not values) of panel vars are the same across all panels,
+    # so just look at the first one. Also, the order of panel vars needs
+    # to be reversed.
+    vars <- rev(layout$vars[[1]])
+    for (i in seq_along(vars)) {
+      mapping[[paste0("panelvar", i)]] <- names(vars)[i]
+    }
+
+    if (isTRUE(coord$flip)) {
+      mapping[c("x", "y")] <- mapping[c("y", "x")]
+    }
+
+    mapping
+  }
+
+  # Mapping is constant across all panels, so get it here and reuse later.
+  mapping <- get_mappings(layers, layout, coord)
+
+  # If coord_flip is used, these need to be swapped
+  flip_xy <- function(layout) {
+    l <- layout
+    l$xscale <- layout$yscale
+    l$yscale <- layout$xscale
+    l$xmin <- layout$ymin
+    l$xmax <- layout$ymax
+    l$ymin <- layout$xmin
+    l$ymax <- layout$xmax
+    l
+  }
+  if (coord$flip) {
+    layout <- flip_xy(layout)
+  }
+
+  # Iterate over each row in the layout data frame
+  lapply(seq_len(nrow(layout)), function(i) {
+    # Slice out one row, use it as a list. The (former) list-cols are still
+    # in lists, so we need to unwrap them.
+    l <- as.list(layout[i, ])
+    l$vars   <- l$vars[[1]]
+    l$xscale <- l$xscale[[1]]
+    l$yscale <- l$yscale[[1]]
+
+    list(
+      panel   = as.numeric(l$panel),
+      row     = l$row,
+      col     = l$col,
+      # Rename panel vars. They must also be in reversed order.
+      panel_vars = rename_panel_vars(rev(l$vars)),
+      log     = get_log_bases(l$xscale, l$yscale, coord),
+      domain  = get_domain(l$xmin, l$xmax, l$ymin, l$ymax, l$xscale, l$yscale),
+      mapping = mapping
+    )
+  })
+}
+
+
+# This is for ggplot2<=2.2.1, before an API was introduced for extracting
+# information about the plot object. The "old" format was used before 2.1.0.
+# The "new" format was used after 2.1.0, up to 2.2.1. The reason these two
+# formats are mixed together in a single function is historical, and it's not
+# worthwhile to separate them at this point.
+find_panel_info_non_api <- function(b, ggplot_format) {
+  # 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 (ggplot_format == "new") {
+      range <- b$layout$panel_ranges[[panel_num]]
+    } else {
+      range <- b$panel$ranges[[panel_num]]
+    }
+    domain <- list(
+      left   = range$x.range[1],
+      right  = range$x.range[2],
+      bottom = range$y.range[1],
+      top    = range$y.range[2]
+    )
+
+    # Check for reversed scales
+    if (ggplot_format == "new") {
+      xscale <- b$layout$panel_scales$x[[scalex_num]]
+      yscale <- b$layout$panel_scales$y[[scaley_num]]
+    } else {
+      xscale <- b$panel$x_scales[[scalex_num]]
+      yscale <- b$panel$y_scales[[scaley_num]]
+    }
+    if (!is.null(xscale$trans) && xscale$trans$name == "reverse") {
+      domain$left  <- -domain$left
+      domain$right <- -domain$right
+    }
+    if (!is.null(yscale$trans) && yscale$trans$name == "reverse") {
+      domain$top    <- -domain$top
+      domain$bottom <- -domain$bottom
+    }
+
+    domain
+  }
+
+  # Given built ggplot object, return object with the log base for x and y if
+  # there are log scales or coord transforms.
+  check_log_scales <- function(b, scalex_num = 1, scaley_num = 1) {
+
+    # Given a vector of transformation names like c("log-10", "identity"),
+    # return the first log base, like 10. If none are present, return NULL.
+    extract_log_base <- function(names) {
+      names <- names[grepl("^log-", names)]
+
+      if (length(names) == 0)
+        return(NULL)
+
+      names <- names[1]
+
+      as.numeric(sub("^log-", "", names))
+    }
+
+    # Look for log scales and log coord transforms. People shouldn't use both.
+    x_names <- character(0)
+    y_names <- character(0)
+
+    # Continuous scales have a trans; discrete ones don't
+    if (ggplot_format == "new") {
+      if (!is.null(b$layout$panel_scales$x[[scalex_num]]$trans))
+        x_names <- b$layout$panel_scales$x[[scalex_num]]$trans$name
+      if (!is.null(b$layout$panel_scales$y[[scaley_num]]$trans))
+        y_names <- b$layout$panel_scales$y[[scaley_num]]$trans$name
+
+    } else {
+      if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
+        x_names <- b$panel$x_scales[[scalex_num]]$trans$name
+      if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
+        y_names <- b$panel$y_scales[[scaley_num]]$trans$name
+    }
+
+    coords <- b$plot$coordinates
+    if (!is.null(coords$trans)) {
+      if (!is.null(coords$trans$x))
+        x_names <- c(x_names, coords$trans$x$name)
+      if (!is.null(coords$trans$y))
+        y_names <- c(y_names, coords$trans$y$name)
+    }
+
+    # Keep only scale/trans names that start with "log-"
+    x_names <- x_names[grepl("^log-", x_names)]
+    y_names <- y_names[grepl("^log-", y_names)]
+
+    # Extract the log base from the trans name -- a string like "log-10".
+    list(
+      x = extract_log_base(x_names),
+      y = extract_log_base(y_names)
+    )
+  }
+
+  # Given a built ggplot object, return a named list of variables mapped to x
+  # and y. This function will be called for each panel, but in practice the
+  # result is always the same across panels, so we'll cache the result.
+  mappings_cache <- NULL
+  find_plot_mappings <- function(b) {
+    if (!is.null(mappings_cache))
+      return(mappings_cache)
+
+    # lapply'ing as.character results in unexpected behavior for expressions
+    # like `wt/2`. This works better.
+    mappings <- as.list(as.character(b$plot$mapping))
+
+    # If x or y mapping is missing, look in each layer for mappings and return
+    # the first one.
+    missing_mappings <- setdiff(c("x", "y"), names(mappings))
+    if (length(missing_mappings) != 0) {
+      # Grab mappings for each layer
+      layer_mappings <- lapply(b$plot$layers, function(layer) {
+        lapply(layer$mapping, as.character)
+      })
+
+      # Get just the first x or y value in the combined list of plot and layer
+      # mappings.
+      mappings <- c(list(mappings), layer_mappings)
+      mappings <- Reduce(x = mappings, init = list(x = NULL, y = NULL),
+        function(init, m) {
+          # Can't use m$x/m$y; you get a partial match with xintercept/yintercept
+          if (is.null(init[["x"]]) && !is.null(m[["x"]])) init$x <- m[["x"]]
+          if (is.null(init[["y"]]) && !is.null(m[["y"]])) init$y <- m[["y"]]
+          init
+        }
+      )
+    }
+
+    # Look for CoordFlip
+    if (inherits(b$plot$coordinates, "CoordFlip")) {
+      mappings[c("x", "y")] <- mappings[c("y", "x")]
+    }
+
+    mappings_cache <<- mappings
+    mappings
+  }
+
+  if (ggplot_format == "new") {
+    layout <- b$layout$panel_layout
+  } else {
+    layout <- b$panel$layout
+  }
+  # Convert factor to numbers
+  layout$PANEL <- as.integer(as.character(layout$PANEL))
+
+  # Names of facets
+  facet_vars <- NULL
+  if (ggplot_format == "new") {
+    facet <- b$layout$facet
+    if (inherits(facet, "FacetGrid")) {
+      facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
+    } else if (inherits(facet, "FacetWrap")) {
+      facet_vars <- vapply(facet$params$facets, as.character, character(1))
+    }
+  } else {
+    facet <- b$plot$facet
+    if (inherits(facet, "grid")) {
+      facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
+    } else if (inherits(facet, "wrap")) {
+      facet_vars <- vapply(facet$facets, as.character, character(1))
+    }
+  }
+
+  # Iterate over each row in the layout data frame
+  lapply(seq_len(nrow(layout)), function(i) {
+    # Slice out one row
+    l <- layout[i, ]
+
+    scale_x <- l$SCALE_X
+    scale_y <- l$SCALE_Y
+
+    mapping <- find_plot_mappings(b)
+
+    # For each of the faceting variables, get the value of that variable in
+    # the current panel. Default to empty _named_ list so that it's sent as a
+    # JSON object, not array.
+    panel_vars <- list(a = NULL)[0]
+    for (i in seq_along(facet_vars)) {
+      var_name <- facet_vars[[i]]
+      vname <- paste0("panelvar", i)
+
+      mapping[[vname]] <- var_name
+      panel_vars[[vname]] <- l[[var_name]]
+    }
+
+    list(
+      panel   = l$PANEL,
+      row     = l$ROW,
+      col     = l$COL,
+      panel_vars = panel_vars,
+      scale_x = scale_x,
+      scale_y = scale_x,
+      log     = check_log_scales(b, scale_x, scale_y),
+      domain  = find_panel_domain(b, l$PANEL, scale_x, scale_y),
+      mapping = mapping
+    )
+  })
+}
+
+
+# Given a gtable object, return the x and y ranges (in pixel dimensions)
+find_panel_ranges <- function(g, res) {
+  # Given a vector of unit objects, return logical vector indicating which ones
+  # are "null" units. These units use the remaining available width/height --
+  # that is, the space not occupied by elements that have an absolute size.
+  is_null_unit <- function(x) {
+    # A vector of units can be either a list of individual units (a unit.list
+    # object), each with their own set of attributes, or an atomic vector with
+    # one set of attributes. ggplot2 switched from the former (in version
+    # 1.0.1) to the latter. We need to make sure that we get the correct
+    # result in both cases.
+    if (inherits(x, "unit.list")) {
+      # For ggplot2 <= 1.0.1
+      vapply(x, FUN.VALUE = logical(1), function(u) {
+        isTRUE(attr(u, "unit", exact = TRUE) == "null")
+      })
+    } else {
+      # For later versions of ggplot2
+      attr(x, "unit", exact = TRUE) == "null"
+    }
+  }
+
+  # Workaround for a bug in the quartz device. If you have a 400x400 image and
+  # run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
+  # res setting of the device. If res=72, then it returns 400 (as expected),
+  # but if, e.g., res=96, it will return 300, which is incorrect.
+  devScaleFactor <- 1
+  if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
+    devScaleFactor <- res / 72
+  }
+
+  # Convert a unit (or vector of units) to a numeric vector of pixel sizes
+  h_px <- function(x) {
+    devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
+  }
+  w_px <- function(x) {
+    devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
+  }
+
+  # Given a vector of relative sizes (in grid units), and a function for
+  # converting grid units to numeric pixels, return a list with: known pixel
+  # dimensions, scalable dimensions, and the overall space for the scalable
+  # objects.
+  find_size_info <- function(rel_sizes, unit_to_px) {
+    # Total pixels (in height or width)
+    total_px <- unit_to_px(grid::unit(1, "npc"))
+    # Calculate size of all panel(s) together. Panels (and only panels) have
+    # null size.
+    null_idx <- is_null_unit(rel_sizes)
+
+    # All the absolute heights. At this point, null heights are 0. We need to
+    # calculate them separately and add them in later.
+    px_sizes <- unit_to_px(rel_sizes)
+    # Mark the null heights as NA.
+    px_sizes[null_idx] <- NA_real_
+
+    # The plotting panels all are 'null' units.
+    null_sizes <- rep(NA_real_, length(rel_sizes))
+    null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
+
+    # Total size allocated for panels is the total image size minus absolute
+    # (non-panel) elements.
+    panel_px_total <- total_px - sum(px_sizes, na.rm = TRUE)
+
+    # Size of a 1null unit
+    null_px <- abs(panel_px_total / sum(null_sizes, na.rm = TRUE))
+
+    # This returned list contains:
+    # * px_sizes: A vector of known pixel dimensions. The values that were
+    #   null units will be assigned NA. The null units are ones that scale
+    #   when the plotting area is resized.
+    # * null_sizes: A vector of the null units. All others will be assigned
+    #   NA. The null units often are 1, but they may be any value, especially
+    #   when using coord_fixed.
+    # * null_px: The size (in pixels) of a 1null unit.
+    # * null_px_scaled: The size (in pixels) of a 1null unit when scaled to
+    #   fit a smaller dimension (used for plots with coord_fixed).
+    list(
+      px_sizes       = abs(px_sizes),
+      null_sizes     = null_sizes,
+      null_px        = null_px,
+      null_px_scaled = null_px
+    )
+  }
+
+  # Given a size_info, return absolute pixel positions
+  size_info_to_px <- function(info) {
+    px_sizes <- info$px_sizes
+
+    null_idx <- !is.na(info$null_sizes)
+    px_sizes[null_idx] <- info$null_sizes[null_idx] * info$null_px_scaled
+
+    # If this direction is scaled down because of coord_fixed, we need to add an
+    # offset so that the pixel locations are centered.
+    offset <- (info$null_px - info$null_px_scaled) *
+              sum(info$null_sizes, na.rm = TRUE) / 2
+
+    # Get absolute pixel positions
+    cumsum(px_sizes) + offset
+  }
+
+  heights_info <- find_size_info(g$heights, h_px)
+  widths_info  <- find_size_info(g$widths,  w_px)
+
+  if (g$respect) {
+    # This is a plot with coord_fixed. The grid 'respect' option means to use
+    # the same pixel value for 1null, for width and height. We want the
+    # smaller of the two values -- that's what makes the plot fit in the
+    # viewport.
+    null_px_min <- min(heights_info$null_px, widths_info$null_px)
+    heights_info$null_px_scaled <- null_px_min
+    widths_info$null_px_scaled  <- null_px_min
+  }
+
+  # Convert to absolute pixel positions
+  y_pos <- size_info_to_px(heights_info)
+  x_pos <- size_info_to_px(widths_info)
+
+  # Match up the pixel dimensions to panels
+  layout <- g$layout
+  # For panels:
+  # * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
+  # * For no facet or facet_grid, they'll just be named "panel". For
+  #   facet_grid, we need to re-order the layout table. Assume that panel
+  #   numbers go from left to right, then next row.
+  # Assign a number to each panel, corresponding to PANEl in the built ggplot
+  # object.
+  layout <- layout[grepl("^panel", layout$name), ]
+  layout <- layout[order(layout$t, layout$l), ]
+  layout$panel <- seq_len(nrow(layout))
+
+  # Return list of lists, where each inner list has left, right, top, bottom
+  # values for a panel
+  lapply(seq_len(nrow(layout)), function(i) {
+    p <- layout[i, , drop = FALSE]
+    list(
+      left   = x_pos[p$l - 1],
+      right  = x_pos[p$r],
+      bottom = y_pos[p$b],
+      top    = y_pos[p$t - 1]
+    )
+  })
+}

R/render-table.R

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

R/run-url.R

@@ -14,18 +14,22 @@
 #' @param subdir A subdirectory in the repository that contains the app. By
 #'   default, this function will run an app from the top level of the repo, but
 #'   you can use a path such as `\code{"inst/shinyapp"}.
+#' @param destdir Directory to store the downloaded application files. If \code{NULL}
+#'   (the default), the application files will be stored in a temporary directory
+#'   and removed when the app exits
 #' @param ... Other arguments to be passed to \code{\link{runApp}()}, such as
 #'   \code{port} and \code{launch.browser}.
 #' @export
 #' @examples
-#' \donttest{
-#' runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
 #'
-#' # Can run an app from a subdirectory in the archive
-#' runUrl("https://github.com/rstudio/shiny_example/archive/master.zip",
-#'  subdir = "inst/shinyapp/")
+#'   # Can run an app from a subdirectory in the archive
+#'   runUrl("https://github.com/rstudio/shiny_example/archive/master.zip",
+#'     subdir = "inst/shinyapp/")
 #' }
-runUrl <- function(url, filetype = NULL, subdir = NULL, ...) {
+runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
 
   if (!is.null(subdir) && ".." %in% strsplit(subdir, '/')[[1]])
     stop("'..' not allowed in subdir")
@@ -43,8 +47,14 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, ...) {
     stop("Unknown file extension.")
 
   message("Downloading ", url)
-  filePath <- tempfile('shinyapp', fileext=fileext)
-  fileDir  <- tempfile('shinyapp')
+  if (is.null(destdir)) {
+    filePath <- tempfile('shinyapp', fileext = fileext)
+    fileDir  <- tempfile('shinyapp')
+  } else {
+    fileDir <- destdir
+    filePath <- paste(destdir, fileext)
+  }
+
   dir.create(fileDir, showWarnings = FALSE)
   if (download(url, filePath, mode = "wb", quiet = TRUE) != 0)
     stop("Failed to download URL ", url)
@@ -61,13 +71,16 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, ...) {
     untar2(filePath, exdir = fileDir)
 
   } else if (fileext == ".zip") {
-    first <- as.character(unzip(filePath, list=TRUE)$Name)[1]
-    unzip(filePath, exdir = fileDir)
+    first <- as.character(utils::unzip(filePath, list=TRUE)$Name)[1]
+    utils::unzip(filePath, exdir = fileDir)
+  }
+
+  if(is.null(destdir)){
+    on.exit(unlink(fileDir, recursive = TRUE), add = TRUE)
   }
-  on.exit(unlink(fileDir, recursive = TRUE), add = TRUE)
 
   appdir <- file.path(fileDir, first)
-  if (!file_test('-d', appdir)) appdir <- dirname(appdir)
+  if (!utils::file_test('-d', appdir)) appdir <- dirname(appdir)
 
   if (!is.null(subdir)) appdir <- file.path(appdir, subdir)
   runApp(appdir, ...)
@@ -80,15 +93,16 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, ...) {
 #'   all valid values.
 #' @export
 #' @examples
-#' \donttest{
-#' runGist(3239667)
-#' runGist("https://gist.github.com/jcheng5/3239667")
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   runGist(3239667)
+#'   runGist("https://gist.github.com/jcheng5/3239667")
 #'
-#' # Old URL format without username
-#' runGist("https://gist.github.com/3239667")
+#'   # Old URL format without username
+#'   runGist("https://gist.github.com/3239667")
 #' }
 #'
-runGist <- function(gist, ...) {
+runGist <- function(gist, destdir = NULL, ...) {
 
   gistUrl <- if (is.numeric(gist) || grepl('^[0-9a-f]+$', gist)) {
     sprintf('https://gist.github.com/%s/download', gist)
@@ -98,7 +112,7 @@ runGist <- function(gist, ...) {
     stop('Unrecognized gist identifier format')
   }
 
-  runUrl(gistUrl, filetype=".tar.gz", ...)
+  runUrl(gistUrl, filetype = ".zip", destdir = destdir, ...)
 }
 
 
@@ -110,15 +124,16 @@ runGist <- function(gist, ...) {
 #'   Defaults to \code{"master"}.
 #' @export
 #' @examples
-#' \donttest{
-#' runGitHub("shiny_example", "rstudio")
-#' # or runGitHub("rstudio/shiny_example")
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   runGitHub("shiny_example", "rstudio")
+#'   # or runGitHub("rstudio/shiny_example")
 #'
-#' # Can run an app from a subdirectory in the repo
-#' runGitHub("shiny_example", "rstudio", subdir = "inst/shinyapp/")
+#'   # Can run an app from a subdirectory in the repo
+#'   runGitHub("shiny_example", "rstudio", subdir = "inst/shinyapp/")
 #' }
 runGitHub <- function(repo, username = getOption("github.user"),
-                      ref = "master", subdir = NULL, ...) {
+                      ref = "master", subdir = NULL, destdir = NULL, ...) {
 
   if (grepl('/', repo)) {
     res <- strsplit(repo, '/')[[1]]
@@ -130,5 +145,5 @@ runGitHub <- function(repo, username = getOption("github.user"),
   url <- paste("https://github.com/", username, "/", repo, "/archive/",
                ref, ".tar.gz", sep = "")
 
-  runUrl(url, subdir=subdir, ...)
+  runUrl(url, subdir = subdir, destdir = destdir, ...)
 }

R/serializers.R

@@ -0,0 +1,91 @@
+#' Add a function for serializing an input before bookmarking application state
+#'
+#' @param inputId Name of the input value.
+#' @param fun A function that takes the input value and returns a modified
+#'   value. The returned value will be used for the test snapshot.
+#' @param session A Shiny session object.
+#'
+#' @keywords internal
+#' @export
+setSerializer <- function(inputId, fun, session = getDefaultReactiveDomain()) {
+  if (is.null(session)) {
+    stop("setSerializer() needs a session object.")
+  }
+
+  input_impl <- .subset2(session$input, "impl")
+  input_impl$setMeta(inputId, "shiny.serializer", fun)
+}
+
+
+# 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_fun <- impl$getMeta(name, "shiny.serializer")
+    if (is.null(serializer_fun))
+      serializer_fun <- serializerDefault
+
+    # Apply serializer function.
+    serializer_fun(val, stateDir)
+  })
+
+  # Filter out any values that were marked as unserializable.
+  vals <- Filter(Negate(isUnserializable), vals)
+  vals
+}

R/server-input-handlers.R

@@ -0,0 +1,241 @@
+# Create a map for input handlers and register the defaults.
+inputHandlers <- Map$new()
+
+#' Register an Input Handler
+#'
+#' Adds an input handler for data of this type. When called, Shiny will use the
+#' function provided to refine the data passed back from the client (after being
+#' deserialized by jsonlite) before making it available in the \code{input}
+#' variable of the \code{server.R} file.
+#'
+#' This function will register the handler for the duration of the R process
+#' (unless Shiny is explicitly reloaded). For that reason, the \code{type} used
+#' should be very specific to this package to minimize the risk of colliding
+#' with another Shiny package which might use this data type name. We recommend
+#' the format of "packageName.widgetName".
+#'
+#' Currently Shiny registers the following handlers: \code{shiny.matrix},
+#' \code{shiny.number}, and \code{shiny.date}.
+#'
+#' The \code{type} of a custom Shiny Input widget will be deduced using the
+#' \code{getType()} JavaScript function on the registered Shiny inputBinding.
+#' @param type The type for which the handler should be added -- should be a
+#' single-element character vector.
+#' @param fun The handler function. This is the function that will be used to
+#'   parse the data delivered from the client before it is available in the
+#'   \code{input} variable. The function will be called with the following three
+#'   parameters:
+#'    \enumerate{
+#'      \item{The value of this input as provided by the client, deserialized
+#'      using jsonlite.}
+#'      \item{The \code{shinysession} in which the input exists.}
+#'      \item{The name of the input.}
+#'    }
+#' @param force If \code{TRUE}, will overwrite any existing handler without
+#' warning. If \code{FALSE}, will throw an error if this class already has
+#' a handler defined.
+#' @examples
+#' \dontrun{
+#' # Register an input handler which rounds a input number to the nearest integer
+#' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
+#'   if (is.null(x)) return(NA)
+#'   round(x)
+#' })
+#'
+#' ## On the Javascript side, the associated input binding must have a corresponding getType method:
+#' getType: function(el) {
+#'   return "mypackage.validint";
+#' }
+#'
+#' }
+#' @seealso \code{\link{removeInputHandler}}
+#' @export
+registerInputHandler <- function(type, fun, force=FALSE){
+  if (inputHandlers$containsKey(type) && !force){
+    stop("There is already an input handler for type: ", type)
+  }
+  inputHandlers$set(type, fun)
+}
+
+#' Deregister an Input Handler
+#'
+#' Removes an Input Handler. Rather than using the previously specified handler
+#' for data of this type, the default jsonlite serialization will be used.
+#'
+#' @param type The type for which handlers should be removed.
+#' @return The handler previously associated with this \code{type}, if one
+#'   existed. Otherwise, \code{NULL}.
+#' @seealso \code{\link{registerInputHandler}}
+#' @export
+removeInputHandler <- function(type){
+  inputHandlers$remove(type)
+}
+
+
+# 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, ...) {
+  if (length(data) == 0)
+    return(matrix(nrow=0, ncol=0))
+
+  m <- matrix(unlist(lapply(data, function(x) {
+    sapply(x, function(y) {
+      ifelse(is.null(y), NA, y)
+    })
+  })), nrow = length(data[[1]]), ncol = length(data))
+  return(m)
+})
+
+
+registerInputHandler("shiny.number", function(val, ...){
+  ifelse(is.null(val), NA, val)
+})
+
+registerInputHandler("shiny.password", function(val, shinysession, name) {
+  # Mark passwords as not serializable
+  setSerializer(name, serializerUnserializable)
+  val
+})
+
+registerInputHandler("shiny.date", function(val, ...){
+  # First replace NULLs with NA, then convert to Date vector
+  datelist <- ifelse(lapply(val, is.null), NA, val)
+
+  res <- NULL
+  tryCatch({
+      res <- as.Date(unlist(datelist))
+    },
+    error = function(e) {
+      # It's possible for client to send a string like "99999-01-01", which
+      # as.Date can't handle.
+      warning(e$message)
+      res <<- as.Date(rep(NA, length(datelist)))
+    }
+  )
+
+  res
+})
+
+registerInputHandler("shiny.datetime", function(val, ...){
+  # First replace NULLs with NA, then convert to POSIXct vector
+  times <- lapply(val, function(x) {
+    if (is.null(x)) NA
+    else x
+  })
+  as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
+})
+
+registerInputHandler("shiny.action", function(val, shinysession, name) {
+  # mark up the action button value with a special class so we can recognize it later
+  class(val) <- c(class(val), "shinyActionButtonValue")
+  val
+})
+
+registerInputHandler("shiny.file", function(val, shinysession, name) {
+  # This function is only used when restoring a Shiny fileInput. When a file is
+  # uploaded the usual way, it takes a different code path and won't hit this
+  # function.
+  if (is.null(val))
+    return(NULL)
+
+  # The data will be a named list of lists; convert to a data frame.
+  val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
+
+  # `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`.
+  setSerializer(name, serializerFileInput)
+
+  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
+
+  val
+})
+
+
+# to be used with !!!answer
+registerInputHandler("shiny.symbolList", function(val, ...) {
+  if (is.null(val)) {
+    list()
+  } else {
+    lapply(val, as.symbol)
+  }
+})
+# to be used with !!answer
+registerInputHandler("shiny.symbol", function(val, ...) {
+  if (is.null(val) || identical(val, "")) {
+    NULL
+  } else {
+    as.symbol(val)
+  }
+})

R/shiny-options.R

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

R/shinyui.R

@@ -14,80 +14,63 @@ NULL
 #' # now we can just write "static" content without withMathJax()
 #' div("more math here $$\\sqrt{2}$$")
 withMathJax <- function(...) {
-  path <- 'https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
+  path <- 'https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
   tagList(
     tags$head(
       singleton(tags$script(src = path, type = 'text/javascript'))
     ),
     ...,
-    tags$script(HTML('MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
+    tags$script(HTML('if (window.MathJax) MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
   )
 }
 
-renderPage <- function(ui, connection, showcase=0) {
+renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
+  # If the ui is a NOT complete document (created by htmlTemplate()), then do some
+  # preprocessing and make sure it's a complete document.
+  if (!inherits(ui, "html_document")) {
+    if (showcase > 0)
+      ui <- showcaseUI(ui)
 
-  if (showcase > 0)
-    ui <- showcaseUI(ui)
+    # Wrap ui in body tag if it doesn't already have a single top-level body tag.
+    if (!(inherits(ui, "shiny.tag") && ui$name == "body"))
+      ui <- tags$body(ui)
 
-  # Wrap ui in body tag if it doesn't already have a single top-level body tag.
-  if (!(inherits(ui, "shiny.tag") && ui$name == "body"))
-    ui <- tags$body(ui)
+    # Put the body into the default template
+    ui <- htmlTemplate(
+      system.file("template", "default.html", package = "shiny"),
+      body = ui
+    )
+  }
 
-  result <- renderTags(ui)
-
-  deps <- c(
-    list(
-      htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
-      htmlDependency("jquery", "1.11.0", c(href="shared"), script = "jquery.min.js"),
-      htmlDependency("shiny", packageVersion("shiny"), c(href="shared"),
-        script = "shiny.min.js", stylesheet = "shiny.css")
-    ),
-    result$dependencies
+  shiny_deps <- list(
+    htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
+    htmlDependency("jquery", "1.12.4", c(href="shared"), script = "jquery.min.js"),
+    htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
+      script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
+      stylesheet = "shiny.css")
   )
-  deps <- resolveDependencies(deps)
-  deps <- lapply(deps, createWebDependency)
-  depStr <- paste(sapply(deps, function(dep) {
-    sprintf("%s[%s]", dep$name, dep$version)
-  }), collapse = ";")
-  depHtml <- renderDependencies(deps, "href")
 
-  # write preamble
-  writeLines(c('<!DOCTYPE html>',
-               '<html>',
-               '<head>',
-               '  <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>',
-               sprintf('  <script type="application/shiny-singletons">%s</script>',
-                       paste(result$singletons, collapse = ',')
-               ),
-               sprintf('  <script type="application/html-dependencies">%s</script>',
-                       depStr
-               ),
-               depHtml
-              ),
-              con = connection)
-  writeLines(c(result$head,
-               '</head>',
-               recursive=TRUE),
-             con = connection)
+  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")
+  }
 
-  writeLines(result$html, con = connection)
-
-  # write end document
-  writeLines('</html>',
-             con = connection)
+  html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
+  writeUTF8(html, con = connection)
 }
 
 #' Create a Shiny UI handler
 #'
 #' Historically this function was used in ui.R files to register a user
-#' interface with Shiny. It is no longer required; simply ensure that the last
-#' expression to be returned from ui.R is a user interface. This function is
-#' kept for backwards compatibility with older applications. It returns the
-#' value that is passed to it.
+#' interface with Shiny. It is no longer required as of Shiny 0.10; simply
+#' ensure that the last expression to be returned from ui.R is a user interface.
+#' This function is kept for backwards compatibility with older applications. It
+#' returns the value that is passed to it.
 #'
 #' @param ui A user interace definition
 #' @return The user interface definition, without modifications or side effects.
-#'
 #' @export
 shinyUI <- function(ui) {
   .globals$ui <- list(ui)
@@ -105,7 +88,7 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
     if (!isTRUE(grepl(uiPattern, req$PATH_INFO)))
       return(NULL)
 
-    textConn <- textConnection(NULL, "w")
+    textConn <- file(open = "w+")
     on.exit(close(textConn))
 
     showcaseMode <- .globals$showcaseDefault
@@ -114,19 +97,41 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
       if (!is.null(mode))
         showcaseMode <- mode
     }
-    uiValue <- if (is.function(ui)) {
-      if (length(formals(ui)) > 0)
-        ui(req)
-      else
-        ui()
+
+    testMode <- .globals$testMode %OR% FALSE
+
+    # Create a restore context using query string
+    bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
+    if (bookmarkStore == "disable") {
+      # If bookmarking is disabled, use empty context
+      restoreContext <- RestoreContext$new()
     } else {
-      ui
+      restoreContext <- RestoreContext$new(req$QUERY_STRING)
     }
+
+    withRestoreContext(restoreContext, {
+      uiValue <- NULL
+
+      if (is.function(ui)) {
+        if (length(formals(ui)) > 0) {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          uiValue <- ..stacktraceon..(ui(req))
+        } else {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          uiValue <- ..stacktraceon..(ui())
+        }
+      } else {
+        if (getCurrentRestoreContext()$active) {
+          warning("Trying to restore saved app state, but UI code must be a function for this to work! See ?enableBookmarking")
+        }
+        uiValue <- ui
+      }
+    })
     if (is.null(uiValue))
       return(NULL)
 
-    renderPage(uiValue, textConn, showcaseMode)
-    html <- paste(textConnectionValue(textConn), collapse='\n')
+    renderPage(uiValue, textConn, showcaseMode, testMode)
+    html <- paste(readLines(textConn, encoding = 'UTF-8'), collapse='\n')
     return(httpResponse(200, content=enc2utf8(html)))
   }
 }

R/shinywrappers.R

@@ -1,4 +1,4 @@
-globalVariables('func')
+utils::globalVariables('func')
 
 #' Mark a function as a render function
 #'
@@ -12,24 +12,121 @@ 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(...)
+  }
+
+  structure(renderFunc,
+            class       = c("shiny.render.function", "function"),
+            outputFunc  = uiFunc,
+            outputArgs  = outputArgs,
+            hasExecuted = hasExecuted)
+}
+
+#' Implement render functions
+#'
+#' @param func A function without parameters, that returns user data. If the
+#'   returned value is a promise, then the render function will proceed in async
+#'   mode.
+#' @param transform A function that takes four arguments: \code{value},
+#'   \code{session}, \code{name}, and \code{...} (for future-proofing). This
+#'   function will be invoked each time a value is returned from \code{func},
+#'   and is responsible for changing the value into a JSON-ready value to be
+#'   JSON-encoded and sent to the browser.
+#' @param outputFunc The UI function that is used (or most commonly used) with
+#'   this render function. This can be used in R Markdown documents to create
+#'   complete output widgets out of just the render function.
+#' @param outputArgs A list of arguments to pass to the \code{outputFunc}.
+#'   Render functions should include \code{outputArgs = list()} in their own
+#'   parameter list, and pass through the value as this argument, 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 An annotated render function, ready to be assigned to an
+#'   \code{output} slot.
 #'
 #' @export
-markRenderFunction <- function(uiFunc, renderFunc) {
-  structure(renderFunc,
-            class      = c("shiny.render.function", "function"),
-            outputFunc = uiFunc)
+createRenderFunction <- function(
+  func, transform = function(value, session, name, ...) value,
+  outputFunc = NULL, outputArgs = NULL
+) {
+
+  renderFunc <- function(shinysession, name, ...) {
+    hybrid_chain(
+      func(),
+      function(value, .visible) {
+        transform(setVisible(value, .visible), shinysession, name, ...)
+      }
+    )
+  }
+
+  if (!is.null(outputFunc))
+    markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+  else
+    renderFunc
 }
 
 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")
+
   o <- getDefaultReactiveDomain()$output
-  if (!is.null(o))
+  if (!is.null(o)) {
     o[[id]] <- renderFunc
-  if (is.logical(formals(outputFunction)[["inline"]])) {
-    outputFunction(id, inline = inline)
-  } else outputFunction(id)
+    # If there's a namespace, we must respect it
+    id <- getDefaultReactiveDomain()$ns(id)
+  }
+
+  # Make the id the first positional argument
+  outputArgs <- c(list(id), outputArgs)
+
+  if (is.logical(formals(outputFunction)[["inline"]]) && !("inline" %in% names(outputArgs))) {
+    outputArgs[["inline"]] <- inline
+  }
+
+  do.call(outputFunction, outputArgs)
 }
 
 #' @export
@@ -38,139 +135,32 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
   useRenderFunction(x, inline = inline)
 }
 
-#' Plot Output
+
+#' Mark a render function with attributes that will be used by the output
 #'
-#' Renders a reactive plot that is suitable for assigning to an \code{output}
-#' slot.
+#' @inheritParams markRenderFunction
+#' @param snapshotExclude If TRUE, exclude the output from test snapshots.
+#' @param snapshotPreprocess A function for preprocessing the value before
+#'   taking a test snapshot.
 #'
-#' The corresponding HTML output tag should be \code{div} or \code{img} and have
-#' the CSS class name \code{shiny-plot-output}.
-#'
-#' @seealso For more details on how the plots are generated, and how to control
-#'   the output, see \code{\link{plotPNG}}.
-#'
-#' @param expr An expression that generates a plot.
-#' @param width,height The width/height of the rendered plot, in pixels; or
-#'   \code{'auto'} to use the \code{offsetWidth}/\code{offsetHeight} of the HTML
-#'   element that is bound to this plot. You can also pass in a function that
-#'   returns the width/height in pixels or \code{'auto'}; in the body of the
-#'   function you may reference reactive values and functions. When rendering an
-#'   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{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 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, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderPlot: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
+#' @keywords internal
+markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
+  snapshotPreprocess = NULL)
+{
+  # Add the outputAttrs attribute if necessary
+  if (is.null(attr(renderFunc, "outputAttrs", TRUE))) {
+    attr(renderFunc, "outputAttrs") <- list()
   }
 
-  args <- list(...)
+  if (!is.null(snapshotExclude)) {
+    attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
+  }
 
-  if (is.function(width))
-    widthWrapper <- reactive({ width() })
-  else
-    widthWrapper <- NULL
+  if (!is.null(snapshotPreprocess)) {
+    attr(renderFunc, "outputAttrs")$snapshotPreprocess <- snapshotPreprocess
+  }
 
-  if (is.function(height))
-    heightWrapper <- reactive({ height() })
-  else
-    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
-  # sets the height to 400px, so to make it adapt we need to override it
-  # with NULL.
-  outputFunc <- plotOutput
-  if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
-
-  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())
-      if (result$visible) {
-        # Use capture.output to squelch printing to the actual console; we
-        # are only interested in plot output
-        capture.output(print(result$value))
-      }
-
-      # Now capture some graphics device info before we close it
-      usrCoords <- par('usr')
-      usrBounds <- usrCoords
-      if (par('xlog')) {
-        usrBounds[c(1,2)] <- 10 ^ usrBounds[c(1,2)]
-      }
-      if (par('ylog')) {
-        usrBounds[c(3,4)] <- 10 ^ usrBounds[c(3,4)]
-      }
-
-      coordmap <<- list(
-        usr = c(
-          left = usrCoords[1],
-          right = usrCoords[2],
-          bottom = usrCoords[3],
-          top = usrCoords[4]
-        ),
-        # The bounds of the plot area, in DOM pixels
-        bounds = c(
-          left = grconvertX(usrBounds[1], 'user', 'nfc') * width,
-          right = grconvertX(usrBounds[2], 'user', 'nfc') * width,
-          bottom = (1-grconvertY(usrBounds[3], 'user', 'nfc')) * height,
-          top = (1-grconvertY(usrBounds[4], 'user', 'nfc')) * height
-        ),
-        log = c(
-          x = par('xlog'),
-          y = par('ylog')
-        ),
-        pixelratio = pixelratio
-      )
-    }
-
-    outfile <- do.call(plotPNG, c(plotFunc, width=width*pixelratio,
-                                  height=height*pixelratio, res=res*pixelratio, args))
-    on.exit(unlink(outfile))
-
-    # Return a list of attributes for the img
-    return(list(
-      src=shinysession$fileUrl(name, outfile, contentType='image/png'),
-      width=width, height=height, coordmap=coordmap
-    ))
-  }))
+  renderFunc
 }
 
 #' Image file output
@@ -204,13 +194,24 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #'   it is sent to the client browser? Generally speaking, if the image is a
 #'   temp file generated within \code{func}, then this should be \code{TRUE};
 #'   if the image is not a temp file, this should be \code{FALSE}.
-#'
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{imageOutput}} when \code{renderImage} is used in an
+#'   interactive R Markdown document.
 #' @export
 #'
 #' @examples
-#' \dontrun{
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
-#' shinyServer(function(input, output, clientData) {
+#' ui <- fluidPage(
+#'   sliderInput("n", "Number of observations", 2, 1000, 500),
+#'   plotOutput("plot1"),
+#'   plotOutput("plot2"),
+#'   plotOutput("plot3")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'
 #'   # A plot of fixed size
 #'   output$plot1 <- renderImage({
@@ -232,14 +233,14 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #'   output$plot2 <- renderImage({
 #'     # Read plot2's width and height. These are reactive values, so this
 #'     # expression will re-run whenever these values change.
-#'     width  <- clientData$output_plot2_width
-#'     height <- clientData$output_plot2_height
+#'     width  <- session$clientData$output_plot2_width
+#'     height <- session$clientData$output_plot2_height
 #'
 #'     # A temp file to save the output.
 #'     outfile <- tempfile(fileext='.png')
 #'
 #'     png(outfile, width=width, height=height)
-#'     hist(rnorm(input$obs))
+#'     hist(rnorm(input$n))
 #'     dev.off()
 #'
 #'     # Return a list containing the filename
@@ -250,6 +251,8 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #'   }, 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',
@@ -258,88 +261,41 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #'     # Return a list containing the filename
 #'     list(src = filename)
 #'   }, deleteFile = FALSE)
-#' })
+#' }
 #'
+#' shinyApp(ui, server)
 #' }
 renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
-                        deleteFile=TRUE) {
+                        deleteFile=TRUE, outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  return(markRenderFunction(imageOutput, function(shinysession, name, ...) {
-    imageinfo <- func()
-    # Should the file be deleted after being sent? If .deleteFile not set or if
-    # TRUE, then delete; otherwise don't delete.
-    if (deleteFile) {
-      on.exit(unlink(imageinfo$src))
-    }
+  createRenderFunction(func,
+    transform = function(imageinfo, session, name, ...) {
+      # Should the file be deleted after being sent? If .deleteFile not set or if
+      # TRUE, then delete; otherwise don't delete.
+      if (deleteFile) {
+        on.exit(unlink(imageinfo$src))
+      }
 
-    # If contentType not specified, autodetect based on extension
-    if (is.null(imageinfo$contentType)) {
-      contentType <- getContentType(sub('^.*\\.', '', basename(imageinfo$src)))
-    } else {
-      contentType <- imageinfo$contentType
-    }
+      # If contentType not specified, autodetect based on extension
+      contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
 
-    # Extra values are everything in imageinfo except 'src' and 'contentType'
-    extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
+      # Extra values are everything in imageinfo except 'src' and 'contentType'
+      extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
 
-    # Return a list with src, and other img attributes
-    c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
-      extra_attr)
-  }))
+      # Return a list with src, and other img attributes
+      c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
+        extra_attr)
+    },
+    imageOutput, outputArgs)
 }
 
 
-#' Table Output
-#'
-#' Creates a reactive table that is suitable for assigning to an \code{output}
-#' slot.
-#'
-#' The corresponding HTML output tag should be \code{div} and have the CSS class
-#' name \code{shiny-html-output}.
-#'
-#' @param expr An expression that returns an R object that can be used with
-#'   \code{\link[xtable]{xtable}}.
-#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}} and
-#'   \code{\link[xtable]{print.xtable}}.
-#' @param env The environment in which to evaluate \code{expr}.
-#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
-#'   is useful if you want to save an expression in a variable.
-#' @param func A function that returns an R object that can be used with
-#'   \code{\link[xtable]{xtable}} (deprecated; use \code{expr} instead).
-#'
-#' @export
-renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderTable: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
-
-  markRenderFunction(tableOutput, function() {
-    classNames <- getOption('shiny.table.class') %OR% 'data table table-bordered table-condensed'
-    data <- func()
-
-    if (is.null(data) || identical(data, data.frame()))
-      return("")
-
-    return(paste(
-      capture.output(
-        print(xtable(data, ...),
-              type='html',
-              html.table.attributes=paste('class="',
-                                          htmlEscape(classNames, TRUE),
-                                          '"',
-                                          sep=''), ...)),
-      collapse="\n"))
-  })
-}
-
 #' Printable Output
 #'
 #' Makes a reactive version of the given function that captures any printed
 #' output, and also captures its printable result (unless
-#' \code{\link{invisible}}), into a string. The resulting function is suitable
+#' \code{\link[base]{invisible}}), into a string. The resulting function is suitable
 #' for assigning to an  \code{output} slot.
 #'
 #' The corresponding HTML output tag can be anything (though \code{pre} is
@@ -351,34 +307,92 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
 #'
 #' Note that unlike most other Shiny output functions, if the given function
 #' returns \code{NULL} then \code{NULL} will actually be visible in the output.
-#' To display nothing, make your function return \code{\link{invisible}()}.
+#' To display nothing, make your function return \code{\link[base]{invisible}()}.
 #'
 #' @param expr An expression that may print output and/or return a printable R
 #'   object.
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
-#' @param func A function that may print output and/or return a printable R
-#'   object (deprecated; use \code{expr} instead).
-#' @param width The value for \code{\link{options}('width')}.
+#'   is useful if you want to save an expression in a variable.
+#' @param width The value for \code{\link[base]{options}('width')}.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{verbatimTextOutput}} when \code{renderPrint} is used
+#'   in an interactive R Markdown document.
 #' @seealso \code{\link{renderText}} for displaying the value returned from a
 #'   function, instead of the printed output.
 #'
 #' @example res/text-example.R
-#'
 #' @export
-renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, func = NULL,
-                        width = getOption('width')) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderPrint: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
+renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
+                        width = getOption('width'), outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
+
+  # Set a promise domain that sets the console width
+  #   and captures output
+  # op <- options(width = width)
+  # on.exit(options(op), add = TRUE)
+
+  renderFunc <- function(shinysession, name, ...) {
+    domain <- createRenderPrintPromiseDomain(width)
+    hybrid_chain(
+      {
+        promises::with_promise_domain(domain, func())
+      },
+      function(value, .visible) {
+        if (.visible) {
+          cat(file = domain$conn, paste(utils::capture.output(value, append = TRUE), collapse = "\n"))
+        }
+        res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
+        res
+      },
+      finally = function() {
+        close(domain$conn)
+      }
+    )
   }
 
-  markRenderFunction(verbatimTextOutput, function() {
-    op <- options(width = width)
-    on.exit(options(op), add = TRUE)
-    paste(capture.output(func()), collapse = "\n")
-  })
+  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
+}
+
+createRenderPrintPromiseDomain <- function(width) {
+  f <- file()
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      op <- options(width = width)
+      on.exit(options(op), add = TRUE)
+
+      sink(f, append = TRUE)
+      on.exit(sink(NULL), add = TRUE)
+
+      force(expr)
+    },
+    conn = f
+  )
 }
 
 #' Text Output
@@ -399,32 +413,31 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, func = NULL,
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
 #'   is useful if you want to save an expression in a variable.
-#' @param func A function that returns an R object that can be used as an
-#'   argument to \code{cat}.(deprecated; use \code{expr} instead).
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{textOutput}} when \code{renderText} is used in an
+#'   interactive R Markdown document.
 #'
 #' @seealso \code{\link{renderPrint}} for capturing the print output of a
 #'   function, rather than the returned text value.
 #'
 #' @example res/text-example.R
-#'
 #' @export
-renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderText: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+renderText <- function(expr, env=parent.frame(), quoted=FALSE,
+                       outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(textOutput, function() {
-    value <- func()
-    return(paste(capture.output(cat(value)), collapse="\n"))
-  })
+  createRenderFunction(
+    func,
+    function(value, session, name, ...) {
+      paste(utils::capture.output(cat(value)), collapse="\n")
+    },
+    textOutput, outputArgs
+  )
 }
 
 #' UI Output
 #'
-#' \bold{Experimental feature.} Makes a reactive version of a function that
-#' generates HTML using the Shiny UI library.
+#' Renders reactive HTML using the Shiny UI library.
 #'
 #' The corresponding HTML output tag should be \code{div} and have the CSS class
 #' name \code{shiny-html-output} (or use \code{\link{uiOutput}}).
@@ -434,46 +447,45 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
 #'   is useful if you want to save an expression in a variable.
-#' @param func A function that returns a Shiny tag object, \code{\link{HTML}},
-#'   or a list of such objects (deprecated; use \code{expr} instead).
-#'
-#' @seealso conditionalPanel
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{uiOutput}} when \code{renderUI} is used in an
+#'   interactive R Markdown document.
 #'
+#' @seealso \code{\link{uiOutput}}
 #' @export
 #' @examples
-#' \dontrun{
-#'   output$moreControls <- renderUI({
-#'     list(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   uiOutput("moreControls")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$moreControls <- renderUI({
+#'     tagList(
+#'       sliderInput("n", "N", 1, 1000, 500),
+#'       textInput("label", "Label")
 #'     )
 #'   })
 #' }
-renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
-  if (!is.null(func)) {
-    shinyDeprecated(msg="renderUI: argument 'func' is deprecated. Please use 'expr' instead.")
-  } else {
-    installExprFunction(expr, "func", env, quoted)
-  }
+#' shinyApp(ui, server)
+#' }
+#'
+renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
+                     outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(uiOutput, function(shinysession, name, ...) {
-    result <- func()
-    if (is.null(result) || length(result) == 0)
-      return(NULL)
+  createRenderFunction(
+    func,
+    function(result, shinysession, name, ...) {
+      if (is.null(result) || length(result) == 0)
+        return(NULL)
 
-    result <- takeSingletons(result, shinysession$singletons, desingleton=FALSE)$ui
-    result <- surroundSingletons(result)
-    dependencies <- lapply(resolveDependencies(findDependencies(result)),
-      createWebDependency)
-    names(dependencies) <- NULL
-
-    # renderTags returns a list with head, singletons, and html
-    output <- list(
-      html = doRenderTags(result),
-      deps = dependencies
-    )
-
-    return(output)
-  })
+      processDeps(result, shinysession)
+    },
+    uiOutput, outputArgs
+  )
 }
 
 #' File Downloads
@@ -499,28 +511,42 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
 #'   example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or
 #'   \code{NA}, the content type will be guessed based on the filename
 #'   extension, or \code{application/octet-stream} if the extension is unknown.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{downloadButton}} when \code{downloadHandler} is used
+#'   in an interactive R Markdown document.
 #'
 #' @examples
-#' \dontrun{
-#' # In server.R:
-#' output$downloadData <- downloadHandler(
-#'   filename = function() {
-#'     paste('data-', Sys.Date(), '.csv', sep='')
-#'   },
-#'   content = function(file) {
-#'     write.csv(data, file)
-#'   }
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   downloadLink("downloadData", "Download")
 #' )
 #'
-#' # In ui.R:
-#' downloadLink('downloadData', 'Download')
+#' server <- function(input, output) {
+#'   # Our dataset
+#'   data <- mtcars
+#'
+#'   output$downloadData <- downloadHandler(
+#'     filename = function() {
+#'       paste("data-", Sys.Date(), ".csv", sep="")
+#'     },
+#'     content = function(file) {
+#'       write.csv(data, file)
+#'     }
+#'   )
 #' }
 #'
+#' shinyApp(ui, server)
+#' }
 #' @export
-downloadHandler <- function(filename, content, contentType=NA) {
-  return(markRenderFunction(downloadButton, function(shinysession, name, ...) {
+downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()) {
+  renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
-  }))
+  }
+  snapshotExclude(
+    markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+  )
 }
 
 #' Table output with the JavaScript library DataTables
@@ -531,7 +557,7 @@ downloadHandler <- function(filename, content, contentType=NA) {
 #' the server infrastructure.
 #'
 #' For the \code{options} argument, the character elements that have the class
-#' \code{"AsIs"} (usually returned from \code{\link{I}()}) will be evaluated in
+#' \code{"AsIs"} (usually returned from \code{\link[base]{I}()}) will be evaluated in
 #' JavaScript. This is useful when the type of the option value is not supported
 #' in JSON, e.g., a JavaScript function, which can be obtained by evaluating a
 #' character string. Note this only applies to the root-level elements of the
@@ -551,75 +577,101 @@ downloadHandler <- function(filename, content, contentType=NA) {
 #'   indicate which columns to escape, e.g. \code{1:5} (the first 5 columns),
 #'   \code{c(1, 3, 4)}, or \code{c(-1, -3)} (all columns except the first and
 #'   third), or \code{c('Species', 'Sepal.Length')}.
+#' @param outputArgs A list of arguments to be passed through to the implicit
+#'   call to \code{\link{dataTableOutput}} when \code{renderDataTable} is used
+#'   in an interactive R Markdown document.
+#'
 #' @references \url{http://datatables.net}
 #' @note This function only provides the server-side version of DataTables
 #'   (using R to process the data object on the server side). There is a
 #'   separate package \pkg{DT} (\url{https://github.com/rstudio/DT}) that allows
-#'   you to create both server-side and client-side DataTables. We may deprecate
-#'   \code{renderDataTable()} and \code{dataTableOutput()} in the future when
-#'   the \pkg{DT} package is mature enough.
+#'   you to create both server-side and client-side DataTables, and supports
+#'   additional DataTables features. Consider using \code{DT::renderDataTable()}
+#'   and \code{DT::dataTableOutput()} (see
+#'   \url{http://rstudio.github.io/DT/shiny.html} for more information).
 #' @export
 #' @inheritParams renderPlot
 #' @examples
-#' \donttest{
-#' # pass a callback function to DataTables using I()
-#' shinyApp(
-#'   ui = fluidPage(
-#'     fluidRow(
-#'       column(12,
-#'         dataTableOutput('table')
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   # pass a callback function to DataTables using I()
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       fluidRow(
+#'         column(12,
+#'           dataTableOutput('table')
+#'         )
 #'       )
-#'     )
-#'   ),
-#'   server = function(input, output) {
-#'     output$table <- renderDataTable(iris,
-#'       options = list(
-#'         pageLength = 5,
-#'         initComplete = I("function(settings, json) {alert('Done.');}")
+#'     ),
+#'     server = function(input, output) {
+#'       output$table <- renderDataTable(iris,
+#'         options = list(
+#'           pageLength = 5,
+#'           initComplete = I("function(settings, json) {alert('Done.');}")
+#'         )
 #'       )
-#'     )
-#'   }
-#' )
+#'     }
+#'   )
 #' }
 renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             callback = 'function(oTable) {}', escape = TRUE,
-                            env = parent.frame(), quoted = FALSE) {
+                            env = parent.frame(), quoted = FALSE,
+                            outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  markRenderFunction(dataTableOutput, function(shinysession, name, ...) {
+  renderFunc <- function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
     options <- checkDT9(options)
     res <- checkAsIs(options)
-    data <- func()
-    if (length(dim(data)) != 2) return() # expects a rectangular data object
-    if (is.data.frame(data)) data <- as.data.frame(data)
-    action <- shinysession$registerDataObj(name, data, dataTablesJSON)
-    colnames <- colnames(data)
-    # if escape is column names, turn names to numeric indices
-    if (is.character(escape)) {
-      escape <- setNames(seq_len(ncol(data)), colnames)[escape]
-      if (any(is.na(escape)))
-        stop("Some column names in the 'escape' argument not found in data")
-    }
-    colnames[escape] <- htmlEscape(colnames[escape])
-    if (!is.logical(escape)) {
-      if (!is.numeric(escape))
-        stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
-      escape <- paste(escape, collapse = ',')
-    }
-    list(
-      colnames = colnames, action = action, options = res$options,
-      evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
-      callback = paste(callback, collapse = '\n'), escape = escape
+    hybrid_chain(
+      func(),
+      function(data) {
+        if (length(dim(data)) != 2) return() # expects a rectangular data object
+        if (is.data.frame(data)) data <- as.data.frame(data)
+        action <- shinysession$registerDataObj(name, data, dataTablesJSON)
+        colnames <- colnames(data)
+        # if escape is column names, turn names to numeric indices
+        if (is.character(escape)) {
+          escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
+          if (any(is.na(escape)))
+            stop("Some column names in the 'escape' argument not found in data")
+        }
+        colnames[escape] <- htmlEscape(colnames[escape])
+        if (!is.logical(escape)) {
+          if (!is.numeric(escape))
+            stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
+          escape <- paste(escape, collapse = ',')
+        }
+        list(
+          colnames = colnames, action = action, options = res$options,
+          evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
+          callback = paste(callback, collapse = '\n'), escape = escape
+        )
+      }
     )
+  }
+
+  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+
+  renderFunc <- snapshotPreprocessOutput(renderFunc, function(value) {
+    # Remove the action field so that it's not saved in test snapshots. It
+    # contains a value that changes every time an app is run, and shouldn't be
+    # stored for test snapshots. It will be something like:
+    # "session/e0d14d3fe97f672f9655a127f2a1e079/dataobj/table?w=&nonce=7f5d6d54e22450a3"
+    value$action <- NULL
+    value
   })
+
+  renderFunc
 }
 
 # a data frame containing the DataTables 1.9 and 1.10 names
 DT10Names <- function() {
   rbind(
-    read.table(system.file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
-               stringsAsFactors = FALSE),
+    utils::read.table(
+      system.file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
+      stringsAsFactors = FALSE
+    ),
     c('aoColumns', 'Removed')  # looks like an omission on the upgrade guide
   )
 }
@@ -637,7 +689,7 @@ checkDT9 <- function(options) {
     'and DataTables 1.10.x uses different parameter names with 1.9.x. ',
     'Please follow the upgrade guide https://datatables.net/upgrade/1.10-convert',
     ' to change your DataTables parameter names:\n\n',
-    paste(formatUL(nms[i]), collapse = '\n'), '\n', sep = ''
+    paste(utils::formatUL(nms[i]), collapse = '\n'), '\n', sep = ''
   )
   j <- gsub('[.].*', '', DT10[, 1]) %in% nms
   # I cannot help you upgrade automatically in these cases, so I have to stop
@@ -646,7 +698,7 @@ checkDT9 <- function(options) {
   nms10 <- DT10[match(nms[i], DT10[, 1]), 2]
   if (any(nms10 == 'Removed')) stop(
     "These parameters have been removed in DataTables 1.10.x:\n\n",
-    paste(formatUL(nms[i][nms10 == 'Removed']), collapse = '\n'),
+    paste(utils::formatUL(nms[i][nms10 == 'Removed']), collapse = '\n'),
     "\n\n", msg
   )
   names(options)[i] <- nms10

R/showcase.R

@@ -18,7 +18,8 @@ licenseLink <- function(licenseName) {
     "Artistic-2.0" = "http://www.r-project.org/Licenses/Artistic-2.0",
     "BSD_2_clause" = "http://www.r-project.org/Licenses/BSD_2_clause",
     "BSD_3_clause" = "http://www.r-project.org/Licenses/BSD_3_clause",
-    "MIT" = "http://www.r-project.org/Licenses/MIT")
+    "MIT" = "http://www.r-project.org/Licenses/MIT",
+    "CC-BY-SA-4.0" = "https://www.r-project.org/Licenses/CC-BY-SA-4.0")
   if (exists(licenseName, where = licenses)) {
     tags$a(href=licenses[[licenseName]], licenseName)
   } else {
@@ -31,7 +32,7 @@ licenseLink <- function(licenseName) {
 showcaseHead <- function() {
 
   deps  <- list(
-    htmlDependency("jqueryui", "1.10.4", c(href="shared/jqueryui/1.10.4"),
+    htmlDependency("jqueryui", "1.12.1", c(href="shared/jqueryui"),
       script = "jquery-ui.min.js"),
     htmlDependency("showdown", "0.3.1", c(href="shared/showdown/compressed"),
       script = "showdown.js"),
@@ -77,10 +78,60 @@ appMetadata <- function(desc) {
   else ""
 }
 
+navTabsHelper <- function(files, prefix = "") {
+  lapply(files, function(file) {
+    with(tags,
+      li(class=if (tolower(file) %in% c("app.r", "server.r")) "active" else "",
+         a(href=paste("#", gsub(".", "_", file, fixed=TRUE), "_code", sep=""),
+           "data-toggle"="tab", paste0(prefix, file)))
+    )
+  })
+}
+
+navTabsDropdown <- function(files) {
+  if (length(files) > 0) {
+    with(tags,
+      li(role="presentation", class="dropdown",
+        a(class="dropdown-toggle", `data-toggle`="dropdown", href="#",
+          role="button", `aria-haspopup`="true", `aria-expanded`="false",
+          "www", span(class="caret")
+        ),
+        ul(class="dropdown-menu", navTabsHelper(files))
+      )
+    )
+  }
+}
+
+tabContentHelper <- function(files, path, language) {
+  lapply(files, function(file) {
+    with(tags,
+      div(class=paste("tab-pane",
+                      if (tolower(file) %in% c("app.r", "server.r")) " active"
+                      else "",
+                      sep=""),
+          id=paste(gsub(".", "_", file, fixed=TRUE),
+                   "_code", sep=""),
+          pre(class="shiny-code",
+              # we need to prevent the indentation of <code> ... </code>
+              HTML(format(tags$code(
+                class=paste0("language-", language),
+                paste(readUTF8(file.path.ci(path, file)), collapse="\n")
+              ), indent = FALSE))))
+    )
+  })
+}
+
 # Returns tags containing the application's code in Bootstrap-style tabs in
 # showcase mode.
 showcaseCodeTabs <- function(codeLicense) {
   rFiles <- list.files(pattern = "\\.[rR]$")
+  wwwFiles <- list()
+  if (isTRUE(.globals$IncludeWWW)) {
+    path <- file.path(getwd(), "www")
+    wwwFiles$jsFiles <- list.files(path, pattern = "\\.js$")
+    wwwFiles$cssFiles <- list.files(path, pattern = "\\.css$")
+    wwwFiles$htmlFiles <- list.files(path, pattern = "\\.html$")
+  }
   with(tags, div(id="showcase-code-tabs",
     a(id="showcase-code-position-toggle",
       class="btn btn-default btn-sm",
@@ -88,27 +139,21 @@ showcaseCodeTabs <- function(codeLicense) {
       icon("level-up"),
       "show with app"),
     ul(class="nav nav-tabs",
-       lapply(rFiles, function(rFile) {
-         li(class=if (tolower(rFile) %in% c("app.r", "server.r")) "active" else "",
-            a(href=paste("#", gsub(".", "_", rFile, fixed=TRUE),
-                         "_code", sep=""),
-              "data-toggle"="tab", rFile))
-       })),
+       navTabsHelper(rFiles),
+       navTabsDropdown(unlist(wwwFiles))
+    ),
     div(class="tab-content", id="showcase-code-content",
-        lapply(rFiles, function(rFile) {
-          div(class=paste("tab-pane",
-                          if (tolower(rFile) %in% c("app.r", "server.r")) " active"
-                          else "",
-                          sep=""),
-              id=paste(gsub(".", "_", rFile, fixed=TRUE),
-                       "_code", sep=""),
-              pre(class="shiny-code",
-                  # we need to prevent the indentation of <code> ... </code>
-                  HTML(format(tags$code(
-                    class="language-r",
-                    paste(readUTF8(file.path.ci(getwd(), rFile)), collapse="\n")
-                  ), indent = FALSE))))
-        })),
+        tabContentHelper(rFiles, path = getwd(), language = "r"),
+        tabContentHelper(wwwFiles$jsFiles,
+                         path = paste0(getwd(), "/www"),
+                         language = "javascript"),
+        tabContentHelper(wwwFiles$cssFiles,
+                         path = paste0(getwd(), "/www"),
+                         language = "css"),
+        tabContentHelper(wwwFiles$htmlFiles,
+                         path = paste0(getwd(), "/www"),
+                         language = "xml")
+    ),
     codeLicense))
 }
 
@@ -177,3 +222,4 @@ showcaseUI <- function(ui) {
     showcaseBody(ui)
   )
 }
+

R/slider.R

@@ -1,26 +0,0 @@
-hasDecimals <- function(value) {
-  truncatedValue <- round(value)
-  return (!identical(value, truncatedValue))
-}
-
-#' @rdname sliderInput
-#'
-#' @param interval The interval, in milliseconds, between each animation step.
-#' @param loop \code{TRUE} to automatically restart the animation when it
-#'   reaches the end.
-#' @param playButton Specifies the appearance of the play button. Valid values
-#'   are a one-element character vector (for a simple text label), an HTML tag
-#'   or list of tags (using \code{\link{tag}} and friends), or raw HTML (using
-#'   \code{\link{HTML}}).
-#' @param pauseButton Similar to \code{playButton}, but for the pause button.
-#'
-#' @export
-animationOptions <- function(interval=1000,
-                             loop=FALSE,
-                             playButton=NULL,
-                             pauseButton=NULL) {
-  list(interval=interval,
-       loop=loop,
-       playButton=playButton,
-       pauseButton=pauseButton)
-}

R/snapshot.R

@@ -0,0 +1,44 @@
+#' Mark an output to be excluded from test snapshots
+#'
+#' @param x A reactive which will be assigned to an output.
+#'
+#' @export
+snapshotExclude <- function(x) {
+  markOutputAttrs(x, snapshotExclude = TRUE)
+}
+
+#' Add a function for preprocessing an output before taking a test snapshot
+#'
+#' @param x A reactive which will be assigned to an output.
+#' @param fun A function that takes the output value as an input and returns a
+#'   modified value. The returned value will be used for the test snapshot.
+#'
+#' @export
+snapshotPreprocessOutput <- function(x, fun) {
+  markOutputAttrs(x, snapshotPreprocess = fun)
+}
+
+
+#' Add a function for preprocessing an input before taking a test snapshot
+#'
+#' @param inputId Name of the input value.
+#' @param fun A function that takes the input value and returns a modified
+#'   value. The returned value will be used for the test snapshot.
+#' @param session A Shiny session object.
+#'
+#' @export
+snapshotPreprocessInput <- function(inputId, fun, session = getDefaultReactiveDomain()) {
+  if (is.null(session)) {
+    stop("snapshotPreprocessInput() needs a session object.")
+  }
+
+  input_impl <- .subset2(session$input, "impl")
+  input_impl$setMeta(inputId, "shiny.snapshot.preprocess", fun)
+}
+
+
+# Strip out file path from fileInput value
+snapshotPreprocessorFileInput <- function(value) {
+  value$datapath <- basename(value$datapath)
+  value
+}

R/tar.R

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

R/test-export.R

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

R/timer.R

@@ -22,6 +22,11 @@ TimerCallbacks <- R6Class(
       .times <<- data.frame()
     },
     schedule = function(millis, func) {
+      # If args could fail to evaluate, let's make them do that before
+      # we change any state
+      force(millis)
+      force(func)
+
       id <- .nextId
       .nextId <<- .nextId + 1L
 
@@ -37,6 +42,17 @@ TimerCallbacks <- R6Class(
 
       return(id)
     },
+    unschedule = function(id) {
+      toRemoveIndices <- .times$id %in% id
+      toRemoveIds <- .times[toRemoveIndices, "id", drop = TRUE]
+      if (length(toRemoveIds) > 0) {
+        .times <<- .times[!toRemoveIndices,]
+        for (toRemoveId in as.character(toRemoveIds)) {
+          .funcs$remove(toRemoveId)
+        }
+      }
+      return(id %in% toRemoveIds)
+    },
     timeToNextEvent = function() {
       if (dim(.times)[1] == 0)
         return(Inf)
@@ -56,7 +72,7 @@ TimerCallbacks <- R6Class(
     },
     executeElapsed = function() {
       elapsed <- takeElapsed()
-      if (length(elapsed) == 0)
+      if (nrow(elapsed) == 0)
         return(FALSE)
 
       for (id in elapsed$id) {
@@ -71,3 +87,12 @@ TimerCallbacks <- R6Class(
 )
 
 timerCallbacks <- TimerCallbacks$new()
+
+scheduleTask <- function(millis, callback) {
+  cancelled <- FALSE
+  id <- timerCallbacks$schedule(millis, callback)
+
+  function() {
+    invisible(timerCallbacks$unschedule(id))
+  }
+}

R/update-input.R

@@ -2,13 +2,21 @@
 #'
 #' @template update-input
 #' @param value The value to set for the input object.
+#' @param placeholder The placeholder to set for the input object.
 #'
 #' @seealso \code{\link{textInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   textInput("inText", "Input text"),
+#'   textInput("inText2", "Input text 2")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
@@ -22,14 +30,54 @@
 #'       label = paste("New label", x),
 #'       value = paste("New text", x))
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
-updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
-  message <- dropNulls(list(label=label, value=value))
+updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeholder = NULL) {
+  message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
   session$sendInputMessage(inputId, message)
 }
 
+#' Change the value of a textarea input on the client
+#'
+#' @template update-input
+#' @inheritParams updateTextInput
+#'
+#' @seealso \code{\link{textAreaInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   textAreaInput("inText", "Input textarea"),
+#'   textAreaInput("inText2", "Input textarea 2")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     # This will change the value of input$inText, based on x
+#'     updateTextAreaInput(session, "inText", value = paste("New text", x))
+#'
+#'     # Can also set the label, this time for input$inText2
+#'     updateTextAreaInput(session, "inText2",
+#'       label = paste("New label", x),
+#'       value = paste("New text", x))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+updateTextAreaInput <- updateTextInput
+
 
 #' Change the value of a checkbox input on the client
 #'
@@ -39,26 +87,90 @@ updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
 #' @seealso \code{\link{checkboxInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 1, 0, step = 1),
+#'   checkboxInput("inCheckbox", "Input checkbox")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # TRUE if input$controller is even, FALSE otherwise.
-#'     x_even <- input$controller %% 2 == 0
+#'     # TRUE if input$controller is odd, FALSE if even.
+#'     x_even <- input$controller %% 2 == 1
 #'
 #'     updateCheckboxInput(session, "inCheckbox", value = x_even)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
-updateCheckboxInput <- updateTextInput
+updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
+  message <- dropNulls(list(label=label, value=value))
+  session$sendInputMessage(inputId, message)
+}
+
+
+#' Change the label or icon of an action button on the client
+#'
+#' @template update-input
+#' @param icon The icon to set for the input object. To remove the
+#' current icon, use \code{icon=character(0)}.
+#'
+#' @seealso \code{\link{actionButton}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   actionButton("update", "Update other buttons"),
+#'   br(),
+#'   actionButton("goButton", "Go"),
+#'   br(),
+#'   actionButton("goButton2", "Go 2", icon = icon("area-chart")),
+#'   br(),
+#'   actionButton("goButton3", "Go 3")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observe({
+#'     req(input$update)
+#'
+#'     # Updates goButton's label and icon
+#'     updateActionButton(session, "goButton",
+#'       label = "New label",
+#'       icon = icon("calendar"))
+#'
+#'     # Leaves goButton2's label unchaged and
+#'     # removes its icon
+#'     updateActionButton(session, "goButton2",
+#'       icon = character(0))
+#'
+#'     # Leaves goButton3's icon, if it exists,
+#'     # unchaged and changes its label
+#'     updateActionButton(session, "goButton3",
+#'       label = "New label 3")
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
+  if (!is.null(icon)) icon <- as.character(validateIcon(icon))
+  message <- dropNulls(list(label=label, icon=icon))
+  session$sendInputMessage(inputId, message)
+}
 
 
 #' Change the value of a date input on the client
 #'
 #' @template update-input
 #' @param value The desired date value. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supply \code{NA} to clear the date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -67,32 +179,44 @@ updateCheckboxInput <- updateTextInput
 #' @seealso \code{\link{dateInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("n", "Day of month", 1, 30, 10),
+#'   dateInput("inDate", "Input date")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
-#'
+#'     date <- as.Date(paste0("2013-04-", input$n))
 #'     updateDateInput(session, "inDate",
-#'       label = paste("Date label", x),
-#'       value = paste("2013-04-", x, sep=""),
-#'       min   = paste("2013-04-", x-1, sep=""),
-#'       max   = paste("2013-04-", x+1, sep="")
+#'       label = paste("Date label", input$n),
+#'       value = date,
+#'       min   = date - 3,
+#'       max   = date + 3
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
                             min = NULL, max = NULL) {
 
-  # If value is a date object, convert it to a string with yyyy-mm-dd format
-  # Same for min and max
-  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
-  if (inherits(min, "Date"))    min   <- format(min,   "%Y-%m-%d")
-  if (inherits(max, "Date"))    max   <- format(max,   "%Y-%m-%d")
+  # Make sure values are NULL or Date objects. This is so we can ensure that
+  # they will be formatted correctly. For example, the string "2016-08-9" is not
+  # correctly formatted, but the conversion to Date and back to string will fix
+  # it.
+  formatDate <- function(x) {
+    if (is.null(x))
+      return(NULL)
+    format(as.Date(x), "%Y-%m-%d")
+  }
+  value <- formatDate(value)
+  min   <- formatDate(min)
+  max   <- formatDate(max)
 
   message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
@@ -103,9 +227,9 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #'
 #' @template update-input
 #' @param start The start date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the start date.
 #' @param end The end date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the end date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -114,20 +238,29 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #' @seealso \code{\link{dateRangeInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   sliderInput("n", "Day of month", 1, 30, 10),
+#'   dateRangeInput("inDateRange", "Input date range")
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     date <- as.Date(paste0("2013-04-", input$n))
 #'
 #'     updateDateRangeInput(session, "inDateRange",
-#'       label = paste("Date range label", x),
-#'       start = paste("2013-01-", x, sep=""))
-#'       end = paste("2013-12-", x, sep=""))
+#'       label = paste("Date range label", input$n),
+#'       start = date - 1,
+#'       end = date + 1,
+#'       min = date - 5,
+#'       max = date + 5
+#'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateDateRangeInput <- function(session, inputId, label = NULL,
@@ -142,7 +275,7 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 
   message <- dropNulls(list(
     label = label,
-    value = c(start, end),
+    value = dropNulls(list(start = start, end = end)),
     min = min,
     max = max
   ))
@@ -162,22 +295,31 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 #' \code{\link{navbarPage}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#'   observe({
-#'     # TRUE if input$controller is even, FALSE otherwise.
-#'     x_even <- input$controller %% 2 == 0
+#' ui <- fluidPage(sidebarLayout(
+#'   sidebarPanel(
+#'     sliderInput("controller", "Controller", 1, 3, 1)
+#'   ),
+#'   mainPanel(
+#'     tabsetPanel(id = "inTabset",
+#'       tabPanel(title = "Panel 1", value = "panel1", "Panel 1 content"),
+#'       tabPanel(title = "Panel 2", value = "panel2", "Panel 2 content"),
+#'       tabPanel(title = "Panel 3", value = "panel3", "Panel 3 content")
+#'     )
+#'   )
+#' ))
 #'
-#'     # Change the selected tab.
-#'     # Note that the tabset container must have been created with an 'id' argument
-#'     if (x_even) {
-#'       updateTabsetPanel(session, "inTabset", selected = "panel2")
-#'     } else {
-#'       updateTabsetPanel(session, "inTabset", selected = "panel1")
-#'     }
+#' server <- function(input, output, session) {
+#'   observeEvent(input$controller, {
+#'     updateTabsetPanel(session, "inTabset",
+#'       selected = paste0("panel", input$controller)
+#'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateTabsetPanel <- function(session, inputId, selected = NULL) {
@@ -185,6 +327,13 @@ updateTabsetPanel <- function(session, inputId, selected = NULL) {
   session$sendInputMessage(inputId, message)
 }
 
+#' @rdname updateTabsetPanel
+#' @export
+updateNavbarPage <- updateTabsetPanel
+
+#' @rdname updateTabsetPanel
+#' @export
+updateNavlistPanel <- updateTabsetPanel
 
 #' Change the value of a number input on the client
 #'
@@ -197,10 +346,18 @@ updateTabsetPanel <- function(session, inputId, selected = NULL) {
 #' @seealso \code{\link{numericInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
-#'   observe({
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   numericInput("inNumber", "Input number", 0),
+#'   numericInput("inNumber2", "Input number 2", 0)
+#' )
+#'
+#' server <- function(input, output, session) {
+#'
+#'   observeEvent(input$controller, {
 #'     # We'll use the input$controller variable multiple times, so save it as x
 #'     # for convenience.
 #'     x <- input$controller
@@ -211,7 +368,9 @@ updateTabsetPanel <- function(session, inputId, selected = NULL) {
 #'       label = paste("Number label ", x),
 #'       value = x, min = x-10, max = x+10, step = 5)
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
@@ -224,57 +383,93 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
   session$sendInputMessage(inputId, message)
 }
 
-#' Change the value of a slider input on the client
+#' Update Slider Input Widget
+#'
+#' Change the value of a slider input on the client.
 #'
 #' @template update-input
 #' @param value The value to set for the input object.
 #' @param min Minimum value.
 #' @param max Maximum value.
 #' @param step Step size.
+#' @param timeFormat Date and POSIXt formatting.
+#' @param timezone The timezone offset for POSIXt objects.
 #'
 #' @seealso \code{\link{sliderInput}}
 #'
 #' @examples
-#' \donttest{
-#' shinyApp(
-#'   ui = fluidPage(
-#'     sidebarLayout(
-#'       sidebarPanel(
-#'         p("The first slider controls the second"),
-#'         slider2Input("control", "Controller:", min=0, max=20, value=10,
-#'                      step=1),
-#'         slider2Input("receive", "Receiver:", min=0, max=20, value=10,
-#'                      step=1)
-#'       ),
-#'       mainPanel()
-#'     )
-#'   ),
-#'   server = function(input, output, session) {
-#'     observe({
-#'       val <- input$control
-#'       # Control the value, min, max, and step.
-#'       # Step size is 2 when input value is even; 1 when value is odd.
-#'       updateSliderInput(session, "receive", value = val,
-#'         min = floor(val/2), max = val+4, step = (val+1)%%2 + 1)
-#'     })
-#'   }
-#' )
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       sidebarLayout(
+#'         sidebarPanel(
+#'           p("The first slider controls the second"),
+#'           sliderInput("control", "Controller:", min=0, max=20, value=10,
+#'                        step=1),
+#'           sliderInput("receive", "Receiver:", min=0, max=20, value=10,
+#'                        step=1)
+#'         ),
+#'         mainPanel()
+#'       )
+#'     ),
+#'     server = function(input, output, session) {
+#'       observe({
+#'         val <- input$control
+#'         # Control the value, min, max, and step.
+#'         # Step size is 2 when input value is even; 1 when value is odd.
+#'         updateSliderInput(session, "receive", value = val,
+#'           min = floor(val/2), max = val+4, step = (val+1)%%2 + 1)
+#'       })
+#'     }
+#'   )
 #' }
 #' @export
-updateSliderInput <- updateNumericInput
+updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
+  min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
+{
+  dataType <- getSliderType(min, max, value)
+
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
+  }
+
+  if (dataType == "date" || dataType == "datetime") {
+    to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
+    if (!is.null(min))   min   <- to_ms(min)
+    if (!is.null(max))   max   <- to_ms(max)
+    if (!is.null(value)) value <- to_ms(value)
+  }
+
+  message <- dropNulls(list(
+    label = label,
+    value = formatNoSci(value),
+    min = formatNoSci(min),
+    max = formatNoSci(max),
+    step = formatNoSci(step),
+    `data-type` = dataType,
+    `time-format` = timeFormat,
+    timezone = timezone
+  ))
+  session$sendInputMessage(inputId, message)
+}
+
 
 updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
-                               selected = NULL, inline = FALSE,
-                               type = 'checkbox') {
+                               selected = NULL, inline = FALSE, type = NULL,
+                               choiceNames = NULL, choiceValues = NULL) {
+  if (is.null(type)) stop("Please specify the type ('checkbox' or 'radio')")
 
-  choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues, mustExist = FALSE)
 
-  options <- if (length(choices))
+  if (!is.null(selected)) selected <- as.character(selected)
+
+  options <- if (!is.null(args$choiceValues)) {
     format(tagList(
-      generateOptions(inputId, choices, selected, inline, type = type)
+      generateOptions(session$ns(inputId), selected, inline, type,
+        args$choiceNames, args$choiceValues)
     ))
+  }
 
   message <- dropNulls(list(label = label, options = options, value = selected))
 
@@ -289,37 +484,42 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' @seealso \code{\link{checkboxGroupInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The first checkbox group controls the second"),
+#'   checkboxGroupInput("inCheckboxGroup", "Input checkbox",
+#'     c("Item A", "Item B", "Item C")),
+#'   checkboxGroupInput("inCheckboxGroup2", "Input checkbox 2",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inCheckboxGroup
 #'
-#'     # Create a list of new options, where the name of the items is something
-#'     # like 'option label x 1', and the values are 'option-x-1'.
-#'     cb_options <- list()
-#'     cb_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     cb_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
-#'
-#'     # Change values for input$inCheckboxGroup
-#'     updateCheckboxGroupInput(session, "inCheckboxGroup", choices = cb_options)
+#'     # Can use character(0) to remove all choices
+#'     if (is.null(x))
+#'       x <- character(0)
 #'
 #'     # Can also set the label and select items
 #'     updateCheckboxGroupInput(session, "inCheckboxGroup2",
-#'       label = paste("checkboxgroup label", x),
-#'       choices = cb_options,
-#'       selected = sprintf("option-%d-2", x)
+#'       label = paste("Checkboxgroup label", length(x)),
+#'       choices = x,
+#'       selected = x
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateCheckboxGroupInput <- function(session, inputId, label = NULL,
-                                     choices = NULL, selected = NULL,
-                                     inline = FALSE) {
-  updateInputOptions(session, inputId, label, choices, selected, inline)
+  choices = NULL, selected = NULL, inline = FALSE,
+  choiceNames = NULL, choiceValues = NULL) {
+  updateInputOptions(session, inputId, label, choices, selected,
+                     inline, "checkbox", choiceNames, choiceValues)
 }
 
 
@@ -331,36 +531,43 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' @seealso \code{\link{radioButtons}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The first radio button group controls the second"),
+#'   radioButtons("inRadioButtons", "Input radio buttons",
+#'     c("Item A", "Item B", "Item C")),
+#'   radioButtons("inRadioButtons2", "Input radio buttons 2",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inRadioButtons
 #'
-#'     r_options <- list()
-#'     r_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     r_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
-#'
-#'     # Change values for input$inRadio
-#'     updateRadioButtons(session, "inRadio", choices = r_options)
-#'
-#'     # Can also set the label and select an item
-#'     updateRadioButtons(session, "inRadio2",
-#'       label = paste("Radio label", x),
-#'       choices = r_options,
-#'       selected = sprintf("option-%d-2", x)
+#'     # Can also set the label and select items
+#'     updateRadioButtons(session, "inRadioButtons2",
+#'       label = paste("radioButtons label", x),
+#'       choices = x,
+#'       selected = x
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
-                               selected = NULL, inline = FALSE) {
+                               selected = NULL, inline = FALSE,
+                               choiceNames = NULL, choiceValues = NULL) {
   # you must select at least one radio button
-  if (is.null(selected) && !is.null(choices)) selected <- choices[[1]]
-  updateInputOptions(session, inputId, label, choices, selected, inline, type = 'radio')
+  if (is.null(selected)) {
+    if (!is.null(choices)) selected <- choices[[1]]
+    else if (!is.null(choiceValues)) selected <- choiceValues[[1]]
+  }
+  updateInputOptions(session, inputId, label, choices, selected,
+    inline, 'radio', choiceNames, choiceValues)
 }
 
 
@@ -369,43 +576,45 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @template update-input
 #' @inheritParams selectInput
 #'
-#' @seealso \code{\link{selectInput}}
+#' @seealso \code{\link{selectInput}} \code{\link{varSelectInput}}
 #'
 #' @examples
-#' \dontrun{
-#' shinyServer(function(input, output, session) {
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
 #'
+#' ui <- fluidPage(
+#'   p("The checkbox group controls the select input"),
+#'   checkboxGroupInput("inCheckboxGroup", "Input checkbox",
+#'     c("Item A", "Item B", "Item C")),
+#'   selectInput("inSelect", "Select input",
+#'     c("Item A", "Item B", "Item C"))
+#' )
+#'
+#' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     x <- input$inCheckboxGroup
 #'
-#'     # Create a list of new options, where the name of the items is something
-#'     # like 'option label x 1', and the values are 'option-x-1'.
-#'     s_options <- list()
-#'     s_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
-#'     s_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
+#'     # Can use character(0) to remove all choices
+#'     if (is.null(x))
+#'       x <- character(0)
 #'
-#'     # Change values for input$inSelect
-#'     updateSelectInput(session, "inSelect", choices = s_options)
-#'
-#'     # Can also set the label and select an item (or more than one if it's a
-#'     # multi-select)
-#'     updateSelectInput(session, "inSelect2",
-#'       label = paste("Select label", x),
-#'       choices = s_options,
-#'       selected = sprintf("option-%d-2", x)
+#'     # Can also set the label and select items
+#'     updateSelectInput(session, "inSelect",
+#'       label = paste("Select input label", length(x)),
+#'       choices = x,
+#'       selected = tail(x, 1)
 #'     )
 #'   })
-#' })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
 updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
                               selected = NULL) {
-  choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
-  options <- if (length(choices)) selectOptions(choices, selected)
+  choices <- if (!is.null(choices)) choicesWithNames(choices)
+  if (!is.null(selected)) selected <- as.character(selected)
+  options <- if (!is.null(choices)) selectOptions(choices, selected)
   message <- dropNulls(list(label = label, options = options, value = selected))
   session$sendInputMessage(inputId, message)
 }
@@ -424,7 +633,7 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     res <- checkAsIs(options)
     cfg <- tags$script(
       type = 'application/json',
-      `data-for` = inputId,
+      `data-for` = session$ns(inputId),
       `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
       HTML(toJSON(res$options))
     )
@@ -433,54 +642,180 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   if (!server) {
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
-  # in the server mode, the choices are not available before we type, so we
-  # cannot really pre-select any options, but here we insert the `selected`
-  # options into selectize forcibly
+
+  noOptGroup <- TRUE
+  if (is.list(choices)) {
+    # check if list is nested
+    for (i in seq_along(choices)) {
+      if (is.list(choices[[i]]) || length(choices[[i]]) > 1) {
+        noOptGroup <- FALSE
+        break()
+      }
+    }
+  }
+  # convert choices to a data frame so it returns [{label: , value: , optgroup: },...]
+  choices <- if (is.data.frame(choices)) {
+    # jcheng 2018/09/25: I don't think we ever said data frames were OK to pass
+    # to updateSelectInput, but one of the example apps does this and at least
+    # one user noticed when we broke it.
+    # https://github.com/rstudio/shiny/issues/2172
+    # https://github.com/rstudio/shiny/issues/2192
+    as.data.frame(choices, stringsAsFactors = FALSE)
+  } else if (is.atomic(choices) || noOptGroup) {
+    # fast path for vectors and flat lists
+    if (is.list(choices)) {
+      choices <- unlist(choices)
+    }
+    if (is.null(names(choices))) {
+      lab <- as.character(choices)
+    } else {
+      lab <- names(choices)
+      # replace empty names like: choices = c(a = 1, 2)
+      # in this case: names(choices) = c("a", "")
+      # with replacement below choices will be: lab = c("a", "2")
+      empty_names_indices <- lab == ""
+      lab[empty_names_indices] <- as.character(choices[empty_names_indices])
+    }
+    data.frame(label = lab, value = choices, stringsAsFactors = FALSE)
+  } else {
+    # slow path for nested lists/optgroups
+    list_names <- names(choices)
+    if (is.null(list_names)) {
+      list_names <- rep("", length(choices))
+    }
+
+    choice_list <- mapply(choices, list_names, FUN = function (choice, name) {
+      group <- ""
+      lab <- name
+      if (lab == "") lab <- as.character(choice)
+
+      if (is.list(choice) || length(choice) > 1) {
+        group <- rep(name, length(choice))
+        choice <- unlist(choice)
+
+        if (is.null(names(choice))) {
+          lab <- as.character(choice)
+        } else {
+          lab <- names(choice)
+          # replace empty names like: choices = c(a = 1, 2)
+          # in this case: names(choices) = c("a", "")
+          # with replacement below choices will be: lab = c("a", "2")
+          empty_names_indices <- lab == ""
+          lab[empty_names_indices] <- as.character(choice[empty_names_indices])
+        }
+      }
+
+      list(
+        label = lab,
+        value = as.character(choice),
+        # The name "optgroup" is because this is the default field where
+        # selectize will look for group IDs
+        optgroup = group
+      )
+    }, SIMPLIFY = FALSE)
+
+
+    extract_vector <- function(x, name) {
+      vecs <- lapply(x, `[[`, name)
+      do.call(c, vecs)
+    }
+
+    data.frame(
+      label = extract_vector(choice_list, "label"),
+      value = extract_vector(choice_list, "value"),
+      optgroup = extract_vector(choice_list, "optgroup"),
+      stringsAsFactors = FALSE, row.names = NULL
+    )
+  }
+
   value <- unname(selected)
-  selected <- choicesWithNames(selected)
+  attr(choices, 'selected_value') <- value
+
   message <- dropNulls(list(
     label = label,
     value = value,
-    selected = if (length(selected)) {
-      columnToRowData(list(label = names(selected), value = selected))
-    },
     url = session$registerDataObj(inputId, choices, selectizeJSON)
   ))
   session$sendInputMessage(inputId, message)
 }
+#' @rdname updateSelectInput
+#' @inheritParams varSelectInput
+#' @export
+updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected
+  )
+}
+#' @rdname updateSelectInput
+#' @export
+updateVarSelectizeInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL, options = list(), server = FALSE) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectizeInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected,
+    options = options,
+    server = server
+  )
+}
+
+
 
 selectizeJSON <- function(data, req) {
   query <- parseQueryString(req$QUERY_STRING)
+
   # extract the query variables, conjunction (and/or), search string, maximum options
-  var <- unlist(fromJSON(query$field, asText = TRUE))
-  cjn <- if (query$conju == 'and') all else any
+  var <- c(safeFromJSON(query$field))
+
   # all keywords in lower-case, for case-insensitive matching
   key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
-  if (identical(key, '')) key <- character(0)
-  mop <- query$maxop
 
-  # convert a single vector to a data frame so it returns {label: , value: }
-  # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
-  data <- if (is.atomic(data)) {
-    data.frame(label = names(choicesWithNames(data)), value = data,
-               stringsAsFactors = FALSE)
-  } else as.data.frame(data, stringsAsFactors = FALSE)
+  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)
 
   # start searching for keywords in all specified columns
   idx <- logical(nrow(data))
-  if (length(key)) for (v in var) {
-    matches <- do.call(
-      cbind,
-      lapply(key, function(k) {
-        grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
-      })
-    )
-    # merge column matches using OR, and match multiple keywords in one column
-    # using the conjunction setting (AND or OR)
-    idx <- idx | apply(matches, 1, cjn)
+  if (length(key)) {
+    for (v in var) {
+      matches <- do.call(
+        cbind,
+        lapply(key, function(k) {
+          grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
+        })
+      )
+      # merge column matches using OR, and match multiple keywords in one column
+      # using the conjunction setting (AND or OR)
+      matches <- rowSums(matches)
+      if (query$conju == 'and')
+        idx <- idx | (matches == length(key))
+      else
+        idx <- idx | matches
+    }
   }
   # only return the first n rows (n = maximum options in configuration)
-  idx <- head(which(idx), mop)
+  idx <- utils::head(if (length(key)) which(idx) else seq_along(idx), mop)
+  # make sure the selected value is in the data
+  if (length(sel)) {
+    i <- stats::na.omit(match(sel, data[, vfd]))
+    if (length(i)) idx <- sort(utils::head(unique(c(i, idx)), mop))
+  }
   data <- data[idx, ]
 
   res <- toJSON(columnToRowData(data))

README.md

@@ -1,20 +1,24 @@
 # Shiny
 
-[![Build Status](https://travis-ci.org/rstudio/shiny.svg?branch=master)](https://travis-ci.org/rstudio/shiny)
+*Travis:* [![Travis Build Status](https://travis-ci.org/rstudio/shiny.svg?branch=master)](https://travis-ci.org/rstudio/shiny)
+
+*AppVeyor:* [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/rstudio/shiny?branch=master&svg=true)](https://ci.appveyor.com/project/rstudio/shiny)
 
 Shiny is a new package from RStudio that makes it incredibly easy to build interactive web applications with R.
 
 For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstudio.com/).
 
+If you have general questions about using Shiny, please use the [RStudio Community website](https://community.rstudio.com). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
+
 ## Features
 
 * Build useful web applications with only a few lines of code—no JavaScript required.
 * Shiny applications are automatically "live" in the same way that spreadsheets are live. Outputs change instantly as users modify inputs, without requiring a reload of the browser.
 * Shiny user interfaces can be built entirely using R, or can be written directly in HTML, CSS, and JavaScript for more flexibility.
-* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.)
-* Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/2.3.2/).
+* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.).
+* Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/).
 * A highly customizable slider widget with built-in support for animation.
-* Pre-built output widgets for displaying plots, tables, and printed output of R objects.
+* Prebuilt output widgets for displaying plots, tables, and printed output of R objects.
 * Fast bidirectional communication between the web browser and R using the [httpuv](https://github.com/rstudio/httpuv) package.
 * Uses a [reactive](http://en.wikipedia.org/wiki/Reactive_programming) programming model that eliminates messy event handling code, so you can focus on the code that really matters.
 * Develop and redistribute your own Shiny widgets that other developers can easily drop into their own applications (coming soon!).
@@ -39,8 +43,6 @@ devtools::install_github("rstudio/shiny")
 
 To learn more we highly recommend you check out the [Shiny Tutorial](http://shiny.rstudio.com/tutorial/). The tutorial explains the framework in-depth, walks you through building a simple application, and includes extensive annotated examples.
 
-We hope you enjoy using Shiny. If you have general questions about using Shiny, please use the Shiny [mailing list](https://groups.google.com/forum/#!forum/shiny-discuss). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
-
 ## Bootstrap 3 migration
 
 Shiny versions 0.10.2.2 and below used the Bootstrap 2 web framework. After 0.10.2.2, Shiny switched to Bootstrap 3. For most users, the upgrade should be seamless. However, if you have have customized your HTML-generating code to use features specific to Bootstrap 2, you may need to update your code to work with Bootstrap 3.
@@ -57,6 +59,10 @@ devtools::install_version("shiny", version = "0.10.2.2")
 
 The Javascript code in Shiny is minified using tools that run on Node.js. See the tools/ directory for more information.
 
+## Guidelines for contributing
+
+We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.md](CONTRIBUTING.md) file for detailed guidelines of how to contribute.
+
 ## License
 
 The shiny package is licensed under the GPLv3. See these files in the inst directory for additional details:

TODO-promises.md

@@ -0,0 +1,54 @@
+# Promises TODO
+
+## Documentation
+
+- [x] Motivation -- why should I care about async? Why shouldn't I (what are the limitations)?
+- [x] High level technical overview
+- [ ] Cookbook-style examples
+- [ ] Top-down porting of a sync app to async
+
+## Core API
+- [x] Should as.promise() convert regular values to promises? Or throw?
+  - [x] If as.promise() doesn't convert regular values to promises, add promise_resolved(value) and promise_rejected(err) functions?
+
+## later
+- [ ] Add support for multiple event loops
+- [x] Add timeout to run_now
+
+## Error handling/debugging
+- [ ] ..stacktraceon../..stacktraceoff.. and stack traces in general
+- [x] long stack traces
+  - [x] require opt-in
+- [ ] options(shiny.error) should work in promise handlers
+- [x] Detect when reactives are used across process boundaries, and error
+
+## Render functions
+- [x] Non-async render functions should have their code all execute on the current tick. Otherwise order of execution will be surprising if they have side effects and explicit priorities.
+- [x] Promise domains should maybe have an onExecute, for the "sync" part that kicks off async operations to also have wrapping behavior (like capturing output). Right now, I have to start off renderPrint with promise(~resolve(TRUE)) and then execute the user code in a then(), just to get the promise behavior. Same will be true when we tackle error handling (stack trace capture).
+- [x] invisible() doesn't seem to be working correctly with renderPrint. .visible doesn't survive promise chaining, e.g. promise(~resolve(promise(~resolve(invisible("Hi"))))) %>% then(function(x, .visible) { cat(.visible) }) will print TRUE, not FALSE.
+- [x] renderDataTable should support async
+- [x] Support downloadHandler
+  - [ ] Support async filename?
+  - [x] Should prevent session from continuing until download completes (ref count)
+
+## Flush lifecycle
+- [x] While async operations are running in a session, hold off on any further processing of inputs and scheduled task items until all operations are complete.
+- [x] Hold all outputs/errors until async operations are complete.
+- [ ] Allow both sync and async outputs to be displayed before all outputs are done. (opt-in)
+
+## Testing
+- [x] App that tests that all built-in render functions support async
+- [x] Apps that test flush lifecycle, including onFlushed(once = FALSE)
+- [x] Apps that test invisible() behavior for renderPrint, both sync and async
+- [x] Apps that ensure all render functions execute synchronous code before tick is over
+- [x] App that tests async downloadHandler
+- [x] App that verifies inputs/timers don't fire for a session while it has async operations pending
+- [x] App that verifies req(FALSE), req(FALSE, cancelOutput = TRUE), validate/need, etc. all work in async
+
+## External packages
+- [x] DT
+- [x] htmlwidgets: Don't require async-aware version of Shiny if not using async
+- [x] Plotly
+
+## Bugs
+- [x] req(FALSE, cancelOutput = TRUE) shows grey (even without async)

appveyor.yml

@@ -0,0 +1,49 @@
+# 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
+
+environment:
+  global:
+    USE_RTOOLS: true

cran-comments.md

@@ -1,10 +0,0 @@
-This is a resubmission of shiny 0.11 with updated license information.
-
-As per our communication, all copyright holders listed in the sources are listed as "cph" in Authors@R. Where the copyright holders are natural persons, they are also listed as "ctb". Where the copyright holders are not natural persons, I have taken the following approach:
-
-* jQuery: The copyright holders are "jQuery Foundation and other contributors". I have listed "jQuery Foundation" as "cph", and "jQuery contributors" as "ctb" and "cph". The jQuery contributors are listed in inst/www/shared/jquery-AUTHORS.txt, and this file is mentioned in the comment.
-* jQuery UI: The jQuery UI library is also created by the jQuery foundation, but is a separate project. The copyright holders are "jQuery Foundation and other contributors". I have listed "jQuery Foundation" as "cph" (for jQuery as well as jQuery UI), and "jQuery contributors" as "ctb" and "cph". The jQuery UI contributors are listed in inst/www/shared/jqueryui/1.10.4/AUTHORS.txt, and this file is mentioned in the comment.
-* Bootstrap: The copyright holder is Twitter, Inc. I have listed "Twitter, Inc", as "cph", and "Bootstrap contributors" as "ctb". The Bootstrap project page also names two creators of the project, and so I have listed them as "ctb". (According to Bootstrap's commit history, there are hundreds of others who have contributed to Bootstrap, so I have not listed them each individually.)
-* es5-shim: The copyright holders are "Kristopher Michael Kowal and contributors". I have listed "Kristopher Michael Kowal" as "ctb" and "cph", and "es5-shim contributors" as "ctb" and "cph". (According to es5-shim's CONTRIBUTORS.md file, there are dozens of others who have contributed to es5-shim, so I have not listed them each individually.)
-* DataTables: The copyright holder is "SpryMedia Limited". Because no natural person is listed in the documentation for DataTables, I have "SpryMedia Limited" as "ctb" and "cph".
-* R: An implentation of tar() is taken from the R sources. I've listed the "R Core Team" as "ctb" and "cph".

data-raw/fa_version.txt

@@ -0,0 +1 @@
+5.4.1

inst/examples/01_hello/Readme.md

@@ -1,4 +1,3 @@
-This small Shiny application demonstrates Shiny's automatic UI updates. Move
-the *Number of bins* slider and notice how the `renderPlot` expression is
-automatically re-evaluated when its dependant, `input$bins`, changes,
-causing a histogram with a new number of bins to be rendered.
+This small Shiny application demonstrates Shiny's automatic UI updates. 
+
+Move the *Number of bins* slider and notice how the `renderPlot` expression is automatically re-evaluated when its dependant, `input$bins`, changes, causing a histogram with a new number of bins to be rendered.

inst/examples/01_hello/app.R

@@ -0,0 +1,59 @@
+library(shiny)
+
+# Define UI for app that draws a histogram ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Hello Shiny!"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Slider for the number of bins ----
+      sliderInput(inputId = "bins",
+                  label = "Number of bins:",
+                  min = 1,
+                  max = 50,
+                  value = 30)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Histogram ----
+      plotOutput(outputId = "distPlot")
+
+    )
+  )
+)
+
+# Define server logic required to draw a histogram ----
+server <- function(input, output) {
+
+  # Histogram of the Old Faithful Geyser Data ----
+  # with requested number of bins
+  # This expression that generates a histogram is wrapped in a call
+  # to renderPlot to indicate that:
+  #
+  # 1. It is "reactive" and therefore should be automatically
+  #    re-executed when inputs (input$bins) change
+  # 2. Its output type is a plot
+  output$distPlot <- renderPlot({
+
+    x    <- faithful$waiting
+    bins <- seq(min(x), max(x), length.out = input$bins + 1)
+
+    hist(x, breaks = bins, col = "#75AADB", border = "white",
+         xlab = "Waiting time to next eruption (in mins)",
+         main = "Histogram of waiting times")
+
+    })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = ui, server = server)

inst/examples/01_hello/server.R

@@ -1,21 +0,0 @@
-library(shiny)
-
-# Define server logic required to draw a histogram
-shinyServer(function(input, output) {
-
-  # Expression that generates a histogram. The expression is
-  # wrapped in a call to renderPlot to indicate that:
-  #
-  #  1) It is "reactive" and therefore should be automatically
-  #     re-executed when inputs change
-  #  2) Its output type is a plot
-
-  output$distPlot <- renderPlot({
-    x    <- faithful[, 2]  # Old Faithful Geyser data
-    bins <- seq(min(x), max(x), length.out = input$bins + 1)
-
-    # draw the histogram with the specified number of bins
-    hist(x, breaks = bins, col = 'darkgray', border = 'white')
-  })
-
-})

inst/examples/01_hello/ui.R

@@ -1,24 +0,0 @@
-library(shiny)
-
-# Define UI for application that draws a histogram
-shinyUI(fluidPage(
-
-  # Application title
-  titlePanel("Hello Shiny!"),
-
-  # Sidebar with a slider input for the number of bins
-  sidebarLayout(
-    sidebarPanel(
-      sliderInput("bins",
-                  "Number of bins:",
-                  min = 1,
-                  max = 50,
-                  value = 30)
-    ),
-
-    # Show a plot of the generated distribution
-    mainPanel(
-      plotOutput("distPlot")
-    )
-  )
-))

inst/examples/02_text/Readme.md

@@ -1 +1 @@
-This example demonstrates output of raw text from R using the `renderPrint` function in `server.R` and the `verbatimTextOutput` function in `ui.R`. In this case, a textual summary of the data is shown using R's built-in `summary` function. 
+This example demonstrates output of raw text from R using the `renderPrint` function in `server` and the `verbatimTextOutput` function in `ui`. In this case, a textual summary of the data is shown using R's built-in `summary` function. 

inst/examples/02_text/app.R

@@ -0,0 +1,64 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Shiny Text"),
+
+  # Sidebar layout with a input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Selector for choosing dataset ----
+      selectInput(inputId = "dataset",
+                  label = "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Numeric entry for number of obs to view ----
+      numericInput(inputId = "obs",
+                   label = "Number of observations to view:",
+                   value = 10)
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Verbatim text for data summary ----
+      verbatimTextOutput("summary"),
+
+      # Output: HTML table with requested number of observations ----
+      tableOutput("view")
+
+    )
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Generate a summary of the dataset ----
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = ui, server = server)

inst/examples/02_text/server.R

@@ -1,26 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the selected
-# dataset
-shinyServer(function(input, output) {
-  
-  # Return the requested dataset
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  # Generate a summary of the dataset
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-  
-  # Show the first "n" observations
-  output$view <- renderTable({
-    head(datasetInput(), n = input$obs)
-  })
-})

inst/examples/02_text/ui.R

@@ -1,27 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-shinyUI(fluidPage(
-  
-  # Application title
-  titlePanel("Shiny Text"),
-  
-  # Sidebar with controls to select a dataset and specify the
-  # number of observations to view
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      
-      numericInput("obs", "Number of observations to view:", 10)
-    ),
-    
-    # Show a summary of the dataset and an HTML table with the 
-	 # requested number of observations
-    mainPanel(
-      verbatimTextOutput("summary"),
-      
-      tableOutput("view")
-    )
-  )
-))

inst/examples/03_reactivity/Readme.md

@@ -1,5 +1,5 @@
-This example demonstrates a core feature of Shiny: **reactivity**. In `server.R`, a reactive called `datasetInput` is declared. 
+This example demonstrates a core feature of Shiny: **reactivity**. In the `server` function, a reactive called `datasetInput` is declared. 
 
-Notice that the reactive expression depends on the input expression `input$dataset`, and that it's used by both the output expression `output$summary` and `output$view`. Try changing the dataset (using *Choose a dataset*) while looking at the reactive and then at the outputs; you will see first the reactive and then its dependencies flash. 
+Notice that the reactive expression depends on the input expression `input$dataset`, and that it's used by two output expressions: `output$summary` and `output$view`. Try changing the dataset (using *Choose a dataset*) while looking at the reactive and then at the outputs; you will see first the reactive and then its dependencies flash. 
 
 Notice also that the reactive expression doesn't just update whenever anything changes--only the inputs it depends on will trigger an update. Change the "Caption" field and notice how only the `output$caption` expression is re-evaluated; the reactive and its dependents are left alone.

inst/examples/03_reactivity/app.R

@@ -0,0 +1,102 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Reactivity"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Text for providing a caption ----
+      # Note: Changes made to the caption in the textInput control
+      # are updated in the output area immediately as you type
+      textInput(inputId = "caption",
+                label = "Caption:",
+                value = "Data Summary"),
+
+      # Input: Selector for choosing dataset ----
+      selectInput(inputId = "dataset",
+                  label = "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Numeric entry for number of obs to view ----
+      numericInput(inputId = "obs",
+                   label = "Number of observations to view:",
+                   value = 10)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Formatted text for caption ----
+      h3(textOutput("caption", container = span)),
+
+      # Output: Verbatim text for data summary ----
+      verbatimTextOutput("summary"),
+
+      # Output: HTML table with requested number of observations ----
+      tableOutput("view")
+
+    )
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  # By declaring datasetInput as a reactive expression we ensure
+  # that:
+  #
+  # 1. It is only called when the inputs it depends on changes
+  # 2. The computation and result are shared by all the callers,
+  #    i.e. it only executes a single time
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Create caption ----
+  # The output$caption is computed based on a reactive expression
+  # that returns input$caption. When the user changes the
+  # "caption" field:
+  #
+  # 1. This function is automatically called to recompute the output
+  # 2. New caption is pushed back to the browser for re-display
+  #
+  # Note that because the data-oriented reactive expressions
+  # below don't depend on input$caption, those expressions are
+  # NOT called when input$caption changes
+  output$caption <- renderText({
+    input$caption
+  })
+
+  # Generate a summary of the dataset ----
+  # The output$summary depends on the datasetInput reactive
+  # expression, so will be re-executed whenever datasetInput is
+  # invalidated, i.e. whenever the input$dataset changes
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  # The output$view depends on both the databaseInput reactive
+  # expression and input$obs, so it will be re-executed whenever
+  # input$dataset or input$obs is changed
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/03_reactivity/server.R

@@ -1,53 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the selected
-# dataset
-shinyServer(function(input, output) {
-
-  # By declaring datasetInput as a reactive expression we ensure 
-  # that:
-  #
-  #  1) It is only called when the inputs it depends on changes
-  #  2) The computation and result are shared by all the callers 
-  #	  (it only executes a single time)
-  #
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  # The output$caption is computed based on a reactive expression
-  # that returns input$caption. When the user changes the
-  # "caption" field:
-  #
-  #  1) This function is automatically called to recompute the 
-  #     output 
-  #  2) The new caption is pushed back to the browser for 
-  #     re-display
-  # 
-  # Note that because the data-oriented reactive expressions
-  # below don't depend on input$caption, those expressions are
-  # NOT called when input$caption changes.
-  output$caption <- renderText({
-    input$caption
-  })
-  
-  # The output$summary depends on the datasetInput reactive
-  # expression, so will be re-executed whenever datasetInput is
-  # invalidated
-  # (i.e. whenever the input$dataset changes)
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-  
-  # The output$view depends on both the databaseInput reactive
-  # expression and input$obs, so will be re-executed whenever
-  # input$dataset or input$obs is changed. 
-  output$view <- renderTable({
-    head(datasetInput(), n = input$obs)
-  })
-})

inst/examples/03_reactivity/ui.R

@@ -1,34 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-shinyUI(fluidPage(
-  
-  # Application title
-  titlePanel("Reactivity"),
-  
-  # Sidebar with controls to provide a caption, select a dataset,
-  # and specify the number of observations to view. Note that
-  # changes made to the caption in the textInput control are
-  # updated in the output area immediately as you type
-  sidebarLayout(
-    sidebarPanel(
-      textInput("caption", "Caption:", "Data Summary"),
-      
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      
-      numericInput("obs", "Number of observations to view:", 10)
-    ),
-    
-    
-    # Show the caption, a summary of the dataset and an HTML 
-	 # table with the requested number of observations
-    mainPanel(
-      h3(textOutput("caption", container = span)),
-      
-      verbatimTextOutput("summary"), 
-      
-      tableOutput("view")
-    )
-  )
-))

inst/examples/04_mpg/Readme.md

@@ -1,4 +1,4 @@
 This example demonstrates the following concepts:
 
-* **Global variables**: The `mpgData` variable is declared outside the `shinyServer` function. This makes it available anywhere inside `shinyServer`. The code in `server.R` outside `shinyServer` is only run once when the app starts up, so it can't contain user input.
-* **Reactive expressions**: `formulaText` is a reactive expression. Note how it re-evaluates when the Variable field is changed, but not when the Show Outliers box is ticked. 
+- **Global variables**: The `mpgData` variable is declared outside of the `ui` and `server` function definitions. This makes it available anywhere inside `app.R`. The code in `app.R` outside of `ui` and `server` function definitions is only run once when the app starts up, so it can't contain user input.
+- **Reactive expressions**: `formulaText` is a reactive expression. Note how it re-evaluates when the Variable field is changed, but not when the Show Outliers box is unchecked. 

inst/examples/04_mpg/app.R

@@ -0,0 +1,75 @@
+library(shiny)
+library(datasets)
+
+# Data pre-processing ----
+# Tweak the "am" variable to have nicer factor labels -- since this
+# doesn't rely on any user inputs, we can do this once at startup
+# and then use the value throughout the lifetime of the app
+mpgData <- mtcars
+mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
+
+
+# Define UI for miles per gallon app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Miles Per Gallon"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Selector for variable to plot against mpg ----
+      selectInput("variable", "Variable:",
+                  c("Cylinders" = "cyl",
+                    "Transmission" = "am",
+                    "Gears" = "gear")),
+
+      # Input: Checkbox for whether outliers should be included ----
+      checkboxInput("outliers", "Show outliers", TRUE)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Formatted text for caption ----
+      h3(textOutput("caption")),
+
+      # Output: Plot of the requested variable against mpg ----
+      plotOutput("mpgPlot")
+
+    )
+  )
+)
+
+# Define server logic to plot various variables against mpg ----
+server <- function(input, output) {
+
+  # Compute the formula text ----
+  # This is in a reactive expression since it is shared by the
+  # output$caption and output$mpgPlot functions
+  formulaText <- reactive({
+    paste("mpg ~", input$variable)
+  })
+
+  # Return the formula text for printing as a caption ----
+  output$caption <- renderText({
+    formulaText()
+  })
+
+  # Generate a plot of the requested variable against mpg ----
+  # and only exclude outliers if requested
+  output$mpgPlot <- renderPlot({
+    boxplot(as.formula(formulaText()),
+            data = mpgData,
+            outline = input$outliers,
+            col = "#75AADB", pch = 19)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/04_mpg/server.R

@@ -1,34 +0,0 @@
-library(shiny)
-library(datasets)
-
-# We tweak the "am" field to have nicer factor labels. Since
-# this doesn't rely on any user inputs we can do this once at
-# startup and then use the value throughout the lifetime of the
-# application
-mpgData <- mtcars
-mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
-
-
-# Define server logic required to plot various variables against
-# mpg
-shinyServer(function(input, output) {
-  
-  # Compute the forumla text in a reactive expression since it is
-  # shared by the output$caption and output$mpgPlot functions
-  formulaText <- reactive({
-    paste("mpg ~", input$variable)
-  })
-   
-  # Return the formula text for printing as a caption
-  output$caption <- renderText({
-    formulaText()
-  })
-  
-  # Generate a plot of the requested variable against mpg and
-  # only include outliers if requested
-  output$mpgPlot <- renderPlot({
-    boxplot(as.formula(formulaText()), 
-            data = mpgData,
-            outline = input$outliers)
-  })
-})