simplify buildMask()

Add shiny::markdown() for inline Markdown

.Rbuildignore

@@ -18,3 +18,6 @@
 ^.*\.o$
 ^appveyor\.yml$
 ^revdep$
+^TODO-promises.md$
+^manualtests$
+^\.github$

.github/CONTRIBUTING.md

@@ -0,0 +1,40 @@
+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. Submit a [pull request](https://help.github.com/articles/using-pull-requests).
+
+3. Ensure that you have signed the contributor license agreement. It will appear as a "Check"
+   on your PR and a comment from "CLAassistant" will also appear explaining whether you have
+   yet to sign. After you sign, you can click the "Recheck" link in that comment and the check
+   will flip to reflect that you've signed.
+
+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.

.github/ISSUE_TEMPLATE/bug_report.md

@@ -0,0 +1,40 @@
+---
+name  : Bug report
+about : Report a bug in Shiny.
+---
+
+<!--
+This issue tracker is for bugs and feature requests in the Shiny package. If you're having trouble with Shiny Server or a related package, please file an issue in the appropriate repository. 
+
+If you're having trouble with shinyapps.io, and you have a paid account (Starter, Basic, Standard, or Pro), please file a support ticket via https://support.rstudio.com. If you have a Free account, please post to the RStudio Community with the shinyappsio tag: https://community.rstudio.com/tags/shinyappsio.
+
+Finally, if you are an RStudio customer and are having trouble with one of our Pro products, get in touch with our support team at support@rstudio.com.
+
+Before you file an issue, please upgrade to the latest version of Shiny from CRAN and confirm that the problem persists.
+
+# First, restart R.
+# To install latest shiny from CRAN:
+install.packages("shiny")
+
+See our guide to writing good bug reports for further guidance: https://github.com/rstudio/shiny/wiki/Writing-Good-Bug-Reports. The better your report is, the likelier we are to be able to reproduce and ultimately solve it.
+-->
+
+### System details
+
+Browser Version: <!-- If applicable -->
+
+Output of `sessionInfo()`:
+
+```
+# sessionInfo() output goes here
+```
+
+### Example application *or* steps to reproduce the problem
+
+<!-- If you're able to create one, a reproducible example is extremely helpful to us. For instructions on how to create one, please see: https://github.com/rstudio/shiny/wiki/Creating-a-Reproducible-Example --> 
+
+```R
+# Minimal, self-contained example app code goes here
+```
+
+### Describe the problem in detail

.github/ISSUE_TEMPLATE/feature_request.md

@@ -0,0 +1,17 @@
+---
+name  : Feature request
+about : Request a new feature.
+---
+
+<!--
+
+Thanks for taking the time to file a feature request! Please take the time to search for an existing feature request, to avoid creating duplicate requests. If you find an existing feature request, please give it a thumbs-up reaction, as we'll use these reactions to help prioritize the implementation of these features in the future.
+
+If the feature has not yet been filed, then please describe the feature you'd like to see become a part of Shiny. See:
+
+https://github.com/rstudio/shiny/wiki/Writing-Good-Feature-Requests
+
+for a guide on how to write good feature requests.
+
+-->
+

.github/ISSUE_TEMPLATE/question.md

@@ -0,0 +1,7 @@
+---
+name  : Ask a Question
+about : The issue tracker is not for questions -- please ask questions at https://community.rstudio.com/c/shiny.
+---
+
+The issue tracker is not for questions. If you have a question, please feel free to ask it on our community site, at https://community.rstudio.com/c/shiny.
+

.gitignore

@@ -9,3 +9,4 @@
 shinyapps/
 README.html
 .*.Rnb.cached
+tools/yarn-error.log

.travis.yml

@@ -1,17 +1,32 @@
 language: r
-r:
-  - oldrel
-  - release
-  - devel
+matrix:
+  include:
+    - name: "Roxygen check"
+      r: release
+      r_packages:
+        - devtools
+        - rprojroot
+      script: ./tools/documentation/checkDocsCurrent.sh
+      env:
+        # GITHUB_PAT for gh::gh calls
+        - secure: "Hk4piVNtDobLT1dQPnCOcM7sOlwNGJOU5cpvbRvOxYSgxP+Bj2MyRZMe825rdHkHbFez0h8w3tJOBf9DDBH7PC1BhhNll2+WM/WxGlkNleg8vsoH/Xopffl+2YgtWbAYZjQ2j0QYdgNn0e/TY86/ggk9qit6+gpsZ7z/HmWQuVY="
+
+    - name: "Javascript check"
+      language: node_js
+      cache: yarn
+      script: ./tools/checkJSCurrent.sh
+      node_js:
+        - "12"
+    - r: 3.2
+    - r: 3.3
+    - r: 3.4
+    - r: 3.5
+    - r: release
+    - r: devel
+
 sudo: false
 cache: packages
-
 notifications:
   email:
     on_success: change
     on_failure: change
-
-# Set CXX1X for R-devel, as R-devel does not detect CXX1X support for gcc 4.6.3.
-# This was causing dependency sourcetools to fail.
-before_install:
-  - if [[ "$TRAVIS_R_VERSION_STRING" = 'devel' ]]; then mkdir ~/.R && echo 'CXX1X=g++ -std=c++0x -g -O2 -fPIC' > ~/.R/Makevars; fi

CONTRIBUTING.md

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

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.14
+Version: 1.4.0.9002
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -14,7 +14,7 @@ Authors@R: c(
     person(family = "jQuery contributors", role = c("ctb", "cph"),
     comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
     person(family = "jQuery UI contributors", role = c("ctb", "cph"),
-    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/1.10.4/AUTHORS.txt"),
+    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
     person("Mark", "Otto", role = "ctb",
     comment = "Bootstrap library"),
     person("Jacob", "Thornton", role = "ctb",
@@ -56,30 +56,48 @@ Authors@R: c(
     )
 Description: Makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
-    outputs and extensive pre-built widgets make it possible to build
+    outputs and extensive prebuilt widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
 License: GPL-3 | file LICENSE
 Depends:
-    R (>= 3.0.0),
+    R (>= 3.0.2),
     methods
 Imports:
     utils,
-    httpuv (>= 1.3.3),
+    grDevices,
+    httpuv (>= 1.5.2),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.3.5),
+    htmltools (>= 0.4.0.9001),
     R6 (>= 2.0),
-    sourcetools
+    sourcetools,
+    later (>= 1.0.0),
+    promises (>= 1.1.0),
+    tools,
+    crayon,
+    rlang (>= 0.4.0),
+    fastmap (>= 1.0.0),
+    withr,
+    commonmark (>= 1.7),
+    glue (>= 1.3.2)
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
-    testthat,
+    testthat (>= 2.1.1),
     knitr (>= 1.6),
     markdown,
     rmarkdown,
-    ggplot2
+    ggplot2,
+    reactlog (>= 1.0.0),
+    magrittr,
+    shinytest,
+    yaml,
+    future,
+    dygraphs
+Remotes:
+    rstudio/htmltools
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
@@ -87,16 +105,24 @@ Collate:
     'bookmark-state-local.R'
     'stack.R'
     'bookmark-state.R'
+    'bootstrap-deprecated.R'
     'bootstrap-layout.R'
+    'globals.R'
     'conditions.R'
     'map.R'
-    'globals.R'
     'utils.R'
     'bootstrap.R'
-    'cache.R'
+    'cache-context.R'
+    'cache-disk.R'
+    'cache-memory.R'
+    'cache-utils.R'
     'diagnose.R'
     'fileupload.R'
+    'font-awesome.R'
     'graph.R'
+    'reactives.R'
+    'reactive-domains.R'
+    'history.R'
     'hooks.R'
     'html-deps.R'
     'htmltools.R'
@@ -118,18 +144,21 @@ Collate:
     'input-text.R'
     'input-textarea.R'
     'input-utils.R'
+    'insert-tab.R'
     'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
     'middleware.R'
+    'timer.R'
+    'mock-session.R'
     'modal.R'
     'modules.R'
     'notifications.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
-    'reactive-domains.R'
-    'reactives.R'
+    'reexports.R'
+    'render-cached-plot.R'
     'render-plot.R'
     'render-table.R'
     'run-url.R'
@@ -141,7 +170,12 @@ Collate:
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
+    'snapshot.R'
     'tar.R'
-    'timer.R'
+    'test-export.R'
+    'test-server.R'
+    'test.R'
     'update-input.R'
-RoxygenNote: 5.0.1
+RoxygenNote: 7.1.0
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)

LICENSE

@@ -12,7 +12,7 @@ these components are included below):
 - Respond.js, https://github.com/scottjehl/Respond
 - bootstrap-datepicker, https://github.com/eternicode/bootstrap-datepicker
 - Font Awesome, https://github.com/FortAwesome/Font-Awesome
-- selectize.js, https://github.com/brianreavis/selectize.js
+- selectize.js, https://github.com/selectize/selectize.js
 - es5-shim, https://github.com/es-shims/es5-shim
 - ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
 - strftime for Javascript, https://github.com/samsonjs/strftime
@@ -25,7 +25,7 @@ these components are included below):
 jQuery license and license for included components from jQuery UI
 ----------------------------------------------------------------------
 
-Copyright jQuery Foundation and other contributors, https://jquery.org/
+Copyright JS Foundation and other contributors, https://js.foundation/
 
 Permission is hereby granted, free of charge, to any person obtaining
 a copy of this software and associated documentation files (the
@@ -51,7 +51,7 @@ Bootstrap License
 ----------------------------------------------------------------------
 The MIT License (MIT)
 
-Copyright (c) 2011-2014 Twitter, Inc
+Copyright (c) 2011-2019 Twitter, Inc.
 
 Permission is hereby granted, free of charge, to any person obtaining a copy
 of this software and associated documentation files (the "Software"), to deal
@@ -673,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)
@@ -795,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
 ----------------------------------------------------------------------

NAMESPACE

@@ -1,15 +1,18 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("$",mockclientdata)
 S3method("$",reactivevalues)
 S3method("$",session_proxy)
 S3method("$",shinyoutput)
 S3method("$<-",reactivevalues)
 S3method("$<-",session_proxy)
 S3method("$<-",shinyoutput)
+S3method("[",mockclientdata)
 S3method("[",reactivevalues)
 S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
 S3method("[<-",shinyoutput)
+S3method("[[",mockclientdata)
 S3method("[[",reactivevalues)
 S3method("[[",session_proxy)
 S3method("[[",shinyoutput)
@@ -22,14 +25,19 @@ S3method(as.shiny.appobj,list)
 S3method(as.shiny.appobj,shiny.appobj)
 S3method(as.tags,shiny.appobj)
 S3method(as.tags,shiny.render.function)
+S3method(format,reactiveExpr)
+S3method(format,reactiveVal)
 S3method(names,reactivevalues)
 S3method(print,reactive)
+S3method(print,reactivevalues)
 S3method(print,shiny.appobj)
+S3method(print,shiny.render.function)
 S3method(str,reactivevalues)
 export("conditionStackTrace<-")
 export(..stacktraceoff..)
 export(..stacktraceon..)
 export(HTML)
+export(MockShinySession)
 export(NS)
 export(Progress)
 export(a)
@@ -38,6 +46,7 @@ export(actionButton)
 export(actionLink)
 export(addResourcePath)
 export(animationOptions)
+export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
 export(bookmarkButton)
@@ -56,12 +65,15 @@ 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)
@@ -69,6 +81,7 @@ export(downloadLink)
 export(em)
 export(enableBookmarking)
 export(eventReactive)
+export(exportTestValues)
 export(exprToFunction)
 export(extractStackTrace)
 export(fileInput)
@@ -82,9 +95,13 @@ 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)
@@ -93,6 +110,7 @@ export(h5)
 export(h6)
 export(headerPanel)
 export(helpText)
+export(hideTab)
 export(hoverOpts)
 export(hr)
 export(htmlOutput)
@@ -107,27 +125,29 @@ 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(knit_print.html)
-export(knit_print.reactive)
-export(knit_print.shiny.appobj)
-export(knit_print.shiny.render.function)
-export(knit_print.shiny.tag)
-export(knit_print.shiny.tag.list)
+export(key_missing)
+export(loadSupport)
 export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
+export(markdown)
 export(maskReactiveContext)
+export(memoryCache)
 export(modalButton)
 export(modalDialog)
+export(moduleServer)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
@@ -145,6 +165,7 @@ export(onReactiveDomainEnded)
 export(onRestore)
 export(onRestored)
 export(onSessionEnded)
+export(onStop)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -154,6 +175,7 @@ export(passwordInput)
 export(plotOutput)
 export(plotPNG)
 export(pre)
+export(prependTab)
 export(printError)
 export(printStackTrace)
 export(radioButtons)
@@ -166,13 +188,20 @@ export(reactiveTable)
 export(reactiveText)
 export(reactiveTimer)
 export(reactiveUI)
+export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
+export(reactlog)
+export(reactlogReset)
+export(reactlogShow)
 export(registerInputHandler)
 export(removeInputHandler)
 export(removeModal)
 export(removeNotification)
+export(removeResourcePath)
+export(removeTab)
 export(removeUI)
+export(renderCachedPlot)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -182,12 +211,14 @@ export(renderText)
 export(renderUI)
 export(repeatable)
 export(req)
+export(resourcePaths)
 export(restoreInput)
 export(runApp)
 export(runExample)
 export(runGadget)
 export(runGist)
 export(runGitHub)
+export(runTests)
 export(runUrl)
 export(safeError)
 export(selectInput)
@@ -195,6 +226,7 @@ export(selectizeInput)
 export(serverInfo)
 export(setBookmarkExclude)
 export(setProgress)
+export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
@@ -205,10 +237,15 @@ 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)
@@ -222,12 +259,16 @@ export(tag)
 export(tagAppendAttributes)
 export(tagAppendChild)
 export(tagAppendChildren)
+export(tagGetAttribute)
+export(tagHasAttribute)
 export(tagList)
 export(tagSetChildren)
 export(tags)
+export(testServer)
 export(textAreaInput)
 export(textInput)
 export(textOutput)
+export(throttle)
 export(titlePanel)
 export(uiOutput)
 export(updateActionButton)
@@ -246,9 +287,13 @@ 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)
@@ -264,3 +309,49 @@ import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
+importFrom(fastmap,fastmap)
+importFrom(fastmap,is.key_missing)
+importFrom(fastmap,key_missing)
+importFrom(grDevices,dev.cur)
+importFrom(grDevices,dev.set)
+importFrom(htmltools,HTML)
+importFrom(htmltools,a)
+importFrom(htmltools,br)
+importFrom(htmltools,code)
+importFrom(htmltools,div)
+importFrom(htmltools,em)
+importFrom(htmltools,h1)
+importFrom(htmltools,h2)
+importFrom(htmltools,h3)
+importFrom(htmltools,h4)
+importFrom(htmltools,h5)
+importFrom(htmltools,h6)
+importFrom(htmltools,hr)
+importFrom(htmltools,htmlTemplate)
+importFrom(htmltools,img)
+importFrom(htmltools,includeCSS)
+importFrom(htmltools,includeHTML)
+importFrom(htmltools,includeMarkdown)
+importFrom(htmltools,includeScript)
+importFrom(htmltools,includeText)
+importFrom(htmltools,is.singleton)
+importFrom(htmltools,p)
+importFrom(htmltools,pre)
+importFrom(htmltools,singleton)
+importFrom(htmltools,span)
+importFrom(htmltools,strong)
+importFrom(htmltools,suppressDependencies)
+importFrom(htmltools,tag)
+importFrom(htmltools,tagAppendAttributes)
+importFrom(htmltools,tagAppendChild)
+importFrom(htmltools,tagAppendChildren)
+importFrom(htmltools,tagGetAttribute)
+importFrom(htmltools,tagHasAttribute)
+importFrom(htmltools,tagList)
+importFrom(htmltools,tagSetChildren)
+importFrom(htmltools,tags)
+importFrom(htmltools,validateCssUnit)
+importFrom(htmltools,withTags)
+importFrom(promises,"%...!%")
+importFrom(promises,"%...>%")
+importFrom(rlang,env_clone)

NEWS.md

@@ -1,5 +1,617 @@
+shiny 1.4.0.9001
+===========
+
+## Full changelog
+
+### Breaking changes
+
+### New features
+
+* `runTests()` is a new function that behaves much like R CMD check. `runTests()` invokes all of the top-level R files in the tests/ directory inside an application, in that application's environment. ([#2585](https://github.com/rstudio/shiny/pull/2585))
+
+* `testServer()` and `testModule()` are two new functions for testing reactive behavior inside server functions and modules, respectively. ([#2682](https://github.com/rstudio/shiny/pull/2682), [#2764](https://github.com/rstudio/shiny/pull/2764))
+
+* The new `moduleServer` function provides a simpler interface for creating and using modules. ([#2773](https://github.com/rstudio/shiny/pull/2773))
+
+* Resolved [#2732](https://github.com/rstudio/shiny/issues/2732): `markdown()` is a new function for writing Markdown with Github extensions directly in Shiny UIs. Markdown rendering is performed by the [commonmark](https://github.com/jeroen/commonmark) package. ([#2737](https://github.com/rstudio/shiny/pull/2737))
+
+### Minor new features and improvements
+
+* Fixed [#2042](https://github.com/rstudio/shiny/issues/2042), [#2628](https://github.com/rstudio/shiny/issues/2628): In a `dateInput` and `dateRangeInput`, disabled months and years are now a lighter gray, to make it easier to see that they are disabled. ([#2690](https://github.com/rstudio/shiny/pull/2690))
+
+* `getCurrentOutputInfo()` previously threw an error when called from outside of an output; now it returns `NULL`. ([#2707](https://github.com/rstudio/shiny/pull/2707))
+
+* Added a label to observer that auto-reloads `R/` directory to avoid confusion when using `reactlog`. ([#58](https://github.com/rstudio/reactlog/issues/58))
+
+* `getDefaultReactiveDomain()` can now be called inside a `session$onSessionEnded` callback and will return the calling `session` information. ([#2757](https://github.com/rstudio/shiny/pull/2757))
+
+* Added a `'function'` class to `reactive()` and `reactiveVal()` objects. ([#2793](https://github.com/rstudio/shiny/pull/2793))
+
+### Bug fixes
+
+* Fixed [#2606](https://github.com/rstudio/shiny/issues/2606): `debounce()` would not work properly if the code in the reactive expression threw an error on the first run. ([#2652](https://github.com/rstudio/shiny/pull/2652))
+
+* Fixed [#2653](https://github.com/rstudio/shiny/issues/2653): The `dataTableOutput()` could have incorrect output if certain characters were in the column names. ([#2658](https://github.com/rstudio/shiny/pull/2658))
+
+### Documentation Updates
+
+
+shiny 1.4.0.2
+===========
+
+Minor patch release: fixed some timing-dependent tests failed intermittently on CRAN build machines.
+
+
+shiny 1.4.0.1
+===========
+
+Minor patch release to account for changes to the grid package that will be upcoming in the R 4.0 release ([#2776](https://github.com/rstudio/shiny/pull/2776)).
+
+
+shiny 1.4.0
+===========
+
+## Full changelog
+
+### Breaking changes
+
+* Resolved [#2554](https://github.com/rstudio/shiny/issues/2554): Upgraded jQuery from v.1.12.4 to v3.4.1 and bootstrap from v3.3.7 to v3.4.1. ([#2557](https://github.com/rstudio/shiny/pull/2557)). Since the jQuery upgrade may introduce breaking changes to user code, there is an option to switch back to the old version by setting `options(shiny.jquery.version = 1)`. If you've hard-coded `shared/jquery[.min].js` in the HTML of your Shiny app, in order to downgrade, you'll have to change that filepath to `shared/legacy/jquery[.min].js`.
+
+### Improvements
+
+* Resolved [#1433](https://github.com/rstudio/shiny/issues/1433): `plotOutput()`'s coordmap info now includes discrete axis limits for **ggplot2** plots. As a result, any **shinytest** tests that contain **ggplot2** plots with discrete axes (that were recorded before this change) will now report differences that can safely be updated. This new coordmap info was added to correctly infer what data points are within an input brush and/or near input click/hover in scenarios where a non-trivial discrete axis scale is involved (e.g., whenever `scale_[x/y]_discrete(limits = ...)` and/or free scales across multiple discrete axes are used). ([#2410](https://github.com/rstudio/shiny/pull/2410))
+
+* Resolved [#2402](https://github.com/rstudio/shiny/issues/2402): An informative warning is now thrown for mis-specified (date) strings in `dateInput()`, `updateDateInput()`, `dateRangeInput()`, and `updateDateRangeInput()`. ([#2403](https://github.com/rstudio/shiny/pull/2403))
+
+* If the `shiny.autoload.r` option is set to `TRUE`, all files ending in `.r` or `.R` contained in a directory named `R/` adjacent to your application are sourced when your app is started. This will become the default Shiny behavior in a future release ([#2547](https://github.com/rstudio/shiny/pull/2547))
+
+* Resolved [#2442](https://github.com/rstudio/shiny/issues/2442): The `shiny:inputchanged` JavaScript event now triggers on the related input element instead of `document`. Existing event listeners bound to `document` will still detect the event due to event bubbling. ([#2446](https://github.com/rstudio/shiny/pull/2446))
+
+* Fixed [#1393](https://github.com/rstudio/shiny/issues/1393), [#2223](https://github.com/rstudio/shiny/issues/2223): For plots with any interactions enabled, the image is no longer draggable. ([#2460](https://github.com/rstudio/shiny/pull/2460))
+
+* Resolved [#2469](https://github.com/rstudio/shiny/issues/2469): `renderText` now takes a `sep` argument that is passed to `cat`. ([#2497](https://github.com/rstudio/shiny/pull/2497))
+
+* Added `resourcePaths()` and `removeResourcePaths()` functions. ([#2459](https://github.com/rstudio/shiny/pull/2459))
+
+* Resolved [#2433](https://github.com/rstudio/shiny/issues/2433): An informative warning is now thrown if subdirectories of the app's `www/` directory are masked by other resource prefixes and/or the same resource prefix is mapped to different local file paths. ([#2434](https://github.com/rstudio/shiny/pull/2434))
+
+* Resolved [#2478](https://github.com/rstudio/shiny/issues/2478): `cmd + shift + f3` and `ctrl + shift + f3` can now be used to add a reactlog mark. If reactlog keybindings are used and the reactlog is not enabled, an error page is displayed showing how to enable reactlog recordings. ([#2560](https://github.com/rstudio/shiny/pull/2560))
+
+### Bug fixes
+
+* Partially resolved [#2423](https://github.com/rstudio/shiny/issues/2423): Reactivity in Shiny leaked some memory, because R can leak memory whenever a new symbols is interned, which happens whenever a new name/key is used in an environment. R now uses the fastmap package, which avoids this problem. ([#2429](https://github.com/rstudio/shiny/pull/2429))
+
+* Fixed [#2267](https://github.com/rstudio/shiny/issues/2267): Fixed a memory leak with `invalidateLater`. ([#2555](https://github.com/rstudio/shiny/pull/2555))
+
+* Fixed [#1548](https://github.com/rstudio/shiny/issues/1548): The `reactivePoll` function leaked an observer; that is the observer would continue to exist even if the `reactivePoll` object was no longer accessible. [#2522](https://github.com/rstudio/shiny/pull/2522)
+
+* Fixed [#2116](https://github.com/rstudio/shiny/issues/2116): Fixed an issue where dynamic tabs could not be added when on a hosted platform. ([#2545](https://github.com/rstudio/shiny/pull/2545))
+
+* Resolved [#2515](https://github.com/rstudio/shiny/issues/2515): `selectInput()` and `selectizeInput()` now deal appropriately with named factors. Note that `updateSelectInput()` and `updateSelectizeInput()` **do not** yet handle factors; their behavior is unchanged. ([#2524](https://github.com/rstudio/shiny/pull/2524), [#2540](https://github.com/rstudio/shiny/pull/2540), [#2625](https://github.com/rstudio/shiny/pull/2625))
+
+* Resolved [#2471](https://github.com/rstudio/shiny/issues/2471): Large file uploads to a Windows computer were slow. ([#2579](https://github.com/rstudio/shiny/pull/2579))
+
+* Fixed [#2387](https://github.com/rstudio/shiny/issues/2387): Updating a `sliderInput()`'s type from numeric to date no longer changes the rate policy from debounced to immediate. More generally, updating an input binding with a new type should (no longer) incorrectly alter the input rate policy. ([#2404](https://github.com/rstudio/shiny/pull/2404))
+
+* Fixed [#868](https://github.com/rstudio/shiny/issues/868): If an input is initialized with a `NULL` label, it can now be updated with a string. Moreover, if an input label is initialized with a string, it can now be removed by updating with `label=character(0)` (similar to how `choices` and `selected` can be cleared in `updateSelectInput()`). ([#2406](https://github.com/rstudio/shiny/pull/2406))
+
+* Fixed [#2250](https://github.com/rstudio/shiny/issues/2250): `updateSliderInput()` now works with un-specified (or zero-length) `min`, `max`, and `value`. ([#2416](https://github.com/rstudio/shiny/pull/2416))
+
+* Fixed [#2396](https://github.com/rstudio/shiny/issues/2396): `selectInput("myID", ...)` resulting in an extra `myID-selectized` input (introduced in v1.2.0). ([#2418](https://github.com/rstudio/shiny/pull/2418))
+
+* Fixed [#2233](https://github.com/rstudio/shiny/issues/2233): `verbatimTextOutput()` produced wrapped text on Safari, but the text should not be wrapped. ([#2353](https://github.com/rstudio/shiny/pull/2353))
+
+* Fixed [#2335](https://github.com/rstudio/shiny/issues/2335): When `dateInput()`'s `value` was unspecified, and `max` and/or `min` was set to `Sys.Date()`, the value was not being set properly. ([#2526](https://github.com/rstudio/shiny/pull/2526))
+
+* Fixed [#2591](https://github.com/rstudio/shiny/issues/2591): Providing malformed date-strings to `min` or `max` no longer results in JS errors for `dateInput()` and `dateRangeInput()`. ([#2592](https://github.com/rstudio/shiny/pull/2592))
+
+* Fixed [rstudio/reactlog#36](https://github.com/rstudio/reactlog/issues/36): Changes to reactive values not displaying accurately in reactlog. ([#2424](https://github.com/rstudio/shiny/pull/2424))
+
+* Fixed [#2598](https://github.com/rstudio/shiny/issues/2598): Showcase files don't appear with a wide window. ([#2582](https://github.com/rstudio/shiny/pull/2582))
+
+* Fixed [#2329](https://github.com/rstudio/shiny/issues/2329), [#1817](https://github.com/rstudio/shiny/issues/1817): These bugs were reported as fixed in Shiny 1.3.0 but were not actually fixed because some JavaScript changes were accidentally not included in the release. The fix resolves issues that occur when `withProgressBar()` or bookmarking are combined with the [networkD3](https://christophergandrud.github.io/networkD3/) package's Sankey plot.
+
+
+shiny 1.3.2
+===========
+
+### Bug fixes
+
+* Fixed [#2385](https://github.com/rstudio/shiny/issues/2385): Static CSS/JS resources in subapps in R Markdown documents did not render properly. ([#2386](https://github.com/rstudio/shiny/pull/2386))
+
+* Fixed [#2280](https://github.com/rstudio/shiny/issues/2280): Shiny applications that used a www/index.html file did not serve up the index file. ([#2382](https://github.com/rstudio/shiny/pull/2382))
+
+
+shiny 1.3.1
+===========
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed a performance issue introduced in v1.3.0 when using large nested lists within Shiny. ([#2377](https://github.com/rstudio/shiny/pull/2377))
+
+
+shiny 1.3.0
+===========
+
+## Full changelog
+
+### Breaking changes
+
+### New features
+
+* Revamped Shiny's [reactlog](https://github.com/rstudio/reactlog) viewer which debugs reactivity within a shiny application.  This allows users to traverse the reactivity history of a shiny application, filter to the dependency tree of a selected reactive object, and search for matching reactive objects.  See `?reactlogShow` for more details and how to enable this feature. ([#2107](https://github.com/rstudio/shiny/pull/2107))
+
+* Shiny now serves static files on a background thread. This means that things like JavaScript and CSS assets can be served without blocking or being blocked by the main R thread, and should result in significantly better performance for heavily loaded servers. ([#2280](https://github.com/rstudio/shiny/pull/2280))
+
+### Minor new features and improvements
+
+* The `Shiny-Shared-Secret` security header is now checked using constant-time comparison to prevent timing attacks (thanks @dirkschumacher!). ([#2319](https://github.com/rstudio/shiny/pull/2319))
+
+### Bug fixes
+
+* Fixed [#2245](https://github.com/rstudio/shiny/issues/2245): `updateSelectizeInput()` did not update labels. ([#2248](https://github.com/rstudio/shiny/pull/2248))
+
+* Fixed [#2308](https://github.com/rstudio/shiny/issues/2308): When restoring a bookmarked application, inputs with a leading `.` would not be restored. ([#2311](https://github.com/rstudio/shiny/pull/2311))
+
+* Fixed [#2305](https://github.com/rstudio/shiny/issues/2305), [#2322](https://github.com/rstudio/shiny/issues/2322), [#2351](https://github.com/rstudio/shiny/issues/2351): When an input in dynamic UI is restored from bookmarks, it would keep getting set to the same value. ([#2360](https://github.com/rstudio/shiny/pull/2360))
+
+* Fixed [#2349](https://github.com/rstudio/shiny/issues/2349), [#2329](https://github.com/rstudio/shiny/issues/2329), [#1817](https://github.com/rstudio/shiny/issues/1817): These were various bugs triggered by the presence of the [networkD3](https://christophergandrud.github.io/networkD3/) package's Sankey plot in an app. Impacted features included `dateRangeInput`, `withProgressBar`, and bookmarking ([#2359](https://github.com/rstudio/shiny/pull/2359))
+
+### Documentation Updates
+
+* Fixed [#2247](https://github.com/rstudio/shiny/issues/2247): `renderCachedPlot` now supports using promises for either `expr` or `cacheKeyExpr`. (Shiny v1.2.0 supported async `expr`, but only if `cacheKeyExpr` was async as well; now you can use any combination of sync/async for `expr` and `cacheKeyExpr`.) [#2261](https://github.com/rstudio/shiny/pull/2261)
+
+
+shiny 1.2.0
+===========
+
+This release features plot caching, an important new tool for improving performance and scalability. Using `renderCachedPlot` in place of `renderPlot` can greatly improve responsiveness for apps that show the same plot many times (for example, a dashboard or report where all users view the same data). Shiny gives you a fair amount of control in where the cache is stored and how cached plots are invalidated, so be sure to read [this article](http://shiny.rstudio.com/articles/plot-caching.html) to get the most out of this feature.
+
+## Full changelog
+
+### Breaking changes
+
+* The URL paths for FontAwesome CSS/JS/font assets have changed, due to our upgrade from FontAwesome 4 to 5. This shouldn't affect you unless you're using `www/index.html` to provide your UI and have hardcoded the old FontAwesome paths into your HTML. If that's you, consider switching to [HTML templates](https://shiny.rstudio.com/articles/templates.html), which give you the syntax of raw HTML while still taking advantage of Shiny's automatic management of web dependencies.
+
+### New features
+
+* Added `renderCachedPlot()`, which stores plots in a cache so that they can be served up almost instantly. ([#1997](https://github.com/rstudio/shiny/pull/1997))
+
+### Minor new features and improvements
+
+* Upgrade FontAwesome from 4.7.0 to 5.3.1 and made `icon` tags browsable, which means they will display in a web browser or RStudio viewer by default ([#2186](https://github.com/rstudio/shiny/issues/2186)). Note that if your application or library depends on FontAwesome directly using custom CSS, you may need to make some or all of the changes recommended in [Upgrade from Version 4](https://fontawesome.com/how-to-use/on-the-web/setup/upgrading-from-version-4). Font Awesome icons can also now be used in static R Markdown documents.
+
+* Address [#174](https://github.com/rstudio/shiny/issues/174): Added `datesdisabled` and `daysofweekdisabled` as new parameters to `dateInput()`. This resolves [#174](https://github.com/rstudio/shiny/issues/174) and exposes the underlying arguments of [Bootstrap Datepicker](http://bootstrap-datepicker.readthedocs.io/en/latest/options.html#datesdisabled). `datesdisabled` expects a character vector with values in `yyyy/mm/dd` format and `daysofweekdisabled` expects an integer vector with day interger ids (Sunday=0, Saturday=6). The default value for both is `NULL`, which leaves all days selectable. Thanks, @nathancday! ([#2147](https://github.com/rstudio/shiny/pull/2147))
+
+* Support for selecting variables of a data frame with the output values to be used within tidy evaluation.  Added functions: `varSelectInput`, `varSelectizeInput`, `updateVarSelectInput`, `updateVarSelectizeInput`. ([#2091](https://github.com/rstudio/shiny/pull/2091))
+
+* Addressed [#2042](https://github.com/rstudio/shiny/issues/2042): dates outside of `min`/`max` date range are now a lighter shade of grey to highlight the allowed range. ([#2087](https://github.com/rstudio/shiny/pull/2087))
+
+* Added support for plot interaction when the plot is scaled. ([#2125](https://github.com/rstudio/shiny/pull/2125))
+
+* Fixed [#1933](https://github.com/rstudio/shiny/issues/1933): extended server-side selectize to lists and optgroups. ([#2102](https://github.com/rstudio/shiny/pull/2102))
+
+* Added namespace support when freezing reactiveValue keys. [#2080](https://github.com/rstudio/shiny/pull/2080)
+
+* Upgrade selectize.js from 0.12.1 to 0.12.4 [#2028](https://github.com/rstudio/shiny/issues/2028)
+
+* Addressed [#2079](https://github.com/rstudio/shiny/issues/2079): Added `coords_img`, `coords_css`, and `img_css_ratio` fields containing x and y location information for plot brush, hover, and click events. [#2183](https://github.com/rstudio/shiny/pull/2183)
+
+### Bug fixes
+
+* Fixed [#2033](https://github.com/rstudio/shiny/issues/2033): RStudio Viewer window not closed on `shiny::stopApp()`. Thanks, @vnijs! [#2047](https://github.com/rstudio/shiny/pull/2047)
+
+* Fixed [#1935](https://github.com/rstudio/shiny/issues/1935): correctly returns plot coordinates when using outer margins. ([#2108](https://github.com/rstudio/shiny/pull/2108))
+
+* Resolved [#2019](https://github.com/rstudio/shiny/issues/2019): `updateSliderInput` now changes the slider formatting if the input type changes. ([#2099](https://github.com/rstudio/shiny/pull/2099))
+
+* Fixed [#2138](https://github.com/rstudio/shiny/issues/2138): Inputs that are part of a `renderUI` were no longer restoring correctly from bookmarked state. [#2139](https://github.com/rstudio/shiny/pull/2139)
+
+* The `knit_print` methods from htmltools are no longer imported into shiny and then exported. Also, shiny's `knit_print` methods are no longer exported. [#2166](https://github.com/rstudio/shiny/pull/2166)
+
+* Fixed [#2093](https://github.com/rstudio/shiny/issues/2093): Make sure bookmark scope directory does not exist before trying to create it. [#2168](https://github.com/rstudio/shiny/pull/2168)
+
+* Fixed [#2177](https://github.com/rstudio/shiny/issues/2177): The session name is now being recorded when exiting a context.  Multiple sessions can now view their respective reactlogs. [#2180](https://github.com/rstudio/shiny/pull/2180)
+
+* Fixed [#2162](https://github.com/rstudio/shiny/issues/2162): `selectInput` was sending spurious duplicate values to the server when using backspace. Thanks, @sada1993! [#2187](https://github.com/rstudio/shiny/pull/2187)
+
+* Fixed [#2142](https://github.com/rstudio/shiny/issues/2142): Dropping files on `fileInput`s stopped working on recent releases of Firefox. Thanks @dmenne for reporting! [#2203](https://github.com/rstudio/shiny/pull/2203)
+
+* Fixed [#2204](https://github.com/rstudio/shiny/issues/2204): `updateDateInput` could set the wrong date on days where DST begins. (Thanks @GaGaMan1101!) [#2212](https://github.com/rstudio/shiny/pull/2212)
+
+* Fixed [#2225](https://github.com/rstudio/shiny/issues/2225): Input event queue can stall in apps that use async. [#2226](https://github.com/rstudio/shiny/pull/2226)
+
+* Fixed [#2228](https://github.com/rstudio/shiny/issues/2228): `reactiveTimer` fails when not owned by a session. Thanks, @P-Bettega! [#2229](https://github.com/rstudio/shiny/pull/2229)
+
+### Documentation Updates
+
+* Addressed [#1864](https://github.com/rstudio/shiny/issues/1864) by changing `optgroup` documentation to use `list` instead of `c`. ([#2084](https://github.com/rstudio/shiny/pull/2084))
+
+
+shiny 1.1.0
+===========
+
+This is a significant release for Shiny, with a major new feature that was nearly a year in the making: support for asynchronous operations! Until now, R's single-threaded nature meant that performing long-running calculations or tasks from Shiny would bring your app to a halt for other users of that process. This release of Shiny deeply integrates the [promises](https://rstudio.github.io/promises/) package to allow you to execute some tasks asynchronously, including as part of reactive expressions and outputs. See the [promises](https://rstudio.github.io/promises/) documentation to learn more.
+
+## Full changelog
+
+### Breaking changes
+
+* `extractStackTrace` and `formatStackTrace` are deprecated and will be removed in a future version of Shiny. As far as we can tell, nobody has been using these functions, and a refactor has made them vestigial; if you need this functionality, please file an issue.
+
+### New features
+
+* Support for asynchronous operations! Built-in render functions that expected a certain kind of object to be yielded from their `expr`, now generally can handle a promise for that kind of object. Reactive expressions and observers are now promise-aware as well. ([#1932](https://github.com/rstudio/shiny/pull/1932))
+
+* Introduced two changes to the (undocumented but widely used) JavaScript function `Shiny.onInputChange(name, value)`. First, we changed the function name to `Shiny.setInputValue` (but don't worry--the old function name will continue to work). Second, until now, all calls to `Shiny.onInputChange(inputId, value)` have been "deduplicated"; that is, anytime an input is set to the same value it already has, the set is ignored. With Shiny v1.1, you can now add an options object as the third parameter: `Shiny.setInputValue("name", value, {priority: "event"})`. When the priority option is set to `"event"`, Shiny will always send the value and trigger reactivity, whether it is a duplicate or not. This closes [#928](https://github.com/rstudio/shiny/issues/928), which was the most upvoted open issue by far! Thanks, @daattali. ([#2018](https://github.com/rstudio/shiny/pull/2018))
+
+### Minor new features and improvements
+
+* Addressed [#1978](https://github.com/rstudio/shiny/issues/1978): `shiny:value` is now triggered when duplicate output data is received from the server. (Thanks, @andrewsali! [#1999](https://github.com/rstudio/shiny/pull/1999))
+
+* If a shiny output contains a css class of `shiny-report-size`, its container height and width are now reported in `session$clientData`. So, for an output with an id with `"myID"`, the height/width can be accessed via `session$clientData[['output_myID_height']]`/`session$clientData[['output_myID_width']]`. Addresses [#1980](https://github.com/rstudio/shiny/issues/1980). (Thanks, @cpsievert! [#1981](https://github.com/rstudio/shiny/pull/1981))
+
+* Added a new `autoclose = TRUE` parameter to `dateInput()` and `dateRangeInput()`. This closed [#1969](https://github.com/rstudio/shiny/issues/1969) which was a duplicate of much older issue, [#173](https://github.com/rstudio/shiny/issues/173). The default value is `TRUE` since that seems to be the common use case. However, this will cause existing apps with date inputs (that update to this version of Shiny) to have the datepicker be immediately closed once a date is selected. For most apps, this is actually desired behavior; if you wish to keep the datepicker open until the user clicks out of it use `autoclose = FALSE`. ([#1987](https://github.com/rstudio/shiny/pull/1987))
+
+* The version of Shiny is now accessible from Javascript, with `Shiny.version`. There is also a new function for comparing version strings, `Shiny.compareVersion()`. ([#1826](https://github.com/rstudio/shiny/pull/1826), [#1830](https://github.com/rstudio/shiny/pull/1830))
+
+* Addressed [#1851](https://github.com/rstudio/shiny/issues/1851): Stack traces are now smaller in some places `do.call()` is used. ([#1856](https://github.com/rstudio/shiny/pull/1856))
+
+* Stack traces have been improved, with more aggressive de-noising and support for deep stack traces (stitching together multiple stack traces that are conceptually part of the same async operation).
+
+* Addressed [#1859](https://github.com/rstudio/shiny/issues/1859): Server-side selectize is now significantly faster. (Thanks to @dselivanov [#1861](https://github.com/rstudio/shiny/pull/1861))
+
+* [#1989](https://github.com/rstudio/shiny/issues/1989): The server side of outputs can now be removed (e.g. `output$plot <- NULL`). This is not usually necessary but it does allow some objects to be garbage collected, which might matter if you are dynamically creating and destroying many outputs. (Thanks, @mmuurr! [#2011](https://github.com/rstudio/shiny/pull/2011))
+
+* Removed the (ridiculously outdated) "experimental feature" tag from the reference documentation for `renderUI`. ([#2036](https://github.com/rstudio/shiny/pull/2036))
+
+* Addressed [#1907](https://github.com/rstudio/shiny/issues/1907): the `ignoreInit` argument was first added only to `observeEvent`. Later, we also added it to `eventReactive`, but forgot to update the documentation. Now done, thanks [@flo12392](https://github.com/flo12392)! ([#2036](https://github.com/rstudio/shiny/pull/2036))
+
+### Bug fixes
+
+* Fixed [#1006](https://github.com/rstudio/shiny/issues/1006): Slider inputs sometimes showed too many digits. ([#1956](https://github.com/rstudio/shiny/pull/1956))
+
+* Fixed [#1958](https://github.com/rstudio/shiny/issues/1958): Slider inputs previously displayed commas after a decimal point. ([#1960](https://github.com/rstudio/shiny/pull/1960))
+
+* The internal `URLdecode()` function previously was a copy of `httpuv::decodeURIComponent()`, assigned at build time; now it invokes the httpuv function at run time.
+
+* Fixed [#1840](https://github.com/rstudio/shiny/issues/1840): with the release of Shiny 1.0.5, we accidently changed the relative positioning of the icon and the title text in `navbarMenu`s and `tabPanel`s. This fix reverts this behavior back (i.e. the icon should be to the left of the text and/or the downward arrow in case of `navbarMenu`s). ([#1848](https://github.com/rstudio/shiny/pull/1848))
+
+* Fixed [#1600](https://github.com/rstudio/shiny/issues/1600): URL-encoded bookmarking did not work with sliders that had dates or date-times. ([#1961](https://github.com/rstudio/shiny/pull/1961))
+
+* Fixed [#1962](https://github.com/rstudio/shiny/issues/1962): [File dragging and dropping](https://blog.rstudio.com/2017/08/15/shiny-1-0-4/) broke in the presence of jQuery version 3.0 as introduced by the [rhandsontable](https://jrowen.github.io/rhandsontable/) [htmlwidget](https://www.htmlwidgets.org/). ([#2005](https://github.com/rstudio/shiny/pull/2005))
+
+* Improved the error handling inside the `addResourcePath()` function, to give end users more informative error messages when the `directoryPath` argument cannot be normalized. This is especially useful for `runtime: shiny_prerendered` Rmd documents, like `learnr` tutorials. ([#1968](https://github.com/rstudio/shiny/pull/1968))
+
+* Changed script tags in reactlog ([inst/www/reactive-graph.html](https://github.com/rstudio/shiny/blob/v1.1.0/inst/www/reactive-graph.html)) from HTTP to HTTPS in order to avoid mixed content blocking by most browsers. (Thanks, @jekriske-lilly! [#1844](https://github.com/rstudio/shiny/pull/1844))
+
+* Addressed [#1784](https://github.com/rstudio/shiny/issues/1784): `runApp()` will avoid port 6697, which is considered unsafe by Chrome.
+
+* Fixed [#2000](https://github.com/rstudio/shiny/issues/2000): Implicit calls to `xxxOutput` not working inside modules. (Thanks, @GregorDeCillia! [#2010](https://github.com/rstudio/shiny/pull/2010))
+
+* Fixed [#2021](https://github.com/rstudio/shiny/issues/2021): Memory leak with `reactiveTimer` and `invalidateLater`. ([#2022](https://github.com/rstudio/shiny/pull/2022))
+
+### Library updates
+
+* Updated to ion.rangeSlider 2.2.0. ([#1955](https://github.com/rstudio/shiny/pull/1955))
+
+
+## Known issues
+
+In some rare cases, interrupting an application (by pressing Ctrl-C or Esc) may result in the message `Error in execCallbacks(timeoutSecs) : c++ exception (unknown reason)`. Although this message sounds alarming, it is harmless, and will go away in a future version of the later package (more information [here](https://github.com/r-lib/later/issues/55)).
+
+
+shiny 1.0.5
+===========
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed [#1818](https://github.com/rstudio/shiny/issues/1818): `conditionalPanel()` expressions that have a newline character in them caused the application to not work. ([#1820](https://github.com/rstudio/shiny/pull/1820))
+
+* Added a safe wrapper function for internal calls to `jsonlite::fromJSON()`. ([#1822](https://github.com/rstudio/shiny/pull/1822))
+
+* Fixed [#1824](https://github.com/rstudio/shiny/issues/1824): HTTP HEAD requests on static files caused the application to stop. ([#1825](https://github.com/rstudio/shiny/pull/1825))
+
+
+shiny 1.0.4
+===========
+
+There are three headlining features in this release of Shiny. It is now possible to add and remove tabs from a `tabPanel`; there is a new function, `onStop()`, which registers callbacks that execute when an application exits; and `fileInput`s now can have files dragged and dropped on them. In addition to these features, this release has a number of minor features and bug fixes. See the full changelog below for more details.
+
+## Full changelog
+
+### New features
+
+* Implemented [#1668](https://github.com/rstudio/shiny/issues/1668): dynamic tabs: added functions (`insertTab`, `appendTab`, `prependTab`, `removeTab`, `showTab` and `hideTab`) that allow you to do those actions for an existing `tabsetPanel`. ([#1794](https://github.com/rstudio/shiny/pull/1794))
+
+* Implemented [#1213](https://github.com/rstudio/shiny/issues/1213): Added a new function, `onStop()`, which can be used to register callback functions that are invoked when an application exits, or when a user session ends. (Multiple sessions can be connected to a single running Shiny application.) This is useful if you have finalization/clean-up code that should be run after the application exits. ([#1770](https://github.com/rstudio/shiny/pull/1770)
+
+* Implemented [#1155](https://github.com/rstudio/shiny/issues/1155): Files can now be drag-and-dropped on `fileInput` controls. The appearance of `fileInput` controls while files are being dragged can be modified by overriding the `shiny-file-input-active` and `shiny-file-input-over` classes. ([#1782](https://github.com/rstudio/shiny/pull/1782))
+
+### Minor new features and improvements
+
+* Addressed [#1688](https://github.com/rstudio/shiny/issues/1688): trigger a new `shiny:outputinvalidated` event when an output gets invalidated, at the same time that the `recalculating` CSS class is added. ([#1758](https://github.com/rstudio/shiny/pull/1758), thanks [@andrewsali](https://github.com/andrewsali)!)
+
+* Addressed [#1508](https://github.com/rstudio/shiny/issues/1508): `fileInput` now permits the same file to be uploaded multiple times. ([#1719](https://github.com/rstudio/shiny/pull/1719))
+
+* Addressed [#1501](https://github.com/rstudio/shiny/issues/1501): The `fileInput` control now retains uploaded file extensions on the server. This fixes [readxl](https://github.com/tidyverse/readxl)'s `readxl::read_excel` and other functions that must recognize a file's extension in order to work. ([#1706](https://github.com/rstudio/shiny/pull/1706))
+
+* For `conditionalPanel`s, Shiny now gives more informative messages if there are errors evaluating or parsing the JavaScript conditional expression. ([#1727](https://github.com/rstudio/shiny/pull/1727))
+
+* Addressed [#1586](https://github.com/rstudio/shiny/issues/1586): The `conditionalPanel` function now accepts an `ns` argument. The `ns` argument can be used in a [module](https://shiny.rstudio.com/articles/modules.html) UI function to scope the `condition` expression to the module's own input and output IDs. ([#1735](https://github.com/rstudio/shiny/pull/1735))
+
+* With `options(shiny.testmode=TRUE)`, the Shiny process will send a message to the client in response to a changed input, even if no outputs have changed. This helps to streamline testing using the shinytest package. ([#1747](https://github.com/rstudio/shiny/pull/1747))
+
+* Addressed [#1738](https://github.com/rstudio/shiny/issues/1738): The `updateTextInput` and `updateTextAreaInput` functions can now update the placeholder. ([#1742](https://github.com/rstudio/shiny/pull/1742))
+
+* Converted examples to single file apps, and made updates and enhancements to comments in the example app scripts. ([#1685](https://github.com/rstudio/shiny/pull/1685))
+
+* Added new `snapshotPreprocessInput()` and `snapshotPreprocessOutput()` functions, which is used for preprocessing and input and output values before taking a test snapshot. ([#1760](https://github.com/rstudio/shiny/pull/1760), [#1789](https://github.com/rstudio/shiny/pull/1789))
+
+* The HTML generated by `renderTable()` no longer includes comments with the R version, xtable version, and timestamp. ([#1771](https://github.com/rstudio/shiny/pull/1771))
+
+* Added a function `isRunning` to test whether a Shiny app is currently running. ([#1785](https://github.com/rstudio/shiny/pull/1785))
+
+* Added a function `setSerializer`, which allows authors to specify a function for serializing the value of a custom input. ([#1791](https://github.com/rstudio/shiny/pull/1791))
+
+### Bug fixes
+
+* Fixed [#1546](https://github.com/rstudio/shiny/issues/1546): make it possible (without any hacks) to write arbitrary data into a module's `session$userData` (which is exactly the same environment as the parent's `session$userData`). To be clear, it allows something like `session$userData$x <- TRUE`, but not something like `session$userData <- TRUE` (that is not allowed in any context, whether you're in the main app, or in a module) ([#1732](https://github.com/rstudio/shiny/pull/1732)).
+
+* Fixed [#1701](https://github.com/rstudio/shiny/issues/1701): There was a partial argument match in the `generateOptions` function. ([#1702](https://github.com/rstudio/shiny/pull/1702))
+
+* Fixed [#1710](https://github.com/rstudio/shiny/issues/1710): `ReactiveVal` objects did not have separate dependents. ([#1712](https://github.com/rstudio/shiny/pull/1712))
+
+* Fixed [#1438](https://github.com/rstudio/shiny/issues/1438): `unbindAll()` should not be called when inserting content with `insertUI()`. A previous fix ([#1449](https://github.com/rstudio/shiny/pull/1449)) did not work correctly. ([#1736](https://github.com/rstudio/shiny/pull/1736))
+
+* Fixed [#1755](https://github.com/rstudio/shiny/issues/1755): dynamic htmlwidgets sent the path of the package on the server to the client. ([#1756](https://github.com/rstudio/shiny/pull/1756))
+
+* Fixed [#1763](https://github.com/rstudio/shiny/issues/1763): Shiny's private random stream leaked out into the main random stream. ([#1768](https://github.com/rstudio/shiny/pull/1768))
+
+* Fixed [#1680](https://github.com/rstudio/shiny/issues/1680): `options(warn=2)` was not respected when running an app. ([#1790](https://github.com/rstudio/shiny/pull/1790))
+
+* Fixed [#1772](https://github.com/rstudio/shiny/issues/1772): ensure that `runApp()` respects the `shinyApp(onStart = function())` argument. ([#1770](https://github.com/rstudio/shiny/pull/1770))
+
+* Fixed [#1474](https://github.com/rstudio/shiny/issues/1474): A `browser()` call in an observer could cause an error in the RStudio IDE on Windows. ([#1802](https://github.com/rstudio/shiny/pull/1802))
+
+
+shiny 1.0.3
+================
+
+This is a hotfix release of Shiny. With previous versions of Shiny, when running an application on the newly-released version of R, 3.4.0, it would print a message: `Warning in body(fun) : argument is not a function`. This has no effect on the application, but because the message could be alarming to users, we are releasing a new version of Shiny that fixes this issue.
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed [#1672](https://github.com/rstudio/shiny/issues/1672): When an error occurred while uploading a file, the progress bar did not change colors. ([#1673](https://github.com/rstudio/shiny/pull/1673))
+
+* Fixed [#1676](https://github.com/rstudio/shiny/issues/1676): On R 3.4.0, running a Shiny application gave a warning: `Warning in body(fun) : argument is not a function`. ([#1677](https://github.com/rstudio/shiny/pull/1677))
+
+
+shiny 1.0.2
+================
+
+This is a hotfix release of Shiny. The primary reason for this release is because the web host for MathJax JavaScript library is scheduled to be shut down in the next few weeks. After it is shut down, Shiny applications that use MathJax will no longer be able to load the MathJax library if they are run with Shiny 1.0.1 and below. (If you don't know whether your application uses MathJax, it probably does not.) For more information about why the MathJax CDN is shutting down, see https://www.mathjax.org/cdn-shutting-down/.
+
+## Full changelog
+
+### Minor new features and improvements
+
+* Added a `shiny:sessioninitialized` Javascript event, which is fired at the end of the initialize method of the Session object. This allows us to listen for this event when we want to get the value of things like `Shiny.user`. ([#1568](https://github.com/rstudio/shiny/pull/1568))
+
+* Fixed [#1649](https://github.com/rstudio/shiny/issues/1649): allow the `choices` argument in `checkboxGroupInput()` to be `NULL` (or `c()`) to keep backward compatibility with Shiny < 1.0.1. This will result in the same thing as providing `choices = character(0)`. ([#1652](https://github.com/rstudio/shiny/pull/1652))
+
+* The official URL for accessing MathJax libraries over CDN has been deprecated and will be removed soon. We have switched to a new rstudio.com URL that we will support going forward. ([#1664](https://github.com/rstudio/shiny/pull/1664))
+
+### Bug fixes
+
+* Fixed [#1653](https://github.com/rstudio/shiny/issues/1653): wrong code example in documentation. ([#1658](https://github.com/rstudio/shiny/pull/1658))
+
+
+shiny 1.0.1
+================
+
+This is a maintenance release of Shiny, mostly aimed at fixing bugs and introducing minor features. The most notable additions in this version of Shiny are the introduction of the `reactiveVal()` function (it's like `reactiveValues()`, but it only stores a single value), and that the choices of `radioButtons()` and `checkboxGroupInput()` can now contain HTML content instead of just plain text.
+
+## Full changelog
+
+### Breaking changes
+
+* The functions `radioButtons()`, `checkboxGroupInput()` and `selectInput()` (and the corresponding `updateXXX()` functions) no longer accept a `selected` argument whose value is the name of a choice, instead of the value of the choice. This feature had been deprecated since Shiny 0.10 (it printed a warning message, but still tried to match the name to the right choice) and it's now completely unsupported.
+
+### New features
+
+* Added `reactiveVal` function, for storing a single value which can be (reactively) read and written. Similar to `reactiveValues`, except that `reactiveVal` just lets you store a single value instead of storing multiple values by name. ([#1614](https://github.com/rstudio/shiny/pull/1614))
+
+### Minor new features and improvements
+
+* Fixed [#1637](https://github.com/rstudio/shiny/issues/1637): Outputs stay faded on MS Edge. ([#1640](https://github.com/rstudio/shiny/pull/1640))
+
+* Addressed [#1348](https://github.com/rstudio/shiny/issues/1348) and [#1437](https://github.com/rstudio/shiny/issues/1437) by adding two new arguments to `radioButtons()` and `checkboxGroupInput()`: `choiceNames` (list or vector) and `choiceValues` (list or vector). These can be passed in as an alternative to `choices`, with the added benefit that the elements in `choiceNames` can be arbitrary UI (i.e. anything created by `HTML()` and the `tags()` functions, like icons and images). While the underlying values for each choice (passed in through `choiceValues`) must still be simple text, their visual representation on the app (what the user actually clicks to select a different option) can be any valid HTML element. See `?radioButtons` for a small example. ([#1521](https://github.com/rstudio/shiny/pull/1521))
+
+* Updated `tools/README.md` with more detailed instructions. ([#1616](https://github.com/rstudio/shiny/pull/1616))
+
+* Fixed [#1565](https://github.com/rstudio/shiny/issues/1565), which meant that resources with spaces in their names return HTTP 404. ([#1566](https://github.com/rstudio/shiny/pull/1566))
+
+* Exported `session$user` (if it exists) to the client-side; it's accessible in the Shiny object: `Shiny.user`. ([#1563](https://github.com/rstudio/shiny/pull/1563))
+
+* Added support for HTML5's `pushState` which allows for pseudo-navigation
+in shiny apps. For more info, see the documentation (`?updateQueryString` and `?getQueryString`). ([#1447](https://github.com/rstudio/shiny/pull/1447))
+
+* Fixed [#1121](https://github.com/rstudio/shiny/issues/1121): plot interactions with ggplot2 now support `coord_fixed()`. ([#1525](https://github.com/rstudio/shiny/pull/1525))
+
+* Added `snapshotExclude` function, which marks an output so that it is not recorded in a test snapshot. ([#1559](https://github.com/rstudio/shiny/pull/1559))
+
+* Added `shiny:filedownload` JavaScript event, which is triggered when a `downloadButton` or `downloadLink` is clicked. Also, the values of `downloadHandler`s are not recorded in test snapshots, because the values change every time the application is run. ([#1559](https://github.com/rstudio/shiny/pull/1559))
+
+* Added support for plot interactions with ggplot2 > 2.2.1. ([#1578](https://github.com/rstudio/shiny/pull/1578))
+
+* Fixed [#1577](https://github.com/rstudio/shiny/issues/1577): Improved `escapeHTML` (util.js) in terms of the order dependency of replacing, XSS risk attack and performance. ([#1579](https://github.com/rstudio/shiny/pull/1579))
+
+* The `shiny:inputchanged` JavaScript event now includes two new fields, `binding` and `el`, which contain the input binding and DOM element, respectively. Additionally, `Shiny.onInputChange()` now accepts an optional argument, `opts`, which can contain the same fields. ([#1596](https://github.com/rstudio/shiny/pull/1596))
+
+* The `NS()` function now returns a vectorized function. ([#1613](https://github.com/rstudio/shiny/pull/1613))
+
+* Fixed [#1617](https://github.com/rstudio/shiny/issues/1617): `fileInput` can have customized text for the button and the placeholder. ([#1619](https://github.com/rstudio/shiny/pull/1619))
+
+### Bug fixes
+
+* Fixed [#1511](https://github.com/rstudio/shiny/issues/1511): `fileInput`s did not trigger the `shiny:inputchanged` event on the client. Also removed `shiny:fileuploaded` JavaScript event, because it is no longer needed after this fix. ([#1541](https://github.com/rstudio/shiny/pull/1541), [#1570](https://github.com/rstudio/shiny/pull/1570))
+
+* Fixed [#1472](https://github.com/rstudio/shiny/issues/1472): With a Progress object, calling `set(value=NULL)` made the progress bar go to 100%. Now it does not change the value of the progress bar. The documentation also incorrectly said that setting the `value` to `NULL` would hide the progress bar. ([#1547](https://github.com/rstudio/shiny/pull/1547))
+
+* Fixed [#162](https://github.com/rstudio/shiny/issues/162): When a dynamically-generated input changed to a different `inputType`, it might be incorrectly deduplicated.  ([#1594](https://github.com/rstudio/shiny/pull/1594))
+
+* Removed redundant call to `inputs.setInput`. ([#1595](https://github.com/rstudio/shiny/pull/1595))
+
+* Fixed bug where `dateRangeInput` did not respect `weekstart` argument. ([#1592](https://github.com/rstudio/shiny/pull/1592))
+
+* Fixed [#1598](https://github.com/rstudio/shiny/issues/1598): `setBookmarkExclude()` did not work properly inside of modules. ([#1599](https://github.com/rstudio/shiny/pull/1599))
+
+* Fixed [#1605](https://github.com/rstudio/shiny/issues/1605): sliders did not move when clicked on the bar area. ([#1610](https://github.com/rstudio/shiny/pull/1610))
+
+* Fixed [#1621](https://github.com/rstudio/shiny/issues/1621): if a `reactiveTimer`'s session was closed before the first time that the `reactiveTimer` fired, then the `reactiveTimer` would not get cleared and would keep firing indefinitely. ([#1623](https://github.com/rstudio/shiny/pull/1623))
+
+* Fixed [#1634](https://github.com/rstudio/shiny/issues/1634): If brushing on a plot causes the plot to redraw, then the redraw could in turn trigger the plot to redraw again and again. This was due to spurious changes in values of floating point numbers. ([#1641](https://github.com/rstudio/shiny/pull/1641))
+
+### Library updates
+
+* Closed [#1500](https://github.com/rstudio/shiny/issues/1500): Updated ion.rangeSlider to 2.1.6. ([#1540](https://github.com/rstudio/shiny/pull/1540))
+
+
+shiny 1.0.0
+===========
+
+Shiny has reached a milestone: version 1.0.0! In the last year, we've added two major features that we considered essential for a 1.0.0 release: bookmarking, and support for testing Shiny applications. As usual, this version of Shiny also includes many minor features and bug fixes.
+
+Here are some highlights from this release. For more details, see the full changelog below.
+
+## Support for testing Shiny applications
+
+Shiny now supports automated testing of applications, with the [shinytest](https://github.com/rstudio/shinytest) package. Shinytest has not yet been released on CRAN, but will be soon. ([#18](https://github.com/rstudio/shiny/issues/18), [#1464](https://github.com/rstudio/shiny/pull/1464))
+
+## Debounce/throttle reactives
+
+Now there's an official way to slow down reactive values and expressions that invalidate too quickly. Pass a reactive expression to the new `debounce` or `throttle` function, and get back a modified reactive expression that doesn't invalidate as often. ([#1510](https://github.com/rstudio/shiny/pull/1510))
+
+## Full changelog
+
+### Breaking changes
+
+* Added a new `placeholder` argument to `verbatimTextOutput()`. The default is `FALSE`, which means that, if there is no content for this output, no representation of this slot will be made in the UI. Previsouly, even if there was no content, you'd see an empty rectangle in the UI that served as a placeholder. You can set `placeholder = TRUE` to revert back to that look. ([#1480](https://github.com/rstudio/shiny/pull/1480))
+
+### New features
+
+* Added support for testing Shiny applications with the shinytest package. ([#18](https://github.com/rstudio/shiny/issues/18), [#1464](https://github.com/rstudio/shiny/pull/1464))
+
+* Added `debounce` and `throttle` functions, to control the rate at which reactive values and expressions invalidate. ([#1510](https://github.com/rstudio/shiny/pull/1510))
+
+### Minor new features and improvements
+
+* Addressed [#1486](https://github.com/rstudio/shiny/issues/1486) by adding a new argument to `observeEvent` and `eventReactive`, called `ignoreInit` (defaults to `FALSE` for backwards compatibility). When set to `TRUE`, the action (i.e. the second argument: `handlerExpr` and `valueExpr`, respectively) will not be triggered when the observer/reactive is first created/initialized. In other words, `ignoreInit = TRUE` ensures that the `observeEvent` (or `eventReactive`) is *never* run right away. For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
+
+* Added a new argument to `observeEvent` called `once`. When set to `TRUE`, it results in the observer being destroyed (stop observing) after the first time that `handlerExpr` is run (i.e. `once = TRUE` guarantees that the observer only runs, at most, once). For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
+
+* Addressed [#1358](https://github.com/rstudio/shiny/issues/1358): more informative error message when calling `runApp()` inside of an app's app.R (or inside ui.R or server.R). ([#1482](https://github.com/rstudio/shiny/pull/1482))
+
+* Added a more descriptive JS warning for `insertUI()` when the selector argument does not match anything in DOM. ([#1488](https://github.com/rstudio/shiny/pull/1488))
+
+* Added support for injecting JavaScript code when the `shiny.testmode` option is set to `TRUE`. This makes it possible to record test events interactively. ([#1464](https://github.com/rstudio/shiny/pull/1464))
+
+* Added ability through arguments to the `a` tag function called inside `downloadButton()` and `downloadLink()`. Closes [#986](https://github.com/rstudio/shiny/issues/986). ([#1492](https://github.com/rstudio/shiny/pulls/1492))
+
+* Implemented [#1512](https://github.com/rstudio/shiny/issues/1512): added a `userData` environment to `session`, for storing arbitrary session-related variables. Generally, session-scoped variables are created just by declaring normal variables that are local to the Shiny server function, but `session$userData` may be more convenient for some advanced scenarios. ([#1513](https://github.com/rstudio/shiny/pull/1513))
+
+* Relaxed naming requirements for `addResourcePath()` (the first character no longer needs to be a letter). ([#1529](https://github.com/rstudio/shiny/pull/1529))
+
+### Bug fixes
+
+* Fixed [#969](https://github.com/rstudio/shiny/issues/969): allow navbarPage's `fluid` param to control both containers. ([#1481](https://github.com/rstudio/shiny/pull/1481))
+
+* Fixed [#1438](https://github.com/rstudio/shiny/issues/1438): `unbindAll()` should not be called when inserting content with `insertUI()` ([#1449](https://github.com/rstudio/shiny/pull/1449))
+
+* Fixed bug causing `<meta>` tags associated with HTML dependencies of Shiny R Markdown files to be rendered incorrectly. ([#1463](https://github.com/rstudio/shiny/pull/1463))
+
+* Fixed [#1359](https://github.com/rstudio/shiny/issues/1359): `shinyApp()` options argument ignored when passed to `runApp()`. ([#1483](https://github.com/rstudio/shiny/pull/1483))
+
+* Fixed [#117](https://github.com/rstudio/shiny/issues/117): Reactive expressions now release references to cached values as soon as they are invalidated, potentially making those cached values eligible for garbage collection sooner. Previously, this would not occur until the next cached value was calculated and stored. ([#1504](https://github.com/rstudio/shiny/pull/1504/files))
+
+* Fixed [#1013](https://github.com/rstudio/shiny/issues/1013): `flushReact` should be called after app loads. Observers set up outside of server functions were not running until after the first user connects. ([#1503](https://github.com/rstudio/shiny/pull/1503))
+
+* Fixed [#1453](https://github.com/rstudio/shiny/issues/1453): When using a modal dialog with `easyClose=TRUE` in a Shiny gadget, pressing Esc would close both the modal and the gadget. Now pressing Esc only closes the modal. ([#1523](https://github.com/rstudio/shiny/pull/1523))
+
+### Library updates
+
+* Updated to Font Awesome 4.7.0.
+
+
+shiny 0.14.2
+============
+
+This is a maintenance release of Shiny, with some bug fixes and minor new features.
+
+## Full changelog
+
+### Minor new features and improvements
+
+* Added a `fade` argument to `modalDialog()` -- setting it to `FALSE` will remove the usual fade-in animation for that modal window. ([#1414](https://github.com/rstudio/shiny/pull/1414))
+
+* Fixed a "duplicate binding" error that occurred in some edge cases involving `insertUI` and nested `uiOutput`. ([#1402](https://github.com/rstudio/shiny/pull/1402))
+
+* Fixed [#1422](https://github.com/rstudio/shiny/issues/1422): When using the `shiny.trace` option, allow specifying to only log SEND or RECV messages, or both. (PR [#1428](https://github.com/rstudio/shiny/pull/1428))
+
+* Fixed [#1419](https://github.com/rstudio/shiny/issues/1419): Allow overriding a JS custom message handler. (PR [#1445](https://github.com/rstudio/shiny/pull/1445))
+
+* Added `exportTestValues()` function, which allows a test driver to query the session for values internal to an application's server function. This only has an effect if the `shiny.testmode` option is set to `TRUE`. ([#1436](https://github.com/rstudio/shiny/pull/1436))
+
+### Bug fixes
+
+* Fixed [#1427](https://github.com/rstudio/shiny/issues/1427): make sure that modals do not close incorrectly when an element inside them is triggered as hidden. ([#1430](https://github.com/rstudio/shiny/pull/1430))
+
+* Fixed [#1404](https://github.com/rstudio/shiny/issues/1404): stack trace tests were not compatible with the byte-code compiler in R-devel, which now tracks source references.
+
+* `sliderInputBinding.setValue()` now sends a slider's value immediately, instead of waiting for the usual 250ms debounce delay. ([#1429](https://github.com/rstudio/shiny/pull/1429))
+
+* Fixed a bug where, in versions of R before 3.2, Shiny applications could crash due to a bug in R's implementation of `list2env()`. ([#1446](https://github.com/rstudio/shiny/pull/1446))
+
+shiny 0.14.1
+============
+
+This is a maintenance release of Shiny, with some bug fixes and minor new features.
+
+## Full changelog
+
+### Minor new features and improvements
+
+* Restored file inputs are now copied on restore, so that the restored application can't modify the bookmarked file. ([#1370](https://github.com/rstudio/shiny/issues/1370))
+
+* Added support for plot interaction in the development version of ggplot2, 2.1.0.9000. Also added support for ggplot2 plots with `coord_flip()` (in the development version of ggplot2). ([hadley/ggplot2#1781](https://github.com/hadley/ggplot2/issues/1781), [#1392](https://github.com/rstudio/shiny/pull/1392))
+
+
+### Bug fixes
+
+* Fixed [#1093](https://github.com/rstudio/shiny/issues/1093) better: `updateRadioButtons()` and `updateCheckboxGroupInput()` were not working correctly if the choices were given as a numeric vector. This had been solved in [#1291](https://github.com/rstudio/shiny/pull/1291), but that introduced a different bug [#1396](https://github.com/rstudio/shiny/issues/1396) that this better fix avoids. ([#1370](https://github.com/rstudio/shiny/pull/1397))
+
+* Fixed [#1368](https://github.com/rstudio/shiny/issues/1368): If an app with a file input was bookmarked and restored, and then the restored app was bookmarked and restored (without uploading a new file), then it would fail to restore the file the second time. ([#1370](https://github.com/rstudio/shiny/pull/1370))
+
+* Fixed [#1369](https://github.com/rstudio/shiny/issues/1369): `sliderInput()` did not allow showing numbers without a thousands separator.
+
+* Fixed [#1346](https://github.com/rstudio/shiny/issues/1346) and [#1107](https://github.com/rstudio/shiny/issues/1107) : jQuery UI's datepicker conflicted with the bootstrap-datepicker used by Shiny's `dateInput()` and `dateRangeInput()`. ([#1374](https://github.com/rstudio/shiny/pull/1374))
+
+### Library updates
+
+* Updated to bootstrap-datepicker 1.6.4. ([#1218](https://github.com/rstudio/shiny/issues/1218), [#1374](https://github.com/rstudio/shiny/pull/1374))
+
+* Updated to jQuery UI 1.12.1. Previously, Shiny included a build of 1.11.4 which was missing the datepicker component due to a conflict with the bootstrap-datepicker used by Shiny's `dateInput()` and `dateRangeInput()`. ([#1374](https://github.com/rstudio/shiny/pull/1374))
+
+
 shiny 0.14
-=================
+==========
 
 A new Shiny release is upon us! There are many new exciting features, bug fixes, and library updates. We'll just highlight the most important changes here, but you can browse through the full changelog below for details. This will likely be the last release before shiny 1.0, so get out your party hats!
 
@@ -10,17 +622,17 @@ Shiny now supports bookmarkable state: users can save the state of an applicatio
 **_Important note_:**
 > Saved-to-server bookmarking currently works with Shiny Server Open Source. Support on Shiny Server Pro, RStudio Connect, and shinyapps.io is under development and testing. However, URL-encoded bookmarking works on all hosting platforms.
 
-See [this article](http://shiny.rstudio-staging.com/articles/bookmarking-state.html) to get started with bookmarkable state. There is also an [advanced-level article](http://shiny.rstudio-staging.com/articles/advanced-bookmarking.html) (for apps that have a complex state), and [a modules article](http://shiny.rstudio-staging.com/articles/bookmarking-modules.html) that details how to use bookmarking in conjunction with modules.
+See [this article](http://shiny.rstudio.com/articles/bookmarking-state.html) to get started with bookmarkable state. There is also an [advanced-level article](http://shiny.rstudio.com/articles/advanced-bookmarking.html) (for apps that have a complex state), and [a modules article](http://shiny.rstudio.com/articles/bookmarking-modules.html) that details how to use bookmarking in conjunction with modules.
 
 ## Notifications
 
 Shiny can now display notifications on the client browser by using the `showNotification()` function. Use [this demo app](https://gallery.shinyapps.io/116-notifications/) to play around with the notification API. Here's a screenshot of a very simple notification (shown when the button is clicked):
 
 <p align="center">
-<img src="http://shiny.rstudio-staging.com/images/notification.png" alt="notification" width="50%"/>
+<img src="http://shiny.rstudio.com/images/notification.png" alt="notification" width="50%"/>
 </p>
 
-[Here](http://shiny.rstudio-staging.com/articles/notifications.html)'s our article about it, and the [reference documentation](http://shiny.rstudio-staging.com/reference/shiny/latest/showNotification.html).
+[Here](http://shiny.rstudio.com/articles/notifications.html)'s our article about it, and the [reference documentation](http://shiny.rstudio.com/reference/shiny/latest/showNotification.html).
 
 ## Progress indicators
 
@@ -29,7 +641,7 @@ If your Shiny app contains computations that take a long time to complete, a pro
 **_Important note_:**
 > If you were already using progress bars and had customized them with your own CSS, you can add the `style = "old"` argument to your `withProgress()` call (or `Progress$new()`). This will result in the same appearance as before. You can also call `shinyOptions(progress.style = "old")` in your app's server function to make all progress indicators use the old styling.
 
-To see new progress bars in action, see [this app](https://gallery.shinyapps.io/085-progress/) in the gallery. You can also learn more about this in [our article](http://shiny.rstudio-staging.com/articles/progress.html) and in the reference documentation (either for the easier [`withProgress` functional API](http://shiny.rstudio-staging.com/reference/shiny/latest/withProgress.html) or the more complicated, but more powerful, [`Progress` object-oriented API](http://shiny.rstudio-staging.com/reference/shiny/latest/Progress.html).
+To see new progress bars in action, see [this app](https://gallery.shinyapps.io/085-progress/) in the gallery. You can also learn more about this in [our article](http://shiny.rstudio.com/articles/progress.html) and in the reference documentation (either for the easier [`withProgress` functional API](http://shiny.rstudio.com/reference/shiny/latest/withProgress.html) or the more complicated, but more powerful, [`Progress` object-oriented API](http://shiny.rstudio.com/reference/shiny/latest/Progress.html).
 
 ## Reconnection
 
@@ -40,10 +652,10 @@ Shiny can now automatically reconnect to your Shiny session if you temporarily l
 Shiny has now built-in support for displaying modal dialogs like the one below ([live app here](https://gallery.shinyapps.io/114-modal-dialog/)):
 
 <p align="center">
-<img src="http://shiny.rstudio-staging.com/images/modal-dialog.png" alt="modal-dialog" width="50%"/>
+<img src="http://shiny.rstudio.com/images/modal-dialog.png" alt="modal-dialog" width="50%"/>
 </p>
 
-To learn more about this, read [our article](http://shiny.rstudio-staging.com/articles/modal-dialogs.html) and the [reference documentation](http://shiny.rstudio-staging.com/reference/shiny/latest/modalDialog.html).
+To learn more about this, read [our article](http://shiny.rstudio.com/articles/modal-dialogs.html) and the [reference documentation](http://shiny.rstudio.com/reference/shiny/latest/modalDialog.html).
 
 ## `insertUI` and `removeUI`
 
@@ -51,13 +663,13 @@ Sometimes in a Shiny app, arbitrary HTML UI may need to be created on-the-fly in
 
 See [this simple demo app](https://gallery.shinyapps.io/111-insert-ui/) of how one could use `insertUI` and `removeUI` to insert and remove text elements using a queue. Also see [this other app](https://gallery.shinyapps.io/insertUI/) that demonstrates how to insert and remove a few common Shiny input objects. Finally, [this app](https://gallery.shinyapps.io/insertUI-modules/) shows how to dynamically insert modules using `insertUI`.
 
-For more, read [our article](http://shiny.rstudio-staging.com/articles/dynamic-ui.html) about dynamic UI generation and the reference documentation about [`insertUI`](http://shiny.rstudio-staging.com/reference/shiny/latest/insertUI.html) and [`removeUI`](http://shiny.rstudio-staging.com/reference/shiny/latest/removeUI.html).
+For more, read [our article](http://shiny.rstudio.com/articles/dynamic-ui.html) about dynamic UI generation and the reference documentation about [`insertUI`](http://shiny.rstudio.com/reference/shiny/latest/insertUI.html) and [`removeUI`](http://shiny.rstudio.com/reference/shiny/latest/removeUI.html).
 
 ## Documentation for connecting to an external database
 
-Many Shiny users have asked about best practices for accessing external databases from their Shiny applications. Although database access has long been possible using various database connector packages in R, it can be challenging to use them robustly in the dynamic environment that Shiny provides. So far, it has been mostly up to application authors to find the appropriate database drivers and to discover how to manage the database connections within an application. In order to demystify this process, we wrote a series of articles ([first one here](http://shiny.rstudio-staging.com/articles/overview.html)) that covers the basics of connecting to an external database, as well as some security precautions to keep in mind (e.g. [how to avoid SQL injection attacks](http://shiny.rstudio-staging.com/articles/sql-injections.html)).
+Many Shiny users have asked about best practices for accessing external databases from their Shiny applications. Although database access has long been possible using various database connector packages in R, it can be challenging to use them robustly in the dynamic environment that Shiny provides. So far, it has been mostly up to application authors to find the appropriate database drivers and to discover how to manage the database connections within an application. In order to demystify this process, we wrote a series of articles ([first one here](http://shiny.rstudio.com/articles/overview.html)) that covers the basics of connecting to an external database, as well as some security precautions to keep in mind (e.g. [how to avoid SQL injection attacks](http://shiny.rstudio.com/articles/sql-injections.html)).
 
-There are a few packages that you should look at if you're using a relational database in a Shiny app: the `dplyr` and `DBI` packages (both featured in the article linked to above), and the brand new `pool` package, which provides a further layer of abstraction to make it easier and safer to use either `DBI` or `dplyr`. `pool` is not yet on CRAN. In particular, `pool` will take care of managing connections, preventing memory leaks, and ensuring the best performance. See this [`pool` basics article](http://shiny.rstudio-staging.com/articles/pool-basics.html) and the [more advanced-level article](http://shiny.rstudio-staging.com/articles/pool-advanced.html) if you're feeling adventurous! (Both of these articles contain Shiny app examples that use `DBI` to connect to an external MySQL database.) If you are more comfortable with `dplyr` than `DBI`, don't miss the article about the [integration of `pool` and `dplyr`](http://shiny.rstudio-staging.com/articles/pool-dplyr.html).
+There are a few packages that you should look at if you're using a relational database in a Shiny app: the `dplyr` and `DBI` packages (both featured in the article linked to above), and the brand new `pool` package, which provides a further layer of abstraction to make it easier and safer to use either `DBI` or `dplyr`. `pool` is not yet on CRAN. In particular, `pool` will take care of managing connections, preventing memory leaks, and ensuring the best performance. See this [`pool` basics article](http://shiny.rstudio.com/articles/pool-basics.html) and the [more advanced-level article](http://shiny.rstudio.com/articles/pool-advanced.html) if you're feeling adventurous! (Both of these articles contain Shiny app examples that use `DBI` to connect to an external MySQL database.) If you are more comfortable with `dplyr` than `DBI`, don't miss the article about the [integration of `pool` and `dplyr`](http://shiny.rstudio.com/articles/pool-dplyr.html).
 
 If you're new to databases in the Shiny world, we recommend using `dplyr` and `pool` if possible. If you need greater control than `dplyr` offers (for example, if you need to modify data in the database or use transactions), then use `DBI` and `pool`. The `pool` package was introduced to make your life easier, but in no way constrains you, so we don't envision any situation in which you'd be better off *not* using it. The only caveat is that `pool` is not yet on CRAN, so you may prefer to wait for that.
 
@@ -65,14 +677,14 @@ If you're new to databases in the Shiny world, we recommend using `dplyr` and `p
 
 There are many more minor features, small improvements, and bug fixes than we can cover here, so we'll just mention a few of the more noteworthy ones (the full changelog, with links to all the relevant issues and pull requests, is right below this section):
 
-*    **Error Sanitization**: you now have the option to sanitize error messages; in other words, the content of the original error message can be suppressed so that it doesn't leak any sensitive information. To sanitize errors everywhere in your app, just add `options(shiny.sanitize.errors = TRUE)` somewhere in your app. Read [this article](http://shiny.rstudio-staging.com/articles/sanitize-errors.html) for more, or play with the [demo app](https://gallery.shinyapps.io/110-error-sanitization/).
+*    **Error Sanitization**: you now have the option to sanitize error messages; in other words, the content of the original error message can be suppressed so that it doesn't leak any sensitive information. To sanitize errors everywhere in your app, just add `options(shiny.sanitize.errors = TRUE)` somewhere in your app. Read [this article](http://shiny.rstudio.com/articles/sanitize-errors.html) for more, or play with the [demo app](https://gallery.shinyapps.io/110-error-sanitization/).
 
 *    **Code Diagnostics**: if there is an error parsing `ui.R`, `server.R`, `app.R`, or `global.R`, Shiny will search the code for missing commas, extra commas, and unmatched braces, parens, and brackets, and will print out messages pointing out those problems. ([#1126](https://github.com/rstudio/shiny/pull/1126))
 
-*    **Reactlog visualization**: by default, the [`showReactLog()` function](http://shiny.rstudio-staging.com/reference/shiny/latest/showReactLog.html) (which brings up the reactive graph) also displays the time that each reactive and observer were active for:
+*    **Reactlog visualization**: by default, the [`showReactLog()` function](http://shiny.rstudio.com/reference/shiny/latest/reactlog.html) (which brings up the reactive graph) also displays the time that each reactive and observer were active for:
 
       <p align="center">
-      <img src="http://shiny.rstudio-staging.com/images/reactlog.png" alt="modal-dialog" width="75%"/>
+      <img src="http://shiny.rstudio.com/images/reactlog.png" alt="modal-dialog" width="75%"/>
       </p>
 
       This new feature can be turned off with `showReactLog(time = FALSE)`. This may be convenient if you have a large graph and don't want to have this new information cluttering it up. The elapsed time info shows up above each relevant node's label, and the time is also coded by color: the slowest reactive will be dark red and the fastest will be light red.
@@ -82,10 +694,10 @@ There are many more minor features, small improvements, and bug fixes than we ca
 *    **Nicer-looking tables**: we've made tables generated with `renderTable()` look cleaner and more modern. While this won't break any older code, the finished look of your table will be quite a bit different, as the following image shows:
 
       <p align="center">
-      <img src="http://shiny.rstudio-staging.com/images/render-table.png" alt="render-table" width="75%"/>
+      <img src="http://shiny.rstudio.com/images/render-table.png" alt="render-table" width="75%"/>
       </p>
 
-      For more, read our [short article](http://shiny.rstudio-staging.com/articles/render-table.html) about this update, experiment with all the new features in this [demo app](https://gallery.shinyapps.io/109-render-table/), or check out the [reference documentation](http://shiny.rstudio-staging.com/reference/shiny/latest/renderTable.html).
+      For more, read our [short article](http://shiny.rstudio.com/articles/render-table.html) about this update, experiment with all the new features in this [demo app](https://gallery.shinyapps.io/109-render-table/), or check out the [reference documentation](http://shiny.rstudio.com/reference/shiny/latest/renderTable.html).
 
 ## Full changelog
 
@@ -301,7 +913,7 @@ shiny 0.12.1
 shiny 0.12.0
 ============
 
-In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps. 
+In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps.
 
 ### JSON serialization
 
@@ -392,13 +1004,13 @@ Shiny 0.11 switches away from the Bootstrap 2 web framework to the next version,
 ### Known issues for migration
 
 *    In Bootstrap 3, images in `<img>` tags are no longer automatically scaled to the width of their container. If you use `img()` in your UI code, or `<img>` tags in your raw HTML source, it's possible that they will be too large in the new version of Shiny. To address this you can add the `img-responsive` class:
-    
+
     ```r
     img(src = "picture.png", class = "img-responsive")
     ```
-    
+
     The R code above will generate the following HTML:
-    
+
     ```html
     <img src="picture.png" class="img-responsive">
     ```

R/app.R

@@ -3,42 +3,47 @@
 #' Create a Shiny app object
 #'
 #' These functions create Shiny app objects from either an explicit UI/server
-#' pair (\code{shinyApp}), or by passing the path of a directory that contains a
-#' Shiny app (\code{shinyAppDir}). You generally shouldn't need to use these
-#' functions to create/run applications; they are intended for interoperability
-#' purposes, such as embedding Shiny apps inside a \pkg{knitr} document.
+#' pair (`shinyApp`), or by passing the path of a directory that contains a
+#' Shiny app (`shinyAppDir`).
 #'
 #' Normally when this function is used at the R console, the Shiny app object is
-#' automatically passed to the \code{print()} function, which runs the app. If
+#' automatically passed to the `print()` function, which runs the app. If
 #' this is called in the middle of a function, the value will not be passed to
-#' \code{print()} and the app will not be run. To make the app run, pass the app
-#' object to \code{print()} or \code{\link{runApp}()}.
+#' `print()` and the app will not be run. To make the app run, pass the app
+#' object to `print()` or [runApp()].
 #'
 #' @param ui The UI definition of the app (for example, a call to
-#'   \code{fluidPage()} with nested controls)
-#' @param server A server function
+#'   `fluidPage()` with nested controls).
+#'
+#'    If bookmarking is enabled (see `enableBookmarking`), this must be
+#'    a single argument function that returns the UI definition.
+#' @param server A function with three parameters: `input`, `output`, and
+#'   `session`. The function is called once for each session ensuring that each
+#'   app is independent.
 #' @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 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
+#'   This is only needed for `shinyAppObj`, since in the `shinyAppDir`
+#'   case, a `global.R` file can be used for this purpose.
+#' @param options Named options that should be passed to the `runApp` call
+#'   (these can be any of the following: "port", "launch.browser", "host", "quiet",
+#'   "display.mode" and "test.mode"). You can also specify `width` and
+#'   `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 `GET`
+#'   request to determine whether the `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.
+#' @param enableBookmarking Can be one of `"url"`, `"server"`, or
+#'   `"disable"`. The default value, `NULL`, will respect the setting from
+#'   any previous calls to  [enableBookmarking()]. See [enableBookmarking()]
+#'   for more information on bookmarking your app.
 #' @return An object that represents the app. Printing the object or passing it
-#'   to \code{\link{runApp}} will run the app.
+#'   to [runApp()] will run the app.
 #'
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   shinyApp(
 #'     ui = fluidPage(
 #'       numericInput("n", "n", 1),
@@ -66,10 +71,10 @@
 #'   runApp(app)
 #' }
 #' @export
-shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
-                     uiPattern="/", enableBookmarking = NULL) {
-  if (is.null(server)) {
-    stop("`server` missing from shinyApp")
+shinyApp <- function(ui, server, onStart=NULL, options=list(),
+                     uiPattern="/", enableBookmarking=NULL) {
+  if (!is.function(server)) {
+    stop("`server` must be a function", call. = FALSE)
   }
 
   # Ensure that the entire path is a match
@@ -137,10 +142,21 @@ shinyAppFile <- function(appFile, options=list()) {
 
 # 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.
+# appDir must be a normalized (absolute) path, not a relative one
 shinyAppDir_serverR <- function(appDir, options=list()) {
   # Most of the complexity here comes from needing to hot-reload if the .R files
   # change on disk, or are created, or are removed.
 
+  # In an upcoming version of shiny, this option will go away.
+  if (getOption("shiny.autoload.r", TRUE)) {
+    # Create a child env which contains all the helpers and will be the shared parent
+    # of the ui.R and server.R load.
+    sharedEnv <- new.env(parent = globalenv())
+  } else {
+    # old behavior
+    sharedEnv <- globalenv()
+  }
+
   # uiHandlerSource is a function that returns an HTTP handler for serving up
   # ui.R as a webpage. The "cachedFuncWithFile" call makes sure that the closure
   # we're creating here only gets executed when ui.R's contents change.
@@ -151,7 +167,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, envir = new.env(parent = globalenv()))
+        ui <- sourceUTF8(uiR, envir = new.env(parent = sharedEnv))
         if (!is.null(.globals$ui)) {
           ui <- .globals$ui[[1]]
         }
@@ -166,7 +182,14 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
   }
 
   wwwDir <- file.path.ci(appDir, "www")
+  if (dirExists(wwwDir)) {
+    staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE))
+  } else {
+    staticPaths <- list()
+  }
+
   fallbackWWWDir <- system.file("www-dir", package = "shiny")
+
   serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE,
     function(serverR) {
       # If server.R contains a call to shinyServer (which sets .globals$server),
@@ -174,7 +197,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       # server.R.
       .globals$server <- NULL
       on.exit(.globals$server <- NULL, add = TRUE)
-      result <- sourceUTF8(serverR, envir = new.env(parent = globalenv()))
+      result <- sourceUTF8(serverR, envir = new.env(parent = sharedEnv))
       if (!is.null(.globals$server)) {
         result <- .globals$server[[1]]
       }
@@ -205,10 +228,15 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     oldwd <<- getwd()
     setwd(appDir)
     monitorHandle <<- initAutoReloadMonitor(appDir)
-    if (file.exists(file.path.ci(appDir, "global.R")))
-      sourceUTF8(file.path.ci(appDir, "global.R"))
+    # TODO: we should support hot reloading on global.R and R/*.R changes.
+    if (getOption("shiny.autoload.r", TRUE)) {
+      loadSupport(appDir, renv=sharedEnv, globalrenv=globalenv())
+    }  else {
+      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
@@ -216,10 +244,17 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 
   structure(
     list(
+      staticPaths = staticPaths,
+      # Even though the wwwDir is handled as a static path, we need to include
+      # it here to be handled by R as well. This is because the special case
+      # of index.html: it is specifically not handled as a staticPath for
+      # reasons explained above, but if someone does want to serve up an
+      # index.html, we need to handle it, and we do it by using the
+      # staticHandler in the R code path. (#2380)
       httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = serverFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
+      onStop = onStop,
       options = options
     ),
     class = "shiny.appobj"
@@ -231,13 +266,13 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 # ignored when checking extensions. If any changes are detected, all connected
 # Shiny sessions are reloaded.
 #
-# Use option(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
+# Use options(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
 # for changes is expensive (we are polling for mtimes here, nothing fancy) this
 # feature is intended only for development.
 #
 # You can customize the file patterns Shiny will monitor by setting the
 # shiny.autoreload.pattern option. For example, to monitor only ui.R:
-# option(shiny.autoreload.pattern = glob2rx("ui.R"))
+# options(shiny.autoreload.pattern = glob2rx("ui.R"))
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
@@ -249,7 +284,8 @@ initAutoReloadMonitor <- function(dir) {
     ".*\\.(r|html?|js|css|png|jpe?g|gif)$")
 
   lastValue <- NULL
-  obs <- observe({
+  observeLabel <- paste0("File Auto-Reload - '", basename(dir), "'")
+  obs <- observe(label = observeLabel, {
     files <- sort(list.files(dir, pattern = filePattern, recursive = TRUE,
       ignore.case = TRUE))
     times <- file.info(files)$mtime
@@ -272,18 +308,81 @@ initAutoReloadMonitor <- function(dir) {
   obs$destroy
 }
 
+#' Load an app's supporting R files
+#'
+#' Loads all of the supporting R files of a Shiny application. Specifically,
+#' this function loads any top-level supporting `.R` files in the `R/` directory
+#' adjacent to the `app.R`/`server.R`/`ui.R` files.
+#'
+#' Since Shiny 1.5.0, this function is called by default when running an
+#' application. If it causes problems, there are two ways to opt out. You can
+#' either place a file named `_disable_autoload.R` in your R/ directory, or
+#' set `options(shiny.autoload.r=FALSE)`. If you set this option, it will
+#' affect any application that runs later in the same R session, potentially
+#' breaking it, so after running your application, you should unset option with
+#' `options(shiny.autoload.r=NULL)`
+#'
+#' @details The files are sourced in alphabetical order (as determined by
+#'   [list.files]). `global.R` is evaluated before the supporting R files in the
+#'   `R/` directory.
+#' @param appDir The application directory
+#' @param renv The environmeny in which the files in the `R/` directory should
+#'   be evaluated.
+#' @param globalrenv The environment in which `global.R` should be evaluated. If
+#'   `NULL`, `global.R` will not be evaluated at all.
+#' @export
+loadSupport <- function(appDir, renv=new.env(parent=globalenv()), globalrenv=globalenv()){
+  if (!is.null(globalrenv)){
+    # Evaluate global.R, if it exists.
+    if (file.exists(file.path.ci(appDir, "global.R"))){
+      sourceUTF8(file.path.ci(appDir, "global.R"), envir=globalrenv)
+    }
+  }
+
+  helpersDir <- file.path(appDir, "R")
+
+  disabled <- list.files(helpersDir, pattern="^_disable_autoload\\.r$", recursive=FALSE, ignore.case=TRUE)
+  if (length(disabled) > 0){
+    message("R/_disable_autoload.R detected; not loading the R/ directory automatically")
+    return(invisible(renv))
+  }
+
+  helpers <- list.files(helpersDir, pattern="\\.[rR]$", recursive=FALSE, full.names=TRUE)
+
+  if (length(helpers) > 0){
+    message("Automatically loading ", length(helpers), " .R file",
+            ifelse(length(helpers) != 1, "s", ""),
+            " found in the R/ directory.\nSee https://rstd.io/shiny-autoload for more info.")
+  }
+
+  lapply(helpers, sourceUTF8, envir=renv)
+
+  invisible(renv)
+}
+
 # This reads in an app dir for a single-file application (e.g. app.R), and
 # returns a shiny.appobj.
+# appDir must be a normalized (absolute) path, not a relative one
 shinyAppDir_appR <- function(fileName, appDir, options=list())
 {
   fullpath <- file.path.ci(appDir, fileName)
 
+  # In an upcoming version of shiny, this option will go away.
+  if (getOption("shiny.autoload.r", TRUE)) {
+    # Create a child env which contains all the helpers and will be the shared parent
+    # of the ui.R and server.R load.
+    sharedEnv <- new.env(parent = globalenv())
+  } else {
+    sharedEnv <- globalenv()
+  }
+
+
   # 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, fileName, case.sensitive = FALSE,
     function(appR) {
-      result <- sourceUTF8(fullpath, envir = new.env(parent = globalenv()))
+      result <- sourceUTF8(fullpath, envir = new.env(parent = sharedEnv))
 
       if (!is.shiny.appobj(result))
         stop("app.R did not return a shiny.appobj object.")
@@ -305,6 +404,20 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
   }
 
   wwwDir <- file.path.ci(appDir, "www")
+  if (dirExists(wwwDir)) {
+    # wwwDir is a static path served by httpuv. It does _not_ serve up
+    # index.html, for two reasons. (1) It's possible that the user's
+    # www/index.html file is not actually used as the index, but as a template
+    # that gets processed before being sent; and (2) the index content may be
+    # modified by the hosting environment (as in SockJSAdapter.R).
+    #
+    # The call to staticPath normalizes the path, so that if the working dir
+    # later changes, it will continue to point to the right place.
+    staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE))
+  } else {
+    staticPaths <- list()
+  }
+
   fallbackWWWDir <- system.file("www-dir", package = "shiny")
 
   oldwd <- NULL
@@ -312,9 +425,14 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
+    # TODO: we should support hot reloading on R/*.R changes.
+    if (getOption("shiny.autoload.r", TRUE)) {
+      loadSupport(appDir, renv=sharedEnv, globalrenv=NULL)
+    }
     monitorHandle <<- initAutoReloadMonitor(appDir)
+    if (!is.null(appObj()$onStart)) appObj()$onStart()
   }
-  onEnd <- function() {
+  onStop <- function() {
     setwd(oldwd)
     monitorHandle()
     monitorHandle <<- NULL
@@ -322,10 +440,22 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
 
   structure(
     list(
+      # fallbackWWWDir is _not_ listed in staticPaths, because it needs to
+      # come after the uiHandler. It also does not need to be fast, since it
+      # should rarely be hit. The order is wwwDir (in staticPaths), then
+      # uiHandler, then falbackWWWDir (which is served up by the R
+      # staticHandler function).
+      staticPaths = staticPaths,
+      # Even though the wwwDir is handled as a static path, we need to include
+      # it here to be handled by R as well. This is because the special case
+      # of index.html: it is specifically not handled as a staticPath for
+      # reasons explained above, but if someone does want to serve up an
+      # index.html, we need to handle it, and we do it by using the
+      # staticHandler in the R code path. (#2380)
       httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = dynServerFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
+      onStop = onStop,
       options = options
     ),
     class = "shiny.appobj"
@@ -333,26 +463,34 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
 }
 
 
-#' @rdname shinyApp
+#' Shiny App object
+#'
+#' Internal methods for the `shiny.appobj` S3 class.
+#'
+#' @keywords internal
+#' @name shiny.appobj
+NULL
+
+#' @rdname shiny.appobj
 #' @param x Object to convert to a Shiny app.
 #' @export
 as.shiny.appobj <- function(x) {
   UseMethod("as.shiny.appobj", x)
 }
 
-#' @rdname shinyApp
+#' @rdname shiny.appobj
 #' @export
 as.shiny.appobj.shiny.appobj <- function(x) {
   x
 }
 
-#' @rdname shinyApp
+#' @rdname shiny.appobj
 #' @export
 as.shiny.appobj.list <- function(x) {
   shinyApp(ui = x$ui, server = x$server)
 }
 
-#' @rdname shinyApp
+#' @rdname shiny.appobj
 #' @export
 as.shiny.appobj.character <- function(x) {
   if (identical(tolower(tools::file_ext(x)), "r"))
@@ -361,26 +499,28 @@ as.shiny.appobj.character <- function(x) {
     shinyAppDir(x)
 }
 
-#' @rdname shinyApp
+#' @rdname shiny.appobj
 #' @export
 is.shiny.appobj <- function(x) {
   inherits(x, "shiny.appobj")
 }
 
-#' @rdname shinyApp
+#' @rdname shiny.appobj
 #' @param ... Additional parameters to be passed to print.
 #' @export
 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
+#' @rdname shiny.appobj
 #' @method as.tags shiny.appobj
 #' @export
 as.tags.shiny.appobj <- function(x, ...) {
@@ -434,7 +574,6 @@ shiny_rmd_warning <- function() {
 }
 
 #' @rdname knitr_methods
-#' @export
 knit_print.shiny.appobj <- function(x, ...) {
   opts <- x$options %OR% list()
   width <- if (is.null(opts$width)) "100%" else opts$width
@@ -471,7 +610,6 @@ knit_print.shiny.appobj <- function(x, ...) {
 # calling output$value <- renderFoo(...) and fooOutput().
 #' @rdname knitr_methods
 #' @param inline Whether the object is printed inline.
-#' @export
 knit_print.shiny.render.function <- function(x, ..., inline = FALSE) {
   x <- htmltools::as.tags(x, inline = inline)
   output <- knitr::knit_print(tagList(x))
@@ -484,7 +622,6 @@ knit_print.shiny.render.function <- function(x, ..., inline = FALSE) {
 # 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({

R/bookmark-state.R

@@ -349,7 +349,7 @@ RestoreContext <- R6Class("RestoreContext",
         mapply(names(vals), vals, SIMPLIFY = FALSE,
           FUN = function(name, value) {
             tryCatch(
-              jsonlite::fromJSON(value),
+              safeFromJSON(value),
               error = function(e) {
                 stop("Failed to parse URL parameter \"", name, "\"")
               }
@@ -362,7 +362,7 @@ RestoreContext <- R6Class("RestoreContext",
       self$input <- RestoreInputSet$new(inputs)
 
       values <- valuesFromJSON(values)
-      self$values <- list2env(values, self$values)
+      self$values <- list2env2(values, self$values)
     }
   )
 )
@@ -385,7 +385,7 @@ RestoreInputSet <- R6Class("RestoreInputSet",
 
   public = list(
     initialize = function(values) {
-      private$values <- list2env(values, parent = emptyenv())
+      private$values <- list2env2(values, parent = emptyenv())
     },
 
     exists = function(name) {
@@ -426,7 +426,7 @@ RestoreInputSet <- R6Class("RestoreInputSet",
     },
 
     asList = function() {
-      as.list.environment(private$values)
+      as.list.environment(private$values, all.names = TRUE)
     }
   )
 )
@@ -448,14 +448,30 @@ withRestoreContext <- function(ctx, expr) {
 
 # Is there a current restore context?
 hasCurrentRestoreContext <- function() {
-  restoreCtxStack$size() > 0
+  if (restoreCtxStack$size() > 0)
+    return(TRUE)
+  domain <- getDefaultReactiveDomain()
+  if (!is.null(domain) && !is.null(domain$restoreContext))
+    return(TRUE)
+  
+  return(FALSE)
 }
 
-# Call to access the current restore context
+# Call to access the current restore context. First look on the restore
+# context stack, and if not found, then see if there's one on the current
+# reactive domain. In practice, the only time there will be a restore context
+# on the stack is when executing the UI function; when executing server code,
+# the restore context will be attached to the domain/session.
 getCurrentRestoreContext <- function() {
   ctx <- restoreCtxStack$peek()
   if (is.null(ctx)) {
-    stop("No restore context found")
+    domain <- getDefaultReactiveDomain()
+
+    if (is.null(domain) || is.null(domain$restoreContext)) {
+      stop("No restore context found")
+    }
+
+    ctx <- domain$restoreContext
   }
   ctx
 }
@@ -463,7 +479,7 @@ getCurrentRestoreContext <- function() {
 #' Restore an input value
 #'
 #' This restores an input value from the current restore context. It should be
-#' called early on inside of input functions (like \code{\link{textInput}}).
+#' called early on inside of input functions (like [textInput()]).
 #'
 #' @param id Name of the input value to restore.
 #' @param default A default value to use, if there's no value to restore.
@@ -493,17 +509,95 @@ restoreInput <- function(id, default) {
 #' It typically is called from an observer. Note that this will not work in
 #' Internet Explorer 9 and below.
 #'
+#' For `mode = "push"`, only three updates are currently allowed:
+#' \enumerate{
+#'   \item the query string (format: `?param1=val1&param2=val2`)
+#'   \item the hash (format: `#hash`)
+#'   \item both the query string and the hash
+#'     (format: `?param1=val1&param2=val2#hash`)
+#' }
+#'
+#' In other words, if `mode = "push"`, the `queryString` must start
+#' with either `?` or with `#`.
+#'
+#' A technical curiosity: under the hood, this function is calling the HTML5
+#' history API (which is where the names for the `mode` argument come from).
+#' When `mode = "replace"`, the function called is
+#' `window.history.replaceState(null, null, queryString)`.
+#' When `mode = "push"`, the function called is
+#' `window.history.pushState(null, null, queryString)`.
+#'
 #' @param queryString The new query string to show in the location bar.
+#' @param mode When the query string is updated, should the the current history
+#'   entry be replaced (default), or should a new history entry be pushed onto
+#'   the history stack? The former should only be used in a live bookmarking
+#'   context. The latter is useful if you want to navigate between states using
+#'   the browser's back and forward buttons. See Examples.
 #' @param session A Shiny session object.
-#' @seealso \code{\link{enableBookmarking}} for examples.
+#' @seealso [enableBookmarking()], [getQueryString()]
+#' @examples
+#' ## Only run these examples in interactive sessions
+#' if (interactive()) {
+#'
+#'   ## App 1: Doing "live" bookmarking
+#'   ## Update the browser's location bar every time an input changes.
+#'   ## This should not be used with enableBookmarking("server"),
+#'   ## because that would create a new saved state on disk every time
+#'   ## the user changes an input.
+#'   enableBookmarking("url")
+#'   shinyApp(
+#'     ui = function(req) {
+#'       fluidPage(
+#'         textInput("txt", "Text"),
+#'         checkboxInput("chk", "Checkbox")
+#'       )
+#'     },
+#'     server = function(input, output, session) {
+#'       observe({
+#'         # Trigger this observer every time an input changes
+#'         reactiveValuesToList(input)
+#'         session$doBookmark()
+#'       })
+#'       onBookmarked(function(url) {
+#'         updateQueryString(url)
+#'       })
+#'     }
+#'   )
+#'
+#'   ## App 2: 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)
+#'       })
+#'     }
+#'   )
+#' }
 #' @export
-updateQueryString <- function(queryString, session = getDefaultReactiveDomain()) {
-  session$updateQueryString(queryString)
+updateQueryString <- function(queryString, mode = c("replace", "push"),
+                              session = getDefaultReactiveDomain()) {
+  mode <- match.arg(mode)
+  session$updateQueryString(queryString, mode)
 }
 
 #' Create a button for bookmarking/sharing
 #'
-#' A \code{bookmarkButton} is a \code{\link{actionButton}} with a default label
+#' A `bookmarkButton` is a [actionButton()] with a default label
 #' that consists of a link icon and the text "Bookmark...". It is meant to be
 #' used for bookmarking state.
 #'
@@ -513,10 +607,10 @@ updateQueryString <- function(queryString, session = getDefaultReactiveDomain())
 #' @param id An ID for the bookmark button. The only time it is necessary to set
 #'   the ID unless you have more than one bookmark button in your application.
 #'   If you specify an input ID, it should be excluded from bookmarking with
-#'   \code{\link{setBookmarkExclude}}, and you must create an observer that
+#'   [setBookmarkExclude()], and you must create an observer that
 #'   does the bookmarking when the button is pressed. See the examples below.
 #'
-#' @seealso \code{\link{enableBookmarking}} for more examples.
+#' @seealso [enableBookmarking()] for more examples.
 #'
 #' @examples
 #' ## Only run these examples in interactive sessions
@@ -566,10 +660,10 @@ bookmarkButton <- function(label = "Bookmark...",
 
 #' Generate a modal dialog that displays a URL
 #'
-#' The modal dialog generated by \code{urlModal} will display the URL in a
+#' The modal dialog generated by `urlModal` will display the URL in a
 #' textarea input, and the URL text will be selected so that it can be easily
-#' copied. The result from \code{urlModal} should be passed to the
-#' \code{\link{showModal}} function to display it in the browser.
+#' copied. The result from `urlModal` should be passed to the
+#' [showModal()] function to display it in the browser.
 #'
 #' @param url A URL to display in the dialog box.
 #' @param title A title for the dialog box.
@@ -625,8 +719,8 @@ urlModal <- function(url, title = "Bookmarked application link", subtitle = NULL
 
 #' Display a modal dialog for bookmarking
 #'
-#' This is a wrapper function for \code{\link{urlModal}} that is automatically
-#' called if an application is bookmarked but no other \code{\link{onBookmark}}
+#' This is a wrapper function for [urlModal()] that is automatically
+#' called if an application is bookmarked but no other [onBookmark()]
 #' callback was set. It displays a modal dialog with the bookmark URL, along
 #' with a subtitle that is appropriate for the type of bookmarking used ("url"
 #' or "server").
@@ -667,8 +761,8 @@ showBookmarkUrlModal <- function(url) {
 #' @details
 #'
 #' For restoring state to work properly, the UI must be a function that takes
-#' one argument, \code{request}. In most Shiny applications, the UI is not a
-#' function; it might have the form \code{fluidPage(....)}. Converting it to a
+#' one argument, `request`. In most Shiny applications, the UI is not a
+#' function; it might have the form `fluidPage(....)`. Converting it to a
 #' function is as simple as wrapping it in a function, as in
 #' \code{function(request) \{ fluidPage(....) \}}.
 #'
@@ -677,17 +771,17 @@ showBookmarkUrlModal <- function(url) {
 #' but not if the state is encoded in a URL.
 #'
 #' When bookmarking state, arbitrary values can be stored, by passing a function
-#' as the \code{onBookmark} argument. That function will be passed a
-#' \code{ShinySaveState} object. The \code{values} field of the object is a list
+#' as the `onBookmark` argument. That function will be passed a
+#' `ShinySaveState` object. The `values` field of the object is a list
 #' which can be manipulated to save extra information. Additionally, if the
-#' state is being saved on the server, and the \code{dir} field of that object
+#' state is being saved on the server, and the `dir` field of that object
 #' can be used to save extra information to files in that directory.
 #'
 #' For saved-to-server state, this is how the state directory is chosen:
 #' \itemize{
 #'   \item If running in a hosting environment such as Shiny Server or
 #'     Connect, the hosting environment will choose the directory.
-#'   \item If running an app in a directory with \code{\link{runApp}()}, the
+#'   \item If running an app in a directory with [runApp()], the
 #'     saved states will be saved in a subdirectory of the app called
 #'    shiny_bookmarks.
 #'   \item If running a Shiny app object that is generated from code (not run
@@ -695,22 +789,22 @@ showBookmarkUrlModal <- function(url) {
 #'     the current working directory called shiny_bookmarks.
 #' }
 #'
-#' When used with \code{\link{shinyApp}()}, this function must be called before
-#' \code{shinyApp()}, or in the \code{shinyApp()}'s \code{onStart} function. An
-#' alternative to calling the \code{enableBookmarking()} function is to use the
-#' \code{enableBookmarking} \emph{argument} for \code{shinyApp()}. See examples
+#' When used with [shinyApp()], this function must be called before
+#' `shinyApp()`, or in the `shinyApp()`'s `onStart` function. An
+#' alternative to calling the `enableBookmarking()` function is to use the
+#' `enableBookmarking` *argument* for `shinyApp()`. See examples
 #' below.
 #'
-#' @param store Either \code{"url"}, which encodes all of the relevant values in
-#'   a URL, \code{"server"}, which saves to disk on the server, or
-#'   \code{"disable"}, which disables any previously-enabled bookmarking.
+#' @param store Either `"url"`, which encodes all of the relevant values in
+#'   a URL, `"server"`, which saves to disk on the server, or
+#'   `"disable"`, which disables any previously-enabled bookmarking.
 #'
-#' @seealso \code{\link{onBookmark}}, \code{\link{onBookmarked}},
-#'   \code{\link{onRestore}}, and \code{\link{onRestored}} for registering
+#' @seealso [onBookmark()], [onBookmarked()],
+#'   [onRestore()], and [onRestored()] for registering
 #'   callback functions that are invoked when the state is bookmarked or
 #'   restored.
 #'
-#'   Also see \code{\link{updateQueryString}}.
+#'   Also see [updateQueryString()].
 #'
 #' @export
 #' @examples
@@ -889,7 +983,7 @@ enableBookmarking <- function(store = c("url", "server", "disable")) {
 #' @param names A character vector containing names of inputs to exclude from
 #'   bookmarking.
 #' @param session A shiny session object.
-#' @seealso \code{\link{enableBookmarking}} for examples.
+#' @seealso [enableBookmarking()] for examples.
 #' @export
 setBookmarkExclude <- function(names = character(0), session = getDefaultReactiveDomain()) {
   session$setBookmarkExclude(names)
@@ -904,17 +998,17 @@ setBookmarkExclude <- function(names = character(0), session = getDefaultReactiv
 #' should be called within an application's server function.
 #'
 #' \itemize{
-#'   \item \code{onBookmark} registers a function that will be called just
+#'   \item `onBookmark` registers a function that will be called just
 #'     before Shiny bookmarks state.
-#'   \item \code{onBookmarked} registers a function that will be called just
+#'   \item `onBookmarked` registers a function that will be called just
 #'     after Shiny bookmarks state.
-#'   \item \code{onRestore} registers a function that will be called when a
+#'   \item `onRestore` registers a function that will be called when a
 #'     session is restored, after the server function executes, but before all
 #'     other reactives, observers and render functions are run.
-#'   \item \code{onRestored} registers a function that will be called after a
-#'     session is restored. This is similar to \code{onRestore}, but it will be
+#'   \item `onRestored` registers a function that will be called after a
+#'     session is restored. This is similar to `onRestore`, but it will be
 #'     called after all reactives, observers, and render functions run, and
-#'     after results are sent to the client browser. \code{onRestored}
+#'     after results are sent to the client browser. `onRestored`
 #'     callbacks can be useful for sending update messages to the client
 #'     browser.
 #' }
@@ -925,25 +1019,25 @@ setBookmarkExclude <- function(names = character(0), session = getDefaultReactiv
 #' arguments to cancel the registration.
 #'
 #' The callback function that is passed to these functions should take one
-#' argument, typically named "state" (for \code{onBookmark}, \code{onRestore},
-#' and \code{onRestored}) or "url" (for \code{onBookmarked}).
+#' argument, typically named "state" (for `onBookmark`, `onRestore`,
+#' and `onRestored`) or "url" (for `onBookmarked`).
 #'
-#' For \code{onBookmark}, the state object has three relevant fields. The
-#' \code{values} field is an environment which can be used to save arbitrary
+#' For `onBookmark`, the state object has three relevant fields. The
+#' `values` field is an environment which can be used to save arbitrary
 #' values (see examples). If the state is being saved to disk (as opposed to
-#' being encoded in a URL), the \code{dir} field contains the name of a
+#' being encoded in a URL), the `dir` field contains the name of a
 #' directory which can be used to store extra files. Finally, the state object
-#' has an \code{input} field, which is simply the application's \code{input}
+#' has an `input` field, which is simply the application's `input`
 #' object. It can be read, but not modified.
 #'
-#' For \code{onRestore} and \code{onRestored}, the state object is a list. This
-#' list contains \code{input}, which is a named list of input values to restore,
-#' \code{values}, which is an environment containing arbitrary values that were
-#' saved in \code{onBookmark}, and \code{dir}, the name of the directory that
+#' For `onRestore` and `onRestored`, the state object is a list. This
+#' list contains `input`, which is a named list of input values to restore,
+#' `values`, which is an environment containing arbitrary values that were
+#' saved in `onBookmark`, and `dir`, the name of the directory that
 #' the state is being restored from, and which could have been used to save
 #' extra files.
 #'
-#' For \code{onBookmarked}, the callback function receives a string with the
+#' For `onBookmarked`, the callback function receives a string with the
 #' bookmark URL. This callback function should be used to display UI in the
 #' client browser with the bookmark URL. If no callback function is registered,
 #' then Shiny will by default display a modal dialog with the bookmark URL.

R/bootstrap-deprecated.R

@@ -0,0 +1,47 @@
+#' Create a page with a sidebar
+#'
+#' **DEPRECATED**: use [fluidPage()] and [sidebarLayout()] instead.
+#'
+#' @param headerPanel The [headerPanel] with the application title
+#' @param sidebarPanel The [sidebarPanel] containing input controls
+#' @param mainPanel The [mainPanel] containing outputs
+#' @keywords internal
+#' @return A UI defintion that can be passed to the [shinyUI] function
+#' @export
+pageWithSidebar <- function(headerPanel,
+                            sidebarPanel,
+                            mainPanel) {
+
+  bootstrapPage(
+    # basic application container divs
+    div(
+      class="container-fluid",
+      div(class="row",
+          headerPanel
+      ),
+      div(class="row",
+          sidebarPanel,
+          mainPanel
+      )
+    )
+  )
+}
+
+#' Create a header panel
+#'
+#' **DEPRECATED**: use [titlePanel()] instead.
+#'
+#' @param title An application title to display
+#' @param windowTitle The title that should be displayed by the browser window.
+#'   Useful if `title` is not a string.
+#' @return A headerPanel that can be passed to [pageWithSidebar]
+#' @keywords internal
+#' @export
+headerPanel <- function(title, windowTitle=title) {
+  tagList(
+    tags$head(tags$title(windowTitle)),
+    div(class="col-sm-12",
+      h1(title)
+    )
+  )
+}

R/bootstrap-layout.R

@@ -10,25 +10,26 @@
 #'
 #' @param ... Elements to include within the page
 #' @param title The browser window title (defaults to the host URL of the page).
-#'   Can also be set as a side effect of the \code{\link{titlePanel}} function.
+#'   Can also be set as a side effect of the [titlePanel()] function.
 #' @param responsive This option is deprecated; it is no longer optional with
 #'   Bootstrap 3.
 #' @param theme Alternative Bootstrap stylesheet (normally a css file within the
 #'   www directory). For example, to use the theme located at
-#'   \code{www/bootstrap.css} you would use \code{theme = "bootstrap.css"}.
+#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
 #'
-#' @return A UI defintion that can be passed to the \link{shinyUI} function.
+#' @return A UI defintion that can be passed to the [shinyUI] function.
 #'
-#' @details To create a fluid page use the \code{fluidPage} function and include
-#'   instances of \code{fluidRow} and \code{\link{column}} within it. As an
+#' @details To create a fluid page use the `fluidPage` function and include
+#'   instances of `fluidRow` and [column()] within it. As an
 #'   alternative to low-level row and column functions you can also use
-#'   higher-level layout functions like \code{\link{sidebarLayout}}.
+#'   higher-level layout functions like [sidebarLayout()].
 #'
-#' @note See the \href{http://shiny.rstudio.com/articles/layout-guide.html}{
-#'   Shiny-Application-Layout-Guide} for additional details on laying out fluid
+#' @note See the [
+#'   Shiny-Application-Layout-Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fluid
 #'   pages.
 #'
-#' @seealso \code{\link{column}}, \code{\link{sidebarLayout}}
+#' @family layout functions
+#' @seealso [column()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -116,21 +117,23 @@ fluidRow <- function(...) {
 #'   Bootstrap 3.
 #' @param theme Alternative Bootstrap stylesheet (normally a css file within the
 #'   www directory). For example, to use the theme located at
-#'   \code{www/bootstrap.css} you would use \code{theme = "bootstrap.css"}.
+#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
 #'
-#' @return A UI defintion that can be passed to the \link{shinyUI} function.
+#' @return A UI defintion that can be passed to the [shinyUI] function.
 #'
-#' @details To create a fixed page use the \code{fixedPage} function and include
-#'   instances of \code{fixedRow} and \code{\link{column}} within it. Note that
-#'   unlike \code{\link{fluidPage}}, fixed pages cannot make use of higher-level
-#'   layout functions like \code{sidebarLayout}, rather, all layout must be done
-#'   with \code{fixedRow} and \code{column}.
+#' @details To create a fixed page use the `fixedPage` function and include
+#'   instances of `fixedRow` and [column()] within it. Note that
+#'   unlike [fluidPage()], fixed pages cannot make use of higher-level
+#'   layout functions like `sidebarLayout`, rather, all layout must be done
+#'   with `fixedRow` and `column`.
 #'
-#' @note See the \href{http://shiny.rstudio.com/articles/layout-guide.html}{
-#'   Shiny Application Layout Guide} for additional details on laying out fixed
+#' @note See the [
+#'   Shiny Application Layout Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fixed
 #'   pages.
 #'
-#' @seealso \code{\link{column}}
+#' @family layout functions
+#'
+#' @seealso [column()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -169,8 +172,8 @@ fixedRow <- function(...) {
 
 #' Create a column within a UI definition
 #'
-#' Create a column for use within a  \code{\link{fluidRow}} or
-#' \code{\link{fixedRow}}
+#' Create a column for use within a  [fluidRow()] or
+#' [fixedRow()]
 #'
 #' @param width The grid width of the column (must be between 1 and 12)
 #' @param ... Elements to include within the column
@@ -178,10 +181,10 @@ fixedRow <- function(...) {
 #'   previous column.
 #'
 #' @return A column that can be included within a
-#'   \code{\link{fluidRow}} or \code{\link{fixedRow}}.
+#'   [fluidRow()] or [fixedRow()].
 #'
 #'
-#' @seealso \code{\link{fluidRow}}, \code{\link{fixedRow}}.
+#' @seealso [fluidRow()], [fixedRow()].
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -228,8 +231,12 @@ column <- function(width, ..., offset = 0) {
     stop("column width must be between 1 and 12")
 
   colClass <- paste0("col-sm-", width)
-  if (offset > 0)
-    colClass <- paste0(colClass, " col-sm-offset-", offset)
+  if (offset > 0) {
+    # offset-md-x is for bootstrap 4 forward compat
+    # (every size tier has been bumped up one level)
+    # https://github.com/twbs/bootstrap/blob/74b8fe7/docs/4.3/migration/index.html#L659
+    colClass <- paste0(colClass, " offset-md-", offset, " col-sm-offset-", offset)
+  }
   div(class = colClass, ...)
 }
 
@@ -240,10 +247,9 @@ column <- function(width, ..., offset = 0) {
 #' @param windowTitle The title that should be displayed by the browser window.
 #'
 #' @details Calling this function has the side effect of including a
-#'   \code{title} tag within the head. You can also specify a page title
+#'   `title` tag within the head. You can also specify a page title
 #'   explicitly using the `title` parameter of the top-level page function.
 #'
-#'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
@@ -263,20 +269,28 @@ titlePanel <- function(title, windowTitle=title) {
 
 #' Layout a sidebar and main area
 #'
-#' Create a layout with a sidebar and main area. The sidebar is displayed with a
-#' distinct background color and typically contains input controls. The main
+#' Create a layout (`sidebarLayout()`) with a sidebar (`sidebarPanel()`) and
+#' main area (`mainPanel()`). The sidebar is displayed with a distinct
+#' background color and typically contains input controls. The main
 #' area occupies 2/3 of the horizontal width and typically contains outputs.
 #'
-#' @param sidebarPanel The \link{sidebarPanel} containing input controls
-#' @param mainPanel The \link{mainPanel} containing outputs
+#' @param sidebarPanel The `sidebarPanel()` containing input controls.
+#' @param mainPanel The `mainPanel()` containing outputs.
 #' @param position The position of the sidebar relative to the main area ("left"
-#'   or "right")
-#' @param fluid \code{TRUE} to use fluid layout; \code{FALSE} to use fixed
+#'   or "right").
+#' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
 #'   layout.
+#' @param width The width of the sidebar and main panel. By default, the
+#'   sidebar takes up 1/3 of the width, and the main panel 2/3. The total
+#'   width must be 12 or less.
+#' @param ... Output elements to include in the sidebar/main panel.
+#'
+#' @family layout functions
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' # Define UI
 #' ui <- fluidPage(
@@ -336,16 +350,34 @@ sidebarLayout <- function(sidebarPanel,
     fixedRow(firstPanel, secondPanel)
 }
 
+#' @export
+#' @rdname sidebarLayout
+sidebarPanel <- function(..., width = 4) {
+  div(class=paste0("col-sm-", width),
+    tags$form(class="well",
+      ...
+    )
+  )
+}
+
+#' @export
+#' @rdname sidebarLayout
+mainPanel <- function(..., width = 8) {
+  div(class=paste0("col-sm-", width),
+    ...
+  )
+}
+
 #' Lay out UI elements vertically
 #'
 #' Create a container that includes one or more rows of content (each element
 #' passed to the container will appear on it's own line in the UI)
 #'
 #' @param ... Elements to include within the container
-#' @param fluid \code{TRUE} to use fluid layout; \code{FALSE} to use fixed
+#' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
 #'   layout.
 #'
-#' @seealso \code{\link{fluidPage}}, \code{\link{flowLayout}}
+#' @family layout functions
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -376,14 +408,14 @@ 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.
-#' \code{\link{plotOutput}} at its default setting of \code{width = "100\%"}).
+#' [plotOutput()] at its default setting of `width = "100%"`).
 #'
 #' @param ... Unnamed arguments will become child elements of the layout. Named
 #'   arguments will become HTML attributes on the outermost tag.
 #' @param cellArgs Any additional attributes that should be used for each cell
 #'   of the layout.
 #'
-#' @seealso \code{\link{verticalLayout}}
+#' @family layout functions
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -414,7 +446,7 @@ flowLayout <- function(..., cellArgs = list()) {
 
 #' Input panel
 #'
-#' A \code{\link{flowLayout}} with a grey border and light grey background,
+#' A [flowLayout()] with a grey border and light grey background,
 #' suitable for wrapping inputs.
 #'
 #' @param ... Input controls or other HTML elements.
@@ -434,14 +466,17 @@ inputPanel <- function(...) {
 #'   arguments will become HTML attributes on the outermost tag.
 #' @param cellWidths Character or numeric vector indicating the widths of the
 #'   individual cells. Recycling will be used if needed. Character values will
-#'   be interpreted as CSS lengths (see \code{\link{validateCssUnit}}), numeric
+#'   be interpreted as CSS lengths (see [validateCssUnit()]), numeric
 #'   values as pixels.
 #' @param cellArgs Any additional attributes that should be used for each cell
 #'   of the layout.
 #'
+#' @family layout functions
+#'
 #' @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) {
@@ -507,41 +542,41 @@ splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 #'
 #' 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
+#' proportional-grid layouts. **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
+#' @details If you try to use `fillRow` and `fillCol` inside of other
+#'   Shiny containers, such as [sidebarLayout()],
+#'   [navbarPage()], or even `tags$div`, you will probably find
+#'   that they will not appear. This is due to `fillRow` and `fillCol`
+#'   defaulting to `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}
+#'     \item only use `fillRow`/`fillCol` inside of `fillPage`,
+#'       `fillRow`, or `fillCol`
+#'     \item provide an explicit `height` argument to
+#'       `fillRow`/`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
+#'   [tagList()] or [div()] to combine them.) Named
+#'   arguments will be used as attributes on the `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
+#'   single value like `1` or `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
+#'   `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
+#'   entire row/column. For the default height of `"100%"` to be
+#'   effective, the parent must be `fillPage`, another
+#'   `fillRow`/`fillCol`, or some other HTML element whose height is
 #'   not determined by the height of its contents.
 #'
 #' @examples
@@ -586,7 +621,7 @@ flexfill <- function(..., direction, flex, width = width, height = height) {
   }
 
   if (length(flex) > length(children)) {
-    flex <- flex[1:length(children)]
+    flex <- flex[seq_along(children)]
   }
 
   # The dimension along the main axis

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 `get()`
+#' and `set()` methods. Objects are automatically pruned from the cache
+#' according to the parameters `max_size`, `max_age`, `max_n`,
+#' and `evict`.
+#'
+#'
+#' @section Missing Keys:
+#'
+#'   The `missing` and `exec_missing` parameters controls what happens
+#'   when `get()` is called with a key that is not in the cache (a cache
+#'   miss). The default behavior is to return a [key_missing()]
+#'   object. This is a *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 [is.key_missing()] function. You can
+#'   also have `get()` return a different sentinel value, like `NULL`.
+#'   If you want to throw an error on a cache miss, you can do so by providing a
+#'   function for `missing` that takes one argument, the key, and also use
+#'   `exec_missing=TRUE`.
+#'
+#'   When the cache is created, you can supply a value for `missing`, which
+#'   sets the default value to be returned for missing values. It can also be
+#'   overridden when `get()` is called, by supplying a `missing`
+#'   argument. For example, if you use `cache$get("mykey", missing =
+#'   NULL)`, it will return `NULL` if the key is not in the cache.
+#'
+#'   If your cache is configured so that `get()` returns a sentinel value
+#'   to represent a cache miss, then `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 `get()` encounters missing
+#'   key. If the function returns a value, then `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 `get()` will not return a value.
+#'
+#'   To do this, pass a one-argument function to `missing`, and use
+#'   `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 `get()` should be wrapped with
+#'   [tryCatch()] to gracefully handle missing keys.
+#'
+#' @section Cache pruning:
+#'
+#'   Cache pruning occurs when `set()` is called, or it can be invoked
+#'   manually by calling `prune()`.
+#'
+#'   The disk cache will throttle the pruning so that it does not happen on
+#'   every call to `set()`, because the filesystem operations for checking
+#'   the status of files can be slow. Instead, it will prune once in every 20
+#'   calls to `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
+#'   `max_age`, they will be removed.
+#'
+#'   The `max_size` and `max_n` parameters are applied to the cache as
+#'   a whole, in contrast to `max_age`, which is applied to each object
+#'   individually.
+#'
+#'   If the number of objects in the cache exceeds `max_n`, then objects
+#'   will be removed from the cache according to the eviction policy, which is
+#'   set with the `evict` parameter. Objects will be removed so that the
+#'   number of items is `max_n`.
+#'
+#'   If the size of the objects in the cache exceeds `max_size`, then
+#'   objects will be removed from the cache. Objects will be removed from the
+#'   cache so that the total size remains under `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
+#'   `get()` is called. If the target object is older than `max_age`,
+#'   it will be removed and the cache will report it as a missing value.
+#'
+#' @section Eviction policies:
+#'
+#' If `max_n` or `max_size` are used, then objects will be removed
+#' from the cache according to an eviction policy. The available eviction
+#' policies are:
+#'
+#'   \describe{
+#'     \item{`"lru"`}{
+#'       Least Recently Used. The least recently used objects will be removed.
+#'       This uses the filesystem's mtime property. When "lru" is used, each
+#'       `get()` is called, it will update the file's mtime.
+#'     }
+#'     \item{`"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 `exists(key)` to check
+#' if an object is in the cache, and then call `get(key)`, the object may
+#' be removed from the cache in between those two calls, and `get(key)`
+#' will throw an error. Instead of calling the two functions, it is better to
+#' simply call `get(key)`, and use `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 `file.remove()` failing to remove a file that has
+#' already been deleted.
+#'
+#'
+#' @section Methods:
+#'
+#'  A disk cache object has the following methods:
+#'
+#'   \describe{
+#'     \item{`get(key, missing, exec_missing)`}{
+#'       Returns the value associated with `key`. If the key is not in the
+#'       cache, then it returns the value specified by `missing` or,
+#'       `missing` is a function and `exec_missing=TRUE`, then
+#'       executes `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{`set(key, value)`}{
+#'       Stores the `key`-`value` pair in the cache.
+#'     }
+#'     \item{`exists(key)`}{
+#'       Returns `TRUE` if the cache contains the key, otherwise
+#'       `FALSE`.
+#'     }
+#'     \item{`size()`}{
+#'       Returns the number of items currently in the cache.
+#'     }
+#'     \item{`keys()`}{
+#'       Returns a character vector of all keys currently in the cache.
+#'     }
+#'     \item{`reset()`}{
+#'       Clears all objects from the cache.
+#'     }
+#'     \item{`destroy()`}{
+#'       Clears all objects in the cache, and removes the cache directory from
+#'       disk.
+#'     }
+#'     \item{`prune()`}{
+#'       Prunes the cache, using the parameters specified by `max_size`,
+#'       `max_age`, `max_n`, and `evict`.
+#'     }
+#'   }
+#'
+#' @param dir Directory to store files for the cache. If `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 `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
+#'   `evict`. Use `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 `evict`. Use `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, `"lru"` and `"fifo"` are
+#'   supported.
+#' @param destroy_on_finalize If `TRUE`, then when the DiskCache object is
+#'   garbage collected, the cache directory and all objects inside of it will be
+#'   deleted from disk. If `FALSE` (the default), it will do nothing when
+#'   finalized.
+#' @param missing A value to return or a function to execute when
+#'   `get(key)` is called but the key is not present in the cache. The
+#'   default is a [key_missing()] object. If it is a function to
+#'   execute, the function must take one argument (the key), and you must also
+#'   use `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
+#'   `get()`. See section Missing keys for more information.
+#' @param exec_missing If `FALSE` (the default), then treat `missing`
+#'   as a value to return when `get()` results in a cache miss. If
+#'   `TRUE`, treat `missing` as a function to execute when
+#'   `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 `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,365 @@
+#' 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 `get()` and
+#' `set()` methods. Objects are automatically pruned from the cache
+#' according to the parameters `max_size`, `max_age`, `max_n`,
+#' and `evict`.
+#'
+#' In a `MemoryCache`, R objects are stored directly in the cache; they are
+#' not *not* serialized before being stored in the cache. This contrasts
+#' with other cache types, like [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 `missing` and `exec_missing` parameters controls what happens
+#'   when `get()` is called with a key that is not in the cache (a cache
+#'   miss). The default behavior is to return a [key_missing()]
+#'   object. This is a *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 [is.key_missing()] function. You can
+#'   also have `get()` return a different sentinel value, like `NULL`.
+#'   If you want to throw an error on a cache miss, you can do so by providing a
+#'   function for `missing` that takes one argument, the key, and also use
+#'   `exec_missing=TRUE`.
+#'
+#'   When the cache is created, you can supply a value for `missing`, which
+#'   sets the default value to be returned for missing values. It can also be
+#'   overridden when `get()` is called, by supplying a `missing`
+#'   argument. For example, if you use `cache$get("mykey", missing =
+#'   NULL)`, it will return `NULL` if the key is not in the cache.
+#'
+#'   If your cache is configured so that `get()` returns a sentinel value
+#'   to represent a cache miss, then `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 `get()` encounters missing
+#'   key. If the function returns a value, then `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 `get()` will not return a value.
+#'
+#'   To do this, pass a one-argument function to `missing`, and use
+#'   `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 `get()` should be wrapped with
+#'   [tryCatch()] to gracefully handle missing keys.
+#'
+#' @section Cache pruning:
+#'
+#'   Cache pruning occurs when `set()` is called, or it can be invoked
+#'   manually by calling `prune()`.
+#'
+#'   When a pruning occurs, if there are any objects that are older than
+#'   `max_age`, they will be removed.
+#'
+#'   The `max_size` and `max_n` parameters are applied to the cache as
+#'   a whole, in contrast to `max_age`, which is applied to each object
+#'   individually.
+#'
+#'   If the number of objects in the cache exceeds `max_n`, then objects
+#'   will be removed from the cache according to the eviction policy, which is
+#'   set with the `evict` parameter. Objects will be removed so that the
+#'   number of items is `max_n`.
+#'
+#'   If the size of the objects in the cache exceeds `max_size`, then
+#'   objects will be removed from the cache. Objects will be removed from the
+#'   cache so that the total size remains under `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
+#'   `get()` is called. If the target object is older than `max_age`,
+#'   it will be removed and the cache will report it as a missing value.
+#'
+#' @section Eviction policies:
+#'
+#' If `max_n` or `max_size` are used, then objects will be removed
+#' from the cache according to an eviction policy. The available eviction
+#' policies are:
+#'
+#'   \describe{
+#'     \item{`"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{`"fifo"`}{
+#'       First-in-first-out. The oldest objects will be removed.
+#'     }
+#'   }
+#'
+#' @section Methods:
+#'
+#'  A disk cache object has the following methods:
+#'
+#'   \describe{
+#'     \item{`get(key, missing, exec_missing)`}{
+#'       Returns the value associated with `key`. If the key is not in the
+#'       cache, then it returns the value specified by `missing` or,
+#'       `missing` is a function and `exec_missing=TRUE`, then
+#'       executes `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{`set(key, value)`}{
+#'       Stores the `key`-`value` pair in the cache.
+#'     }
+#'     \item{`exists(key)`}{
+#'       Returns `TRUE` if the cache contains the key, otherwise
+#'       `FALSE`.
+#'     }
+#'     \item{`size()`}{
+#'       Returns the number of items currently in the cache.
+#'     }
+#'     \item{`keys()`}{
+#'       Returns a character vector of all keys currently in the cache.
+#'     }
+#'     \item{`reset()`}{
+#'       Clears all objects from the cache.
+#'     }
+#'     \item{`destroy()`}{
+#'       Clears all objects in the cache, and removes the cache directory from
+#'       disk.
+#'     }
+#'     \item{`prune()`}{
+#'       Prunes the cache, using the parameters specified by `max_size`,
+#'       `max_age`, `max_n`, and `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        <- fastmap()
+      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$get(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$set(key, list(
+        key = key,
+        value = value,
+        size = size,
+        mtime = time,
+        atime = time
+      ))
+      self$prune()
+      invisible(self)
+    },
+
+    exists = function(key) {
+      validate_key(key)
+      private$cache$has(key)
+    },
+
+    keys = function() {
+      private$cache$keys()
+    },
+
+    remove = function(key) {
+      private$log(paste0('remove: key "', key, '"'))
+      validate_key(key)
+      private$cache$remove(key)
+      invisible(self)
+    },
+
+    reset = function() {
+      private$log(paste0('reset'))
+      private$cache$reset()
+      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 = ", ")))
+          private$cache$remove(info$key[rm_idx])
+          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 = ", ")))
+        private$cache$remove(info$key[rm_idx])
+        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 = ", ")))
+        private$cache$remove(info$key[rm_idx])
+        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$get(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))
+        private$cache$remove(key)
+      }
+    },
+
+    object_info = function() {
+      keys <- private$cache$keys()
+      data.frame(
+        key   = keys,
+        size  = vapply(keys, function(key) private$cache$get(key)$size,  0),
+        mtime = vapply(keys, function(key) private$cache$get(key)$mtime, 0),
+        atime = vapply(keys, function(key) private$cache$get(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,9 @@
+
+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

@@ -3,9 +3,9 @@
 #' 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}.
+#' @return `printError` and `printStackTrace` return
+#'   `invisible()`. The other functions pass through the results of
+#'   `expr`.
 #'
 #' @examples
 #' # Keeps tryCatch and withVisible related calls off the
@@ -76,7 +76,7 @@ getCallNames <- function(calls) {
 }
 
 getLocs <- function(calls) {
-  sapply(calls, function(call) {
+  vapply(calls, function(call) {
     srcref <- attr(call, "srcref", exact = TRUE)
     if (!is.null(srcref)) {
       srcfile <- attr(srcref, "srcfile", exact = TRUE)
@@ -86,41 +86,134 @@ getLocs <- function(calls) {
       }
     }
     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
+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 `captureStackTraces` runs the given `expr` and if any
+#'   *uncaught* errors occur, annotates them with stack trace info for use
+#'   by `printError` and `printStackTrace`. It is not necessary to use
+#'   `captureStackTraces` around the same expression as
+#'   `withLogErrors`, as the latter includes a call to the former. Note
+#'   that if `expr` contains calls (either directly or indirectly) to
+#'   `try`, or `tryCatch` with an error handler, stack traces therein
+#'   cannot be captured unless another `captureStackTraces` call is
+#'   inserted in the interior of the `try` or `tryCatch`. This is
 #'   because these calls catch the error and prevent it from traveling up to the
-#'   condition handler installed by \code{captureStackTraces}.
+#'   condition handler installed by `captureStackTraces`.
 #'
 #' @param expr The expression to wrap.
 #' @rdname stacktrace
 #' @export
 captureStackTraces <- function(expr) {
-  withCallingHandlers(expr,
-    error = function(e) {
-      if (is.null(attr(e, "stack.trace", exact = TRUE))) {
-        calls <- sys.calls()
-        attr(e, "stack.trace") <- calls
-        stop(e)
-      }
-    }
+  promises::with_promise_domain(createStackTracePromiseDomain(),
+    expr
   )
 }
 
-#' @details \code{withLogErrors} captures stack traces and logs errors that
-#'   occur in \code{expr}, but does allow errors to propagate beyond this point
+#' @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 `withLogErrors` captures stack traces and logs errors that
+#'   occur in `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}.
+#'   `captureStackTraces` with regard to `try`/`tryCatch` apply
+#'   to `withLogErrors`.
 #' @rdname stacktrace
 #' @export
 withLogErrors <- function(expr,
@@ -128,7 +221,22 @@ withLogErrors <- function(expr,
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   withCallingHandlers(
-    captureStackTraces(expr),
+    {
+      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()
@@ -139,30 +247,30 @@ withLogErrors <- function(expr,
   )
 }
 
-#' @details \code{printError} prints the error and stack trace (if any) using
-#'   \code{warning(immediate.=TRUE)}. \code{printStackTrace} prints the stack
+#' @details `printError` prints the error and stack trace (if any) using
+#'   `warning(immediate.=TRUE)`. `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
+#' @param full If `TRUE`, then every element of `sys.calls()` will be
+#'   included in the stack trace. By default (`FALSE`), calls that Shiny
 #'   deems uninteresting will be hidden.
-#' @param offset If \code{TRUE} (the default), srcrefs will be reassigned from
+#' @param offset If `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
+#'   location specified by the srcref match up. If `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",
+  
+  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s", 
     getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
+  
   printStackTrace(cond, full = full, offset = offset)
-  invisible()
 }
 
 #' @rdname stacktrace
@@ -171,37 +279,103 @@ printStackTrace <- function(cond,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
-  stackTrace <- attr(cond, "stack.trace", exact = TRUE)
-  tryCatch(
-    if (!is.null(stackTrace)) {
-      message(paste0(
-        "Stack trace (innermost first):\n",
-        paste0(collapse = "\n",
-          formatStackTrace(stackTrace, full = full, offset = offset,
-            indent = "    ")
-        )
-      ))
-    } else {
-      message("No stack trace available")
-    },
-
-    error = function(cond) {
-      warning("Failed to write stack trace: ", cond)
-    }
+  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).
+#' @details `extractStackTrace` takes a list of calls (e.g. as returned
+#'   from `conditionStackTrace(cond)`) and returns a data frame with one
+#'   row for each stack frame and the columns `num` (stack frame number),
+#'   `call` (a function name or similar), and `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) {
@@ -241,7 +415,11 @@ extractStackTrace <- function(calls,
     score <- rep.int(0, length(callnames))
     score[callnames == "..stacktraceoff.."] <- -1
     score[callnames == "..stacktraceon.."] <- 1
-    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff.."))
+    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]
 
@@ -253,12 +431,115 @@ extractStackTrace <- function(calls,
     num = index,
     call = getCallNames(calls),
     loc = getLocs(calls),
+    category = getCallCategories(calls),
     stringsAsFactors = FALSE
   )
 }
 
-#' @details \code{formatStackTrace} is similar to \code{extractStackTrace}, but
-#'   it returns a preformatted character vector instead of a data frame.
+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 `formatStackTrace` is similar to `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
@@ -266,6 +547,10 @@ 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))
@@ -276,8 +561,14 @@ formatStackTrace <- function(calls, indent = "    ",
     indent,
     formatC(st$num, width = width),
     ": ",
-    st$call,
-    st$loc
+    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)
+    })
   )
 }
 
@@ -297,11 +588,11 @@ stripStackTrace <- function(cond) {
   conditionStackTrace(cond) <- NULL
 }
 
-#' @details \code{conditionStackTrace} and \code{conditionStackTrace<-} are
+#' @details `conditionStackTrace` and `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}).
+#'   `captureStackTraces` (or `withLogErrors`).
 #' @rdname stacktrace
 #' @export
 conditionStackTrace <- function(cond) {
@@ -316,8 +607,8 @@ conditionStackTrace <- function(cond) {
   invisible(cond)
 }
 
-#' @details The two functions \code{..stacktraceon..} and
-#'   \code{..stacktraceoff..} have no runtime behavior during normal execution;
+#' @details The two functions `..stacktraceon..` and
+#'   `..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
@@ -332,3 +623,5 @@ conditionStackTrace <- function(cond) {
 #' @rdname stacktrace
 #' @export
 ..stacktraceoff.. <- function(expr) expr
+
+..stacktracefloor.. <- function(expr) expr

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

R/font-awesome.R

@@ -0,0 +1,75 @@
+font_awesome_brands <- c(
+  "500px", "accessible-icon", "accusoft", "adn", "adversal",
+  "affiliatetheme", "algolia", "alipay", "amazon", "amazon-pay",
+  "amilia", "android", "angellist", "angrycreative", "angular",
+  "app-store", "app-store-ios", "apper", "apple", "apple-pay",
+  "asymmetrik", "audible", "autoprefixer", "avianex", "aviato",
+  "aws", "bandcamp", "behance", "behance-square", "bimobject",
+  "bitbucket", "bitcoin", "bity", "black-tie", "blackberry", "blogger",
+  "blogger-b", "bluetooth", "bluetooth-b", "btc", "buromobelexperte",
+  "buysellads", "cc-amazon-pay", "cc-amex", "cc-apple-pay", "cc-diners-club",
+  "cc-discover", "cc-jcb", "cc-mastercard", "cc-paypal", "cc-stripe",
+  "cc-visa", "centercode", "chrome", "cloudscale", "cloudsmith",
+  "cloudversify", "codepen", "codiepie", "connectdevelop", "contao",
+  "cpanel", "creative-commons", "creative-commons-by", "creative-commons-nc",
+  "creative-commons-nc-eu", "creative-commons-nc-jp", "creative-commons-nd",
+  "creative-commons-pd", "creative-commons-pd-alt", "creative-commons-remix",
+  "creative-commons-sa", "creative-commons-sampling", "creative-commons-sampling-plus",
+  "creative-commons-share", "css3", "css3-alt", "cuttlefish", "d-and-d",
+  "dashcube", "delicious", "deploydog", "deskpro", "deviantart",
+  "digg", "digital-ocean", "discord", "discourse", "dochub", "docker",
+  "draft2digital", "dribbble", "dribbble-square", "dropbox", "drupal",
+  "dyalog", "earlybirds", "ebay", "edge", "elementor", "ello",
+  "ember", "empire", "envira", "erlang", "ethereum", "etsy", "expeditedssl",
+  "facebook", "facebook-f", "facebook-messenger", "facebook-square",
+  "firefox", "first-order", "first-order-alt", "firstdraft", "flickr",
+  "flipboard", "fly", "font-awesome", "font-awesome-alt", "font-awesome-flag",
+  "font-awesome-logo-full", "fonticons", "fonticons-fi", "fort-awesome",
+  "fort-awesome-alt", "forumbee", "foursquare", "free-code-camp",
+  "freebsd", "fulcrum", "galactic-republic", "galactic-senate",
+  "get-pocket", "gg", "gg-circle", "git", "git-square", "github",
+  "github-alt", "github-square", "gitkraken", "gitlab", "gitter",
+  "glide", "glide-g", "gofore", "goodreads", "goodreads-g", "google",
+  "google-drive", "google-play", "google-plus", "google-plus-g",
+  "google-plus-square", "google-wallet", "gratipay", "grav", "gripfire",
+  "grunt", "gulp", "hacker-news", "hacker-news-square", "hackerrank",
+  "hips", "hire-a-helper", "hooli", "hornbill", "hotjar", "houzz",
+  "html5", "hubspot", "imdb", "instagram", "internet-explorer",
+  "ioxhost", "itunes", "itunes-note", "java", "jedi-order", "jenkins",
+  "joget", "joomla", "js", "js-square", "jsfiddle", "kaggle", "keybase",
+  "keycdn", "kickstarter", "kickstarter-k", "korvue", "laravel",
+  "lastfm", "lastfm-square", "leanpub", "less", "line", "linkedin",
+  "linkedin-in", "linode", "linux", "lyft", "magento", "mailchimp",
+  "mandalorian", "markdown", "mastodon", "maxcdn", "medapps", "medium",
+  "medium-m", "medrt", "meetup", "megaport", "microsoft", "mix",
+  "mixcloud", "mizuni", "modx", "monero", "napster", "neos", "nimblr",
+  "nintendo-switch", "node", "node-js", "npm", "ns8", "nutritionix",
+  "odnoklassniki", "odnoklassniki-square", "old-republic", "opencart",
+  "openid", "opera", "optin-monster", "osi", "page4", "pagelines",
+  "palfed", "patreon", "paypal", "periscope", "phabricator", "phoenix-framework",
+  "phoenix-squadron", "php", "pied-piper", "pied-piper-alt", "pied-piper-hat",
+  "pied-piper-pp", "pinterest", "pinterest-p", "pinterest-square",
+  "playstation", "product-hunt", "pushed", "python", "qq", "quinscape",
+  "quora", "r-project", "ravelry", "react", "readme", "rebel",
+  "red-river", "reddit", "reddit-alien", "reddit-square", "rendact",
+  "renren", "replyd", "researchgate", "resolving", "rev", "rocketchat",
+  "rockrms", "safari", "sass", "schlix", "scribd", "searchengin",
+  "sellcast", "sellsy", "servicestack", "shirtsinbulk", "shopware",
+  "simplybuilt", "sistrix", "sith", "skyatlas", "skype", "slack",
+  "slack-hash", "slideshare", "snapchat", "snapchat-ghost", "snapchat-square",
+  "soundcloud", "speakap", "spotify", "squarespace", "stack-exchange",
+  "stack-overflow", "staylinked", "steam", "steam-square", "steam-symbol",
+  "sticker-mule", "strava", "stripe", "stripe-s", "studiovinari",
+  "stumbleupon", "stumbleupon-circle", "superpowers", "supple",
+  "teamspeak", "telegram", "telegram-plane", "tencent-weibo", "the-red-yeti",
+  "themeco", "themeisle", "trade-federation", "trello", "tripadvisor",
+  "tumblr", "tumblr-square", "twitch", "twitter", "twitter-square",
+  "typo3", "uber", "uikit", "uniregistry", "untappd", "usb", "ussunnah",
+  "vaadin", "viacoin", "viadeo", "viadeo-square", "viber", "vimeo",
+  "vimeo-square", "vimeo-v", "vine", "vk", "vnv", "vuejs", "weebly",
+  "weibo", "weixin", "whatsapp", "whatsapp-square", "whmcs", "wikipedia-w",
+  "windows", "wix", "wolf-pack-battalion", "wordpress", "wordpress-simple",
+  "wpbeginner", "wpexplorer", "wpforms", "xbox", "xing", "xing-square",
+  "y-combinator", "yahoo", "yandex", "yandex-international", "yelp",
+  "yoast", "youtube", "youtube-square", "zhihu"
+)

R/globals.R

@@ -1,23 +1,78 @@
 # A scope where we can put mutable global state
 .globals <- new.env(parent = emptyenv())
 
+register_s3_method <- function(pkg, generic, class, fun = NULL) {
+  stopifnot(is.character(pkg), length(pkg) == 1)
+  stopifnot(is.character(generic), length(generic) == 1)
+  stopifnot(is.character(class), length(class) == 1)
+
+  if (is.null(fun)) {
+    fun <- get(paste0(generic, ".", class), envir = parent.frame())
+  } else {
+    stopifnot(is.function(fun))
+  }
+
+  if (pkg %in% loadedNamespaces()) {
+    registerS3method(generic, class, fun, envir = asNamespace(pkg))
+  }
+
+  # Always register hook in case pkg is loaded at some
+  # point the future (or, potentially, but less commonly,
+  # unloaded & reloaded)
+  setHook(
+    packageEvent(pkg, "onLoad"),
+    function(...) {
+      registerS3method(generic, class, fun, envir = asNamespace(pkg))
+    }
+  )
+}
+
+register_upgrade_message <- function(pkg, version) {
+  # Is an out-dated version of this package installed?
+  needs_upgrade <- function() {
+    if (system.file(package = pkg) == "")
+      return(FALSE)
+    if (utils::packageVersion(pkg) >= version)
+      return(FALSE)
+    TRUE
+  }
+
+  msg <- sprintf(
+    "This version of Shiny is designed to work with '%s' >= %s.
+    Please upgrade via install.packages('%s').",
+    pkg, version, pkg
+  )
+
+  if (pkg %in% loadedNamespaces() && needs_upgrade()) {
+    packageStartupMessage(msg)
+  }
+
+  # Always register hook in case pkg is loaded at some
+  # point the future (or, potentially, but less commonly,
+  # unloaded & reloaded)
+  setHook(
+    packageEvent(pkg, "onLoad"),
+    function(...) {
+      if (needs_upgrade()) packageStartupMessage(msg)
+    }
+  )
+}
+
 .onLoad <- function(libname, pkgname) {
   # 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."
-    )
-  }
+  # Make sure these methods are available to knitr if shiny is loaded but not
+  # attached.
+  register_s3_method("knitr", "knit_print", "reactive")
+  register_s3_method("knitr", "knit_print", "shiny.appobj")
+  register_s3_method("knitr", "knit_print", "shiny.render.function")
+
+  # Shiny 1.4.0 bumps jQuery 1.x to 3.x, which caused a problem
+  # with static-rendering of htmlwidgets, and htmlwidgets 1.5
+  # includes a fix for this problem
+  # https://github.com/rstudio/shiny/issues/2630
+  register_upgrade_message("htmlwidgets", 1.5)
 }

R/graph.R

@@ -1,21 +1,66 @@
-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)
+is_installed <- function(package, version) {
+  installedVersion <- tryCatch(utils::packageVersion(package), error = function(e) NA)
+  !is.na(installedVersion) && installedVersion >= version
 }
 
+# Check that the version of an suggested package satisfies the requirements
+#
+# @param package The name of the suggested package
+# @param version The version of the package
+check_suggested <- function(package, version, location) {
+
+  if (is_installed(package, version)) {
+    return()
+  }
+
+  missing_location <- missing(location)
+  msg <- paste0(
+    sQuote(package),
+    if (is.na(version)) "" else paste0("(>= ", version, ")"),
+    " must be installed for this functionality.",
+    if (!missing_location)
+      paste0(
+        "\nPlease install the missing package: \n",
+        "  source(\"https://install-github.me/", location, "\")"
+      )
+  )
+
+  if (interactive() && missing_location) {
+    message(msg, "\nWould you like to install it?")
+    if (utils::menu(c("Yes", "No")) == 1) {
+      return(utils::install.packages(package))
+    }
+  }
+
+  stop(msg, call. = FALSE)
+}
+
+
+
+
+# domain is like session
+
+
+# used to help define truly global react id's.
+# should work across session and in global namespace
+.globals$reactIdCounter <- 0L
+nextGlobalReactId <- function() {
+  .globals$reactIdCounter <- .globals$reactIdCounter + 1L
+  reactIdStr(.globals$reactIdCounter)
+}
+reactIdStr <- function(num) {
+  paste0("r", num)
+}
+
+
 #' Reactive Log Visualizer
 #'
 #' Provides an interactive browser-based tool for visualizing reactive
 #' dependencies and execution in your application.
 #'
 #' To use the reactive log visualizer, start with a fresh R session and
-#' run the command \code{options(shiny.reactlog=TRUE)}; then launch your
-#' application in the usual way (e.g. using \code{\link{runApp}}). At
+#' run the command `options(shiny.reactlog=TRUE)`; then launch your
+#' application in the usual way (e.g. using [runApp()]). At
 #' any time you can hit Ctrl+F3 (or for Mac users, Command+F3) in your
 #' web browser to launch the reactive log visualization.
 #'
@@ -30,88 +75,499 @@ writeReactLog <- function(file=stdout(), sessionToken = NULL) {
 #'
 #' As an alternative to pressing Ctrl/Command+F3--for example, if you
 #' are using reactives outside of the context of a Shiny
-#' application--you can run the \code{showReactLog} function, which will
+#' application--you can run the `reactlogShow` function, which will
 #' generate the reactive log visualization as a static HTML file and
 #' launch it in your default browser. In this case, refreshing your
 #' browser will not load new activity into the report; you will need to
-#' call \code{showReactLog()} explicitly.
+#' call `reactlogShow()` explicitly.
 #'
 #' For security and performance reasons, do not enable
-#' \code{shiny.reactlog} in production environments. When the option is
+#' `shiny.reactlog` in production environments. When the option is
 #' 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.
+#' @name reactlog
+NULL
+
+
+#' @describeIn reactlog Return a list of reactive information.  Can be used in conjunction with
+#'   [reactlog::reactlog_show] to later display the reactlog graph.
 #' @export
+reactlog <- function() {
+  rLog$asList()
+}
+
+#' @describeIn reactlog Display a full reactlog graph for all sessions.
+#' @inheritParams reactlog::reactlog_show
+#' @export
+reactlogShow <- function(time = TRUE) {
+  check_reactlog()
+  reactlog::reactlog_show(reactlog(), time = time)
+}
+#' @describeIn reactlog This function is deprecated. You should use [reactlogShow()]
+#' @export
+# legacy purposes
 showReactLog <- function(time = TRUE) {
-  utils::browseURL(renderReactLog(time = as.logical(time)))
+  shinyDeprecated(new = "`reactlogShow`", version = "1.2.0")
+  reactlogShow(time = time)
+}
+#' @describeIn reactlog Resets the entire reactlog stack.  Useful for debugging and removing all prior reactive history.
+#' @export
+reactlogReset <- function() {
+  rLog$reset()
 }
 
-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, 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)
+# called in "/reactlog" middleware
+renderReactlog <- function(sessionToken = NULL, time = TRUE) {
+  check_reactlog()
+  reactlog::reactlog_render(
+    reactlog(),
+    session_token = sessionToken,
+    time = time
+  )
 }
+check_reactlog <- function() {
+  check_suggested("reactlog", reactlog_version())
+}
+# read reactlog version from description file
+# prevents version mismatch in code and description file
+reactlog_version <- function() {
+  desc <- read.dcf(system.file("DESCRIPTION", package = "shiny", mustWork = TRUE))
+  suggests <- desc[1,"Suggests"][[1]]
+  suggests_pkgs <- strsplit(suggests, "\n")[[1]]
 
-.graphAppend <- function(logEntry, domain = getDefaultReactiveDomain()) {
-  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())
-    )))
+  reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
+  if (length(reactlog_info) == 0) {
+    stop("reactlog can not be found in shiny DESCRIPTION file")
   }
 
-  if (!is.null(domain)) {
-    domain$reactlog(logEntry)
-  }
+  reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
+  reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
+  reactlog_info <- sub("^[>= ]*", "", reactlog_info)
+
+  package_version(reactlog_info)
 }
 
-.graphDependsOn <- function(id, label) {
-  .graphAppend(list(action='dep', id=id, dependsOn=label))
-}
 
-.graphDependsOnId <- function(id, dependee) {
-  .graphAppend(list(action='depId', id=id, dependsOn=dependee))
-}
+RLog <- R6Class(
+  "RLog",
+  portable = FALSE,
+  private = list(
+    option = "shiny.reactlog",
+    msgOption = "shiny.reactlog.console",
 
-.graphCreateContext <- function(id, label, type, prevId, domain) {
-  .graphAppend(list(
-    action='ctx', id=id, label=paste(label, collapse='\n'),
-    srcref=as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile"),
-    type=type, prevId=prevId
-  ), domain = domain)
-}
+    appendEntry = function(domain, logEntry) {
+      if (self$isLogging()) {
+        sessionToken <- if (is.null(domain)) NULL else domain$token
+        logStack$push(c(logEntry, list(
+          session = sessionToken,
+          time = as.numeric(Sys.time())
+        )))
+      }
+      if (!is.null(domain)) domain$reactlog(logEntry)
+    }
+  ),
+  public = list(
+    msg = "<MessageLogger>",
+    logStack = "<Stack>",
 
-.graphEnterContext <- function(id) {
-  .graphAppend(list(action='enter', id=id))
-}
+    noReactIdLabel = "NoCtxReactId",
+    noReactId = reactIdStr("NoCtxReactId"),
+    dummyReactIdLabel = "DummyReactId",
+    dummyReactId = reactIdStr("DummyReactId"),
 
-.graphExitContext <- function(id) {
-  .graphAppend(list(action='exit', id=id))
-}
+    asList = function() {
+      ret <- self$logStack$as_list()
+      attr(ret, "version") <- "1"
+      ret
+    },
 
-.graphValueChange <- function(label, value) {
-  .graphAppend(list(
-    action = 'valueChange',
-    id = label,
-    value = paste(utils::capture.output(utils::str(value)), collapse='\n')
-  ))
-}
+    ctxIdStr = function(ctxId) {
+      if (is.null(ctxId) || identical(ctxId, "")) return(NULL)
+      paste0("ctx", ctxId)
+    },
+    namesIdStr = function(reactId) {
+      paste0("names(", reactId, ")")
+    },
+    asListIdStr = function(reactId) {
+      paste0("as.list(", reactId, ")")
+    },
+    asListAllIdStr = function(reactId) {
+      paste0("as.list(", reactId, ", all.names = TRUE)")
+    },
+    keyIdStr = function(reactId, key) {
+      paste0(reactId, "$", key)
+    },
 
-.graphInvalidate <- function(id, domain) {
-  .graphAppend(list(action='invalidate', id=id), domain)
-}
+    valueStr = function(value, n = 200) {
+      if (!self$isLogging()) {
+        # return a placeholder string to avoid calling str
+        return("<reactlog is turned off>")
+      }
+      output <- try(silent = TRUE, {
+        # only capture the first level of the object
+        utils::capture.output(utils::str(value, max.level = 1))
+      })
+      outputTxt <- paste0(output, collapse="\n")
+      msg$shortenString(outputTxt, n = n)
+    },
+
+    initialize = function(rlogOption = "shiny.reactlog", msgOption = "shiny.reactlog.console") {
+      private$option <- rlogOption
+      private$msgOption <- msgOption
+
+      self$reset()
+    },
+    reset = function() {
+      .globals$reactIdCounter <- 0L
+
+      self$logStack <- Stack$new()
+      self$msg <- MessageLogger$new(option = private$msgOption)
+
+      # setup dummy and missing react information
+      self$msg$setReact(force = TRUE, list(reactId = self$noReactId, label = self$noReactIdLabel))
+      self$msg$setReact(force = TRUE, list(reactId = self$dummyReactId, label = self$dummyReactIdLabel))
+    },
+    isLogging = function() {
+      isTRUE(getOption(private$option, FALSE))
+    },
+
+    define = function(reactId, value, label, type, domain) {
+      valueStr <- self$valueStr(value)
+      if (msg$hasReact(reactId)) {
+        stop("react definition for id: ", reactId, " already found!!", "Label: ", label, "Type: ", type)
+      }
+      msg$setReact(list(reactId = reactId, label = label))
+      msg$log("define:", msg$reactStr(reactId), msg$typeStr(type = type), msg$valueStr(valueStr))
+      private$appendEntry(domain, list(
+        action = "define",
+        reactId = reactId,
+        label = msg$shortenString(label),
+        type = type,
+        value = valueStr
+      ))
+    },
+    defineNames = function(reactId, value, label, domain) {
+      self$define(self$namesIdStr(reactId), value, self$namesIdStr(label), "reactiveValuesNames", domain)
+    },
+    defineAsList = function(reactId, value, label, domain) {
+      self$define(self$asListIdStr(reactId), value, self$asListIdStr(label), "reactiveValuesAsList", domain)
+    },
+    defineAsListAll = function(reactId, value, label, domain) {
+      self$define(self$asListAllIdStr(reactId), value, self$asListAllIdStr(label), "reactiveValuesAsListAll", domain)
+    },
+    defineKey = function(reactId, value, key, label, domain) {
+      self$define(self$keyIdStr(reactId, key), value, self$keyIdStr(label, key), "reactiveValuesKey", domain)
+    },
+    defineObserver = function(reactId, label, domain) {
+      self$define(reactId, value = NULL, label, "observer", domain)
+    },
+
+    dependsOn = function(reactId, depOnReactId, ctxId, domain) {
+      if (is.null(reactId)) return()
+      ctxId <- ctxIdStr(ctxId)
+      msg$log("dependsOn:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
+      private$appendEntry(domain, list(
+        action = "dependsOn",
+        reactId = reactId,
+        depOnReactId = depOnReactId,
+        ctxId = ctxId
+      ))
+    },
+    dependsOnKey = function(reactId, depOnReactId, key, ctxId, domain) {
+      self$dependsOn(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
+    },
+
+    dependsOnRemove = function(reactId, depOnReactId, ctxId, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      msg$log("dependsOnRemove:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
+      private$appendEntry(domain, list(
+        action = "dependsOnRemove",
+        reactId = reactId,
+        depOnReactId = depOnReactId,
+        ctxId = ctxId
+      ))
+    },
+    dependsOnKeyRemove = function(reactId, depOnReactId, key, ctxId, domain) {
+      self$dependsOnRemove(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
+    },
+
+    createContext = function(ctxId, label, type, prevCtxId, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      prevCtxId <- self$ctxIdStr(prevCtxId)
+      msg$log("createContext:", msg$ctxPrevCtxStr(preCtxIdTxt = " ", ctxId, prevCtxId, type))
+      private$appendEntry(domain, list(
+        action = "createContext",
+        ctxId = ctxId,
+        label = msg$shortenString(label),
+        type = type,
+        prevCtxId = prevCtxId,
+        srcref = as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile")
+      ))
+    },
+
+    enter = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$log("isolateEnter:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "isolateEnter",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$log("enter:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "enter",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+    exit = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$depthDecrement()
+        msg$log("isolateExit:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        private$appendEntry(domain, list(
+          action = "isolateExit",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$depthDecrement()
+        msg$log("exit:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        private$appendEntry(domain, list(
+          action = "exit",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+
+    valueChange = function(reactId, value, domain) {
+      valueStr <- self$valueStr(value)
+      msg$log("valueChange:", msg$reactStr(reactId), msg$valueStr(valueStr))
+      private$appendEntry(domain, list(
+        action = "valueChange",
+        reactId = reactId,
+        value = valueStr
+      ))
+    },
+    valueChangeNames = function(reactId, nameValues, domain) {
+      self$valueChange(self$namesIdStr(reactId), nameValues, domain)
+    },
+    valueChangeAsList = function(reactId, listValue, domain) {
+      self$valueChange(self$asListIdStr(reactId), listValue, domain)
+    },
+    valueChangeAsListAll = function(reactId, listValue, domain) {
+      self$valueChange(self$asListAllIdStr(reactId), listValue, domain)
+    },
+    valueChangeKey = function(reactId, key, value, domain) {
+      self$valueChange(self$keyIdStr(reactId, key), value, domain)
+    },
+
+
+    invalidateStart = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$log("isolateInvalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "isolateInvalidateStart",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$log("invalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "invalidateStart",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+    invalidateEnd = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$depthDecrement()
+        msg$log("isolateInvalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        private$appendEntry(domain, list(
+          action = "isolateInvalidateEnd",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$depthDecrement()
+        msg$log("invalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        private$appendEntry(domain, list(
+          action = "invalidateEnd",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+
+    invalidateLater = function(reactId, runningCtx, millis, domain) {
+      msg$log("invalidateLater: ", millis, "ms", msg$reactStr(reactId), msg$ctxStr(runningCtx))
+      private$appendEntry(domain, list(
+        action = "invalidateLater",
+        reactId = reactId,
+        ctxId = runningCtx,
+        millis = millis
+      ))
+    },
+
+    idle = function(domain = NULL) {
+      msg$log("idle")
+      private$appendEntry(domain, list(
+        action = "idle"
+      ))
+    },
+
+    asyncStart = function(domain = NULL) {
+      msg$log("asyncStart")
+      private$appendEntry(domain, list(
+        action = "asyncStart"
+      ))
+    },
+    asyncStop = function(domain = NULL) {
+      msg$log("asyncStop")
+      private$appendEntry(domain, list(
+        action = "asyncStop"
+      ))
+    },
+
+    freezeReactiveVal = function(reactId, domain) {
+      msg$log("freeze:", msg$reactStr(reactId))
+      private$appendEntry(domain, list(
+        action = "freeze",
+        reactId = reactId
+      ))
+    },
+    freezeReactiveKey = function(reactId, key, domain) {
+      self$freezeReactiveVal(self$keyIdStr(reactId, key), domain)
+    },
+
+    thawReactiveVal = function(reactId, domain) {
+      msg$log("thaw:", msg$reactStr(reactId))
+      private$appendEntry(domain, list(
+        action = "thaw",
+        reactId = reactId
+      ))
+    },
+    thawReactiveKey = function(reactId, key, domain) {
+      self$thawReactiveVal(self$keyIdStr(reactId, key), domain)
+    },
+
+    userMark = function(domain = NULL) {
+      msg$log("userMark")
+      private$appendEntry(domain, list(
+        action = "userMark"
+      ))
+    }
+
+  )
+)
+
+MessageLogger = R6Class(
+  "MessageLogger",
+  portable = FALSE,
+  public = list(
+    depth = 0L,
+    reactCache = list(),
+    option = "shiny.reactlog.console",
+
+    initialize = function(option = "shiny.reactlog.console", depth = 0L) {
+      if (!missing(depth)) self$depth <- depth
+      if (!missing(option)) self$option <- option
+    },
+
+    isLogging = function() {
+      isTRUE(getOption(self$option))
+    },
+    isNotLogging = function() {
+      ! isTRUE(getOption(self$option))
+    },
+    depthIncrement = function() {
+      if (self$isNotLogging()) return(NULL)
+      self$depth <- self$depth + 1L
+    },
+    depthDecrement = function() {
+      if (self$isNotLogging()) return(NULL)
+      self$depth <- self$depth - 1L
+    },
+    hasReact = function(reactId) {
+      if (self$isNotLogging()) return(FALSE)
+      !is.null(self$getReact(reactId))
+    },
+    getReact = function(reactId, force = FALSE) {
+      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
+      self$reactCache[[reactId]]
+    },
+    setReact = function(reactObj, force = FALSE) {
+      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
+      self$reactCache[[reactObj$reactId]] <- reactObj
+    },
+    shortenString = function(txt, n = 250) {
+      if (is.null(txt) || isTRUE(is.na(txt))) {
+        return("")
+      }
+      if (nchar(txt) > n) {
+        return(
+          paste0(substr(txt, 1, n - 3), "...")
+        )
+      }
+      return(txt)
+    },
+    singleLine = function(txt) {
+      gsub("[^\\]\\n", "\\\\n", txt)
+    },
+    valueStr = function(valueStr) {
+      paste0(
+        " '",  self$shortenString(self$singleLine(valueStr)), "'"
+      )
+    },
+    reactStr = function(reactId) {
+      if (self$isNotLogging()) return(NULL)
+      reactInfo <- self$getReact(reactId)
+      if (is.null(reactInfo)) return(" <UNKNOWN_REACTID>")
+      paste0(
+        " ", reactInfo$reactId, ":'", self$shortenString(self$singleLine(reactInfo$label)), "'"
+      )
+    },
+    typeStr = function(type = NULL) {
+      self$ctxStr(ctxId = NULL, type = type)
+    },
+    ctxStr = function(ctxId = NULL, type = NULL) {
+      if (self$isNotLogging()) return(NULL)
+      self$ctxPrevCtxStr(ctxId = ctxId, prevCtxId = NULL, type = type)
+    },
+    ctxPrevCtxStr = function(ctxId = NULL, prevCtxId = NULL, type = NULL, preCtxIdTxt = " in ") {
+      if (self$isNotLogging()) return(NULL)
+      paste0(
+        if (!is.null(ctxId)) paste0(preCtxIdTxt, ctxId),
+        if (!is.null(prevCtxId)) paste0(" from ", prevCtxId),
+        if (!is.null(type) && !identical(type, "other")) paste0(" - ", type)
+      )
+    },
+    log = function(...) {
+      if (self$isNotLogging()) return(NULL)
+      msg <- paste0(
+        paste0(rep("= ", depth), collapse = ""), "- ", paste0(..., collapse = ""),
+        collapse = ""
+      )
+      message(msg)
+    }
+  )
+)
 
 #' @include stack.R
-.graphStack <- Stack$new()
+rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")

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
+#' `updateQueryString(_yourNewQueryString_, mode = "push")`. The default
+#' `mode` for `updateQueryString` is `"replace"`, which doesn't
+#' raise any events, so any observers or reactives that depend on it will
+#' *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 `getQueryString`, a named list. For example, the query
+#'   string `?param1=value1&param2=value2` becomes `list(param1 =
+#'   value1, param2 = value2)`. For `getUrlHash`, a character vector with
+#'   the hash (including the leading `#` symbol).
+#'
+#' @seealso [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

@@ -2,17 +2,22 @@
 #'
 #' Ensure that a file-based HTML dependency (from the htmltools package) can be
 #' served over Shiny's HTTP server. This function works by using
-#' \code{\link{addResourcePath}} to map the HTML dependency's directory to a
+#' [addResourcePath()] to map the HTML dependency's directory to a
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named, then
-#'   \code{href} and/or \code{file} names must be present.
+#'   [htmltools::htmlDependency()]. If the `src` value is named,
+#'   then `href` and/or `file` names must be present.
+#' @param scrubFile If TRUE (the default), remove `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
+#'   `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}.
+#' @return A single HTML dependency object that has an `href`-named element
+#'   in its `src`.
 #' @export
-createWebDependency <- function(dependency) {
+createWebDependency <- function(dependency, scrubFile = TRUE) {
   if (is.null(dependency))
     return(NULL)
 
@@ -25,6 +30,10 @@ createWebDependency <- function(dependency) {
     dependency$src$href <- prefix
   }
 
+  # Don't leak local file path to client
+  if (scrubFile)
+    dependency$src$file <- NULL
+
   return(dependency)
 }
 

R/htmltools.R

@@ -1,8 +1,11 @@
-#' @export a br code div em h1 h2 h3 h4 h5 h6 hr HTML img p pre span strong
-#' @export includeCSS includeHTML includeMarkdown includeScript includeText
-#' @export is.singleton singleton
-#' @export tag tagAppendAttributes tagAppendChild tagAppendChildren tagList tags tagSetChildren withTags
+#' @import htmltools
+#' @export tags p h1 h2 h3 h4 h5 h6 a br div span pre code img strong em hr
+#' @export tag tagList tagAppendAttributes tagHasAttribute tagGetAttribute tagAppendChild tagAppendChildren tagSetChildren
+#' @export HTML
+#' @export includeHTML includeText includeMarkdown includeCSS includeScript
+#' @export singleton is.singleton
 #' @export validateCssUnit
-#' @export knit_print.html knit_print.shiny.tag knit_print.shiny.tag.list
-#' @export htmlTemplate suppressDependencies
+#' @export htmlTemplate
+#' @export suppressDependencies
+#' @export withTags
 NULL

R/image-interact-opts.R

@@ -1,11 +1,11 @@
 #' 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}}.
+#' `click` argument of [imageOutput()] or
+#' [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 id Input value name. For example, if the value is `"plot_click"`,
+#'   then the click coordinates will be available as `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.
@@ -24,12 +24,12 @@ clickOpts <- function(id = NULL, clip = TRUE) {
 #' 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}}.
+#' the `dblclick` argument of [imageOutput()] or
+#' [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}.
+#'   `"plot_dblclick"`, then the click coordinates will be available as
+#'   `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.
@@ -50,23 +50,23 @@ dblclickOpts <- function(id = NULL, clip = TRUE, delay = 400) {
 #' 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}}.
+#' `hover` argument of [imageOutput()] or
+#' [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 id Input value name. For example, if the value is `"plot_hover"`,
+#'   then the hover coordinates will be available as `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
+#'   events. Use `"throttle"` to limit the number of hover events to one
+#'   every `delay` milliseconds. Use `"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.
+#'   `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
+#' @param nullOutside If `TRUE` (the default), the value will be set to
+#'   `NULL` when the mouse exits the plotting area. If `FALSE`, the
 #'   value will stop changing when the cursor exits the plotting area.
 #' @export
 hoverOpts <- function(id = NULL, delay = 300,
@@ -87,34 +87,34 @@ hoverOpts <- function(id = NULL, delay = 300,
 #' 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}}.
+#' `brush` argument of [imageOutput()] or
+#' [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}
+#' @param id Input value name. For example, if the value is `"plot_brush"`,
+#'   then the coordinates will be available as `input$plot_brush`. Multiple
+#'   `imageOutput`/`plotOutput` calls may share the same `id`
 #'   value; brushing one image or plot will cause any other brushes with the
-#'   same \code{id} to disappear.
+#'   same `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
+#'   events. Use `"throttle"` to limit the number of brush events to one
+#'   every `delay` milliseconds. Use `"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.
+#'   `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"},
+#' @param direction The direction for brushing. If `"xy"`, the brush can be
+#'   drawn and moved in both x and y directions. If `"x"`, or `"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
+#'   [renderImage()]), should the brush be reset? The default,
+#'   `FALSE`, is useful if you want to update the plot while keeping the
+#'   brush. Using `TRUE` is useful if you want to clear the brush whenever
 #'   the plot is updated.
 #' @export
 brushOpts <- function(id = NULL, fill = "#9cf", stroke = "#036",

R/image-interact.R

@@ -1,28 +1,28 @@
 #' 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}}.
+#' with [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.
+#' frame, but with an additional column `selected_`, which indicates which
+#' rows of the input data frame are selected by the brush (`TRUE` for
+#' selected, `FALSE` for not-selected). This is enabled by setting
+#' `allRows=TRUE` option.
 #'
-#' The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2}
+#' The `xvar`, `yvar`, `panelvar1`, and `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")}.
+#' `plot(x=cars$speed, y=cars$dist)`, and your brush is named
+#' `"cars_brush"`, then you would use `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
+#' example, with `ggplot(cars, aes(x=speed, y=dist)) + geom_point()`, you
+#' could use `brushedPoints(cars, input$cars_brush)`. If, however, you use
+#' a computed column, like `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.
@@ -33,26 +33,26 @@
 #' 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
+#' `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 brush The data from a brush, such as `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
+#'   This must also be the name of a column in `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
+#'   `cyl`, then you can use `"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}).
+#' @param allRows If `FALSE` (the default) return a data frame containing
+#'   the selected rows. If `TRUE`, the input data frame will have a new
+#'   column, `selected_`, which indicates whether the row was inside the
+#'   brush (`TRUE`) or outside the brush (`FALSE`).
 #'
-#' @seealso \code{\link{plotOutput}} for example usage.
+#' @seealso [plotOutput()] for example usage.
 #' @export
 brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
                           panelvar1 = NULL, panelvar2 = NULL,
@@ -86,15 +86,16 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
   if (use_x) {
     if (is.null(xvar))
       stop("brushedPoints: not able to automatically infer `xvar` from brush")
-    # Extract data values from the data frame
-    x <- asNumber(df[[xvar]])
-    keep_rows <- keep_rows & (x >= brush$xmin & x <= brush$xmax)
+    if (!(xvar %in% names(df)))
+      stop("brushedPoints: `xvar` ('", xvar ,"')  not in names of input")
+    keep_rows <- keep_rows & within_brush(df[[xvar]], brush, "x")
   }
   if (use_y) {
     if (is.null(yvar))
       stop("brushedPoints: not able to automatically infer `yvar` from brush")
-    y <- asNumber(df[[yvar]])
-    keep_rows <- keep_rows & (y >= brush$ymin & y <= brush$ymax)
+    if (!(yvar %in% names(df)))
+      stop("brushedPoints: `yvar` ('", yvar ,"') not in names of input")
+    keep_rows <- keep_rows & within_brush(df[[yvar]], brush, "y")
   }
 
   # Find which rows are matches for the panel vars (if present)
@@ -118,6 +119,19 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ 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
@@ -143,6 +157,19 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ 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"
@@ -167,39 +194,39 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #'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
+#'double-click, when used with [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
+#'frame, but with an additional column `selected_`, which indicates which
+#'rows of the input data frame are selected by the brush (`TRUE` for
+#'selected, `FALSE` for not-selected). This is enabled by setting
+#'`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
+#'The `xvar`, `yvar`, `panelvar1`, and `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")}.
+#'`plot(x=cars$speed, y=cars$dist)`, and your click variable is named
+#'`"cars_click"`, then you would use `nearPoints(cars,
+#'input$cars_brush, "speed", "dist")`.
 #'
 #'@inheritParams brushedPoints
-#'@param coordinfo The data from a mouse event, such as \code{input$plot_click}.
+#'@param coordinfo The data from a mouse event, such as `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
+#'  frame where the distance to the click is less than `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
+#'@param addDist If TRUE, add a column named `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}).
+#'  has yet occured, the value of `dist_` will be `NA`.
+#'@param allRows If `FALSE` (the default) return a data frame containing
+#'  the selected rows. If `TRUE`, the input data frame will have a new
+#'  column, `selected_`, which indicates whether the row was inside the
+#'  selected by the mouse event (`TRUE`) or not (`FALSE`).
 #'
-#'@seealso \code{\link{plotOutput}} for more examples.
+#'@seealso [plotOutput()] for more examples.
 #'
 #' @examples
 #' \dontrun{
@@ -245,18 +272,29 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
   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]])
+  x <- asNumber(df[[xvar]], coordinfo$domain$discrete_limits$x)
+  y <- asNumber(df[[yvar]], coordinfo$domain$discrete_limits$y)
 
-  # Get the pixel coordinates of the point
-  coordPx <- scaleCoords(coordinfo$x, coordinfo$y, coordinfo)
+  # Get the coordinates of the point (in img pixel coordinates)
+  point_img <- coordinfo$coords_img
 
-  # Get pixel coordinates of data points
-  dataPx <- scaleCoords(x, y, coordinfo)
+  # Get coordinates of data points (in img pixel coordinates)
+  data_img <- scaleCoords(x, y, coordinfo)
 
-  # Distances of data points to coordPx
-  dists <- sqrt((dataPx$x - coordPx$x) ^ 2 + (dataPx$y - coordPx$y) ^ 2)
+  # 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
@@ -298,56 +336,90 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 # 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
-#  $ mapping: Named list()
-#  $ domain :List of 4
+#  $ 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
+#  $ range     :List of 4
 #   ..$ left  : num 58
 #   ..$ right : num 429
 #   ..$ bottom: num 226
 #   ..$ top   : num 58
-#  $ log    :List of 2
+#  $ log       :List of 2
 #   ..$ x: NULL
 #   ..$ y: NULL
-#  $ .nonce : num 0.343
+#  $ .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
-#  $ panelvar1: int 6
-#  $ panelvar2: int 0
-#  $ mapping  :List of 4
+#  $ 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
+#  $ domain    :List of 4
 #   ..$ left  : num 1.32
 #   ..$ right : num 5.62
 #   ..$ bottom: num 9.22
 #   ..$ top   : num 35.1
-#  $ range    :List of 4
+#  $ range     :List of 4
 #   ..$ left  : num 172
 #   ..$ right : num 300
 #   ..$ bottom: num 144
 #   ..$ top   : num 28.5
-#  $ log      :List of 2
+#  $ log       :List of 2
 #   ..$ x: NULL
 #   ..$ y: NULL
-#  $ .nonce   : num 0.603
-
+#  $ .nonce    : num 0.603
 
+# Helper to determine if data values are within the limits of
+# an input brush
+within_brush <- function(vals, brush, var = "x") {
+  var <- match.arg(var, c("x", "y"))
+  vals <- asNumber(vals, brush$domain$discrete_limits[[var]])
+  # It's possible for a non-missing data values to not
+  # map to the axis limits, for example:
+  # https://github.com/rstudio/shiny/pull/2410#issuecomment-488100881
+  !is.na(vals) &
+    vals >= brush[[paste0(var, "min")]] &
+    vals <= brush[[paste0(var, "max")]]
+}
 
 # 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) {
+# The `levels` argument should be used when mapping this variable to
+# a known set of discrete levels, which is needed for ggplot2 since
+# it allows you to control ordering and possible values of a discrete
+# positional scale (#2410)
+asNumber <- function(x, levels = NULL) {
+  if (length(levels)) return(match(x, levels))
   if (is.character(x)) x <- as.factor(x)
   if (is.factor(x)) x <- as.integer(x)
   as.numeric(x)

R/imageutils.R

@@ -1,40 +1,11 @@
-#' Run a plotting function and save the output as a PNG
-#'
-#' This function returns the name of the PNG file that it generates. In
-#' essence, it calls \code{png()}, then \code{func()}, then \code{dev.off()}.
-#' So \code{func} must be a function that will generate a plot when used this
-#' way.
-#'
-#' For output, it will try to use the following devices, in this order:
-#' quartz (via \code{\link[grDevices]{png}}), then \code{\link[Cairo]{CairoPNG}},
-#' and finally \code{\link[grDevices]{png}}. This is in order of quality of
-#' output. Notably, plain \code{png} output on Linux and Windows may not
-#' antialias some point shapes, resulting in poor quality output.
-#'
-#' In some cases, \code{Cairo()} provides output that looks worse than
-#' \code{png()}. To disable Cairo output for an app, use
-#' \code{options(shiny.usecairo=FALSE)}.
-#'
-#' @param func A function that generates a plot.
-#' @param filename The name of the output file. Defaults to a temp file with
-#'   extension \code{.png}.
-#' @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
-#'   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, ...) {
+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"))) {
+      nchar(system.file(package = "Cairo"))) {
     pngfun <- Cairo::CairoPNG
   } else {
     pngfun <- grDevices::png
@@ -54,9 +25,77 @@ plotPNG <- function(func, filename=tempfile(fileext='.png'),
     finally = graphics::par(op)
   )
 
-  dv <- grDevices::dev.cur()
+  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
+#' essence, it calls `png()`, then `func()`, then `dev.off()`.
+#' So `func` must be a function that will generate a plot when used this
+#' way.
+#'
+#' For output, it will try to use the following devices, in this order:
+#' quartz (via [grDevices::png()]), then [Cairo::CairoPNG()],
+#' and finally [grDevices::png()]. This is in order of quality of
+#' output. Notably, plain `png` output on Linux and Windows may not
+#' antialias some point shapes, resulting in poor quality output.
+#'
+#' In some cases, `Cairo()` provides output that looks worse than
+#' `png()`. To disable Cairo output for an app, use
+#' `options(shiny.usecairo=FALSE)`.
+#'
+#' @param func A function that generates a plot.
+#' @param filename The name of the output file. Defaults to a temp file with
+#'   extension `.png`.
+#' @param width Width in pixels.
+#' @param height Height in pixels.
+#' @param res Resolution in pixels per inch. This value is passed to
+#'   [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 [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, ...) {
+  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

@@ -6,7 +6,7 @@
 #' @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 icon An optional [icon()] to appear on the button.
 #' @param ... Named attributes to be applied to the button or link.
 #'
 #' @family input elements
@@ -16,7 +16,7 @@
 #'
 #' ui <- fluidPage(
 #'   sliderInput("obs", "Number of observations", 0, 1000, 500),
-#'   actionButton("goButton", "Go!"),
+#'   actionButton("goButton", "Go!", class = "btn-success"),
 #'   plotOutput("distPlot")
 #' )
 #'
@@ -36,7 +36,18 @@
 #'
 #' }
 #'
-#' @seealso \code{\link{observeEvent}} and \code{\link{eventReactive}}
+#' ## Example of adding extra class values
+#' actionButton("largeButton", "Large Primary Button", class = "btn-primary btn-lg")
+#' actionLink("infoLink", "Information Link", class = "btn-info")
+#'
+#' @seealso [observeEvent()] and [eventReactive()]
+#'
+#' @section Server value:
+#' An integer of class `"shinyActionButtonValue"`. This class differs from
+#' ordinary integers in that a value of 0 is considered "falsy".
+#' This implies two things:
+#'   * Event handlers (e.g., [observeEvent()], [eventReactive()]) won't execute on initial load.
+#'   * Input validation (e.g., [req()], [need()]) will fail on initial load.
 #' @export
 actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
 

R/input-checkbox.R

@@ -3,11 +3,11 @@
 #' Create a checkbox that can be used to specify logical values.
 #'
 #' @inheritParams textInput
-#' @param value Initial value (\code{TRUE} or \code{FALSE}).
+#' @param value Initial value (`TRUE` or `FALSE`).
 #' @return A checkbox control that can be added to a UI definition.
 #'
 #' @family input elements
-#' @seealso \code{\link{checkboxGroupInput}}, \code{\link{updateCheckboxInput}}
+#' @seealso [checkboxGroupInput()], [updateCheckboxInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -22,6 +22,10 @@
 #' }
 #' shinyApp(ui, server)
 #' }
+#'
+#' @section Server value:
+#' `TRUE` if checked, `FALSE` otherwise.
+#'
 #' @export
 checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
 

R/input-checkboxgroup.R

@@ -6,13 +6,26 @@
 #'
 #' @inheritParams textInput
 #' @param choices List of values to show checkboxes for. If elements of the list
-#'   are named then that name rather than the value is displayed to the user.
+#'   are named then that name rather than the value is displayed to the user. If
+#'   this argument is provided, then `choiceNames` and `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 inline If `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, `choiceNames` and `choiceValues`
+#'   must have the same length). If either of these arguments is
+#'   provided, then the other *must* be provided and `choices`
+#'   *must not* be provided. The advantage of using both of these over
+#'   a named list for `choices` is that `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}}
+#' @seealso [checkboxInput()], [updateCheckboxGroupInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -26,26 +39,55 @@
 #'   tableOutput("data")
 #' )
 #'
-#' server <- function(input, output) {
+#' 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)
+#' }
+#' @section Server value:
+#' Character vector of values corresponding to the boxes that are checked.
+#'
 #' @export
-checkboxGroupInput <- function(inputId, label, choices, selected = NULL,
-  inline = FALSE, width = NULL) {
+checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
+
+  # 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)
 
-  # resolve names
-  choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+  # default value if it's not specified
+  if (!is.null(selected)) selected <- as.character(selected)
 
-  options <- generateOptions(inputId, choices, selected, inline)
+  options <- generateOptions(inputId, selected, inline,
+    'checkbox', args$choiceNames, args$choiceValues)
 
   divClass <- "form-group shiny-input-checkboxgroup shiny-input-container"
   if (inline)
@@ -55,7 +97,7 @@ checkboxGroupInput <- function(inputId, label, choices, selected = NULL,
   tags$div(id = inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     class = divClass,
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     options
   )
 }

R/input-date.R

@@ -3,44 +3,53 @@
 #' 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 date `format` string specifies how the date will be displayed in
 #' the browser. It allows the following values:
 #'
 #' \itemize{
-#'   \item \code{yy} Year without century (12)
-#'   \item \code{yyyy} Year with century (2012)
-#'   \item \code{mm} Month number, with leading zero (01-12)
-#'   \item \code{m} Month number, without leading zero (01-12)
-#'   \item \code{M} Abbreviated month name
-#'   \item \code{MM} Full month name
-#'   \item \code{dd} Day of month with leading zero
-#'   \item \code{d} Day of month without leading zero
-#'   \item \code{D} Abbreviated weekday name
-#'   \item \code{DD} Full weekday name
+#'   \item `yy` Year without century (12)
+#'   \item `yyyy` Year with century (2012)
+#'   \item `mm` Month number, with leading zero (01-12)
+#'   \item `m` Month number, without leading zero (1-12)
+#'   \item `M` Abbreviated month name
+#'   \item `MM` Full month name
+#'   \item `dd` Day of month with leading zero
+#'   \item `d` Day of month without leading zero
+#'   \item `D` Abbreviated weekday name
+#'   \item `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.
+#'   `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.
+#'   `yyyy-mm-dd` format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   `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".
+#'   `"yyyy-mm-dd"`.
+#' @param startview The date range shown when the input object is first clicked.
+#'   Can be "month" (the default), "year", or "decade".
 #' @param weekstart Which day is the start of the week. Should be an integer
 #'   from 0 (Sunday) to 6 (Saturday).
 #' @param language The language used for month and day names. Default is "en".
-#'   Other valid values include "bg", "ca", "cs", "da", "de", "el", "es", "fi",
-#'   "fr", "he", "hr", "hu", "id", "is", "it", "ja", "kr", "lt", "lv", "ms",
-#'   "nb", "nl", "pl", "pt", "pt-BR", "ro", "rs", "rs-latin", "ru", "sk", "sl",
-#'   "sv", "sw", "th", "tr", "uk", "zh-CN", and "zh-TW".
+#'   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 `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}}
+#' @seealso [dateRangeInput()], [updateDateInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -60,52 +69,74 @@
 #'
 #'   # Use different language and different first day of week
 #'   dateInput("date5", "Date:",
-#'           language = "de",
+#'           language = "ru",
 #'           weekstart = 1),
 #'
 #'   # Start with decade view instead of default month view
 #'   dateInput("date6", "Date:",
-#'             startview = "decade")
+#'             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) { })
 #' }
+#'
+#' @section Server value:
+#' A [Date] vector of length 1.
+#'
 #' @export
 dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
-  format = "yyyy-mm-dd", startview = "month", weekstart = 0, language = "en",
-  width = 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")
+  value <- dateYMD(value, "value")
+  min <- dateYMD(min, "min")
+  max <- dateYMD(max, "max")
+  datesdisabled <- dateYMD(datesdisabled, "datesdisabled")
 
   value <- restoreInput(id = inputId, default = value)
 
-  attachDependencies(
-    tags$div(id = inputId,
-      class = "shiny-date-input form-group shiny-input-container",
-      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+  tags$div(id = inputId,
+    class = "shiny-date-input form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
 
-      controlLabel(inputId, label),
-      tags$input(type = "text",
-                 # datepicker class necessary for dropdown to display correctly
-                 class = "form-control datepicker",
-                 `data-date-language` = language,
-                 `data-date-weekstart` = weekstart,
-                 `data-date-format` = format,
-                 `data-date-start-view` = startview,
-                 `data-min-date` = min,
-                 `data-max-date` = max,
-                 `data-initial-date` = value
-      )
+    shinyInputLabel(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.0.2", c(href = "shared/datepicker"),
+  "bootstrap-datepicker", "1.6.4", c(href = "shared/datepicker"),
   script = "js/bootstrap-datepicker.min.js",
-  stylesheet = "css/datepicker.css")
+  stylesheet = "css/bootstrap-datepicker3.min.css",
+  # Need to enable noConflict mode. See #1346.
+  head = "<script>
+(function() {
+  var datepicker = $.fn.datepicker.noConflict();
+  $.fn.bsDatepicker = datepicker;
+})();
+</script>"
+)

R/input-daterange.R

@@ -3,33 +3,33 @@
 #' 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 date `format` string specifies how the date will be displayed in
 #' the browser. It allows the following values:
 #'
 #' \itemize{
-#'   \item \code{yy} Year without century (12)
-#'   \item \code{yyyy} Year with century (2012)
-#'   \item \code{mm} Month number, with leading zero (01-12)
-#'   \item \code{m} Month number, without leading zero (01-12)
-#'   \item \code{M} Abbreviated month name
-#'   \item \code{MM} Full month name
-#'   \item \code{dd} Day of month with leading zero
-#'   \item \code{d} Day of month without leading zero
-#'   \item \code{D} Abbreviated weekday name
-#'   \item \code{DD} Full weekday name
+#'   \item `yy` Year without century (12)
+#'   \item `yyyy` Year with century (2012)
+#'   \item `mm` Month number, with leading zero (01-12)
+#'   \item `m` Month number, without leading zero (1-12)
+#'   \item `M` Abbreviated month name
+#'   \item `MM` Full month name
+#'   \item `dd` Day of month with leading zero
+#'   \item `d` Day of month without leading zero
+#'   \item `D` Abbreviated weekday name
+#'   \item `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
+#'   `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
+#'   `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}}
+#' @seealso [dateInput()], [updateDateRangeInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -70,17 +70,20 @@
 #'
 #' shinyApp(ui, server = function(input, output) { })
 #' }
+#'
+#' @section Server value:
+#' A [Date] vector of length 2.
+#'
 #' @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) {
+    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")
+  start <- dateYMD(start, "start")
+  end   <- dateYMD(end, "end")
+  min   <- dateYMD(min, "min")
+  max   <- dateYMD(max, "max")
 
   restored <- restoreInput(id = inputId, default = list(start, end))
   start <- restored[[1]]
@@ -91,31 +94,38 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
       class = "shiny-date-range-input form-group shiny-input-container",
       style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
 
-      controlLabel(inputId, label),
+      shinyInputLabel(inputId, label),
       # input-daterange class is needed for dropdown behavior
-      div(class = "input-daterange input-group",
+      div(class = "input-daterange input-group input-group-sm",
         tags$input(
-          class = "input-sm form-control",
+          class = "form-control",
           type = "text",
           `data-date-language` = language,
-          `data-date-weekstart` = weekstart,
+          `data-date-week-start` = weekstart,
           `data-date-format` = format,
           `data-date-start-view` = startview,
           `data-min-date` = min,
           `data-max-date` = max,
-          `data-initial-date` = start
+          `data-initial-date` = start,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
+        ),
+        # input-group-prepend and input-group-append are for bootstrap 4 forward compat
+        span(class = "input-group-addon input-group-prepend input-group-append",
+          span(class = "input-group-text",
+            separator
+          )
         ),
-        span(class = "input-group-addon", separator),
         tags$input(
-          class = "input-sm form-control",
+          class = "form-control",
           type = "text",
           `data-date-language` = language,
-          `data-date-weekstart` = weekstart,
+          `data-date-week-start` = weekstart,
           `data-date-format` = format,
           `data-date-start-view` = startview,
           `data-min-date` = min,
           `data-max-date` = max,
-          `data-initial-date` = end
+          `data-initial-date` = end,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
         )
       )
     ),

R/input-file.R

@@ -3,30 +3,26 @@
 #' 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.}
-#' }
+#' to a dataframe. See the `Server value` section.
 #'
 #' @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.
+#'   multiple files at once. **Does not work on older browsers, including
+#'   Internet Explorer 9 and earlier.**
+#' @param accept A character vector of "unique file type specifiers" which
+#'   gives the browser a hint as to the type of file the server expects.
+#'   Many browsers use this prevent the user from selecting an invalid file.
+#'
+#'   A unique file type specifier can be:
+#'   * A case insensitive extension like `.csv` or `.rds`.
+#'   * A valid MIME type, like `text/plain` or `application/pdf`
+#'   * One of `audio/*`, `video/*`, or `image/*` meaning any audio, video,
+#'     or image type, respectively.
+#' @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
@@ -35,13 +31,7 @@
 #' ui <- fluidPage(
 #'   sidebarLayout(
 #'     sidebarPanel(
-#'       fileInput("file1", "Choose CSV File",
-#'         accept = c(
-#'           "text/csv",
-#'           "text/comma-separated-values,text/plain",
-#'           ".csv")
-#'         ),
-#'       tags$hr(),
+#'       fileInput("file1", "Choose CSV File", accept = ".csv"),
 #'       checkboxInput("header", "Header", TRUE)
 #'     ),
 #'     mainPanel(
@@ -52,25 +42,38 @@
 #'
 #' 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
+#'     file <- input$file1
+#'     ext <- tools::file_ext(file$datapath)
 #'
-#'     if (is.null(inFile))
-#'       return(NULL)
+#'     req(file)
+#'     validate(need(ext == "csv", "Please upload a csv file"))
 #'
-#'     read.csv(inFile$datapath, header = input$header)
+#'     read.csv(file$datapath, header = input$header)
 #'   })
 #' }
 #'
 #' shinyApp(ui, server)
 #' }
+#'
+#' @section Server value:
+#' A `data.frame` that contains one row for each selected file, and following columns:
+#' \describe{
+#'   \item{`name`}{The filename provided by the web browser. This is
+#'   **not** the path to read to get at the actual data that was uploaded
+#'   (see
+#'   `datapath` column).}
+#'   \item{`size`}{The size of the uploaded data, in
+#'   bytes.}
+#'   \item{`type`}{The MIME type reported by the browser (for example,
+#'   `text/plain`), or empty string if the browser didn't know.}
+#'   \item{`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.}
+#' }
+#'
 #' @export
 fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
-  width = NULL) {
+  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
 
   restoredValue <- restoreInput(id = inputId, default = NULL)
 
@@ -100,23 +103,24 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
 
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label),
+    shinyInputLabel(inputId, label),
 
     div(class = "input-group",
-      tags$label(class = "input-group-btn",
+      # input-group-prepend is for bootstrap 4 compat
+      tags$label(class = "input-group-btn input-group-prepend",
         span(class = "btn btn-default btn-file",
-          "Browse...",
+          buttonLabel,
           inputTag
         )
       ),
       tags$input(type = "text", class = "form-control",
-        placeholder = "No file selected", readonly = "readonly"
+        placeholder = placeholder, readonly = "readonly"
       )
     ),
 
     tags$div(
       id=paste(inputId, "_progress", sep=""),
-      class="progress progress-striped active shiny-file-input-progress",
+      class="progress active shiny-file-input-progress",
       tags$div(class="progress-bar")
     )
   )

R/input-numeric.R

@@ -9,7 +9,7 @@
 #' @return A numeric input control that can be added to a UI definition.
 #'
 #' @family input elements
-#' @seealso \code{\link{updateNumericInput}}
+#' @seealso [updateNumericInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -24,6 +24,10 @@
 #' }
 #' shinyApp(ui, server)
 #' }
+#'
+#' @section Server value:
+#' A numeric vector of length 1.
+#'
 #' @export
 numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
   width = NULL) {
@@ -42,7 +46,7 @@ numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
 
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
     inputTag
   )
 }

R/input-password.R

@@ -6,7 +6,11 @@
 #' @return A text input control that can be added to a UI definition.
 #'
 #' @family input elements
-#' @seealso \code{\link{updateTextInput}}
+#' @seealso [updateTextInput()]
+#'
+#' @section Server value:
+#' A character string of the password input. The default value is `""`
+#' unless `value` is provided.
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -30,7 +34,7 @@ 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),
+    shinyInputLabel(inputId, label),
     tags$input(id = inputId, type="password", class="form-control", value=value,
                placeholder = placeholder)
   )

R/input-radiobuttons.R

@@ -3,22 +3,33 @@
 #' 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"
-#' = "")}.
+#' the radio buttons to have no options selected by using `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 `c("None selected" = "")`.
 #'
 #' @inheritParams textInput
 #' @param choices List of values to select from (if elements of the list are
-#' named then that name rather than the value is displayed to the user)
-#' @param selected The initially selected value (if not specified then
-#' defaults to the first value)
-#' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
+#'   named then that name rather than the value is displayed to the user). If
+#'   this argument is provided, then `choiceNames` and `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 `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, `choiceNames` and `choiceValues` must have the same
+#'   length). If either of these arguments is provided, then the other
+#'   *must* be provided and `choices` *must not* be provided. The
+#'   advantage of using both of these over a named list for `choices` is
+#'   that `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}}
+#' @seealso [updateRadioButtons()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -47,32 +58,55 @@
 #' }
 #'
 #' 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)
+#' }
+#'
+#' @section Server value:
+#' A character string containing the value of the selected button.
+#'
 #' @export
-radioButtons <- function(inputId, label, choices, selected = NULL,
-  inline = FALSE, width = NULL) {
+radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
 
-  # resolve names
-  choices <- choicesWithNames(choices)
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
 
   selected <- restoreInput(id = inputId, default = selected)
 
   # default value if it's not specified
-  selected <- if (is.null(selected)) choices[[1]] else {
-    validateSelected(selected, choices, inputId)
-  }
+  selected <- if (is.null(selected)) args$choiceValues[[1]] else as.character(selected)
+
   if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
 
-  options <- generateOptions(inputId, choices, selected, inline, type = 'radio')
+  options <- generateOptions(inputId, selected, inline,
+    'radio', args$choiceNames, args$choiceValues)
 
   divClass <- "form-group shiny-input-radiogroup shiny-input-container"
-  if (inline)
-    divClass <- paste(divClass, "shiny-input-container-inline")
+  if (inline) divClass <- paste(divClass, "shiny-input-container-inline")
 
   tags$div(id = inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     class = divClass,
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     options
   )
 }

R/input-select.R

@@ -3,57 +3,83 @@
 #' Create a select list that can be used to choose a single or multiple items
 #' from a list of values.
 #'
-#' By default, \code{selectInput()} and \code{selectizeInput()} use the
-#' JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/brianreavis/selectize.js}) to instead of the basic
-#' select input element. To use the standard HTML select input element, use
-#' \code{selectInput()} with \code{selectize=FALSE}.
+#' By default, `selectInput()` and `selectizeInput()` use the JavaScript library
+#' \pkg{selectize.js} (<https://github.com/selectize/selectize.js>) instead of
+#' the basic select input element. To use the standard HTML select input
+#' element, use `selectInput()` with `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))}
+#' In selectize mode, if the first element in `choices` has a value of `""`, its
+#' name will be treated as a placeholder prompt. For example:
+#' `selectInput("letter", "Letter", c("Choose one" = "", LETTERS))`
 #'
 #' @inheritParams textInput
 #' @param choices List of values to select from. If elements of the list are
-#'   named then that name rather than the value is displayed to the user.
-#' @param selected The initially selected value (or multiple values if
-#'   \code{multiple = TRUE}). If not specified then defaults to the first value
-#'   for single-select lists and no values for multiple select lists.
+#'   named, then that name --- rather than the value --- is displayed to the
+#'   user. It's also possible to group related inputs by providing a named list
+#'   whose elements are (either named or unnamed) lists, vectors, or factors. In
+#'   this case, the outermost names will be used as the group labels (leveraging
+#'   the `<optgroup>` HTML tag) for the elements in the respective sublist. See
+#'   the example section for a small demo of this feature.
+#' @param selected The initially selected value (or multiple values if `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.
+#'   will result in a taller box. Not compatible with `selectize=TRUE`.
+#'   Normally, when `multiple=FALSE`, a select input will be a drop-down list,
+#'   but when `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}}
+#' @seealso [updateSelectInput()] [varSelectInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
 #'
-#' ui <- fluidPage(
-#'   selectInput("variable", "Variable:",
-#'               c("Cylinders" = "cyl",
-#'                 "Transmission" = "am",
-#'                 "Gears" = "gear")),
-#'   tableOutput("data")
+#' # 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)
+#'   }
 #' )
 #'
-#' server <- function(input, output) {
-#'   output$data <- renderTable({
-#'     mtcars[, c("mpg", input$variable), drop = FALSE]
-#'   }, rownames = TRUE)
+#' # demoing group 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)
+#'     })
+#'   }
+#' )
 #' }
 #'
-#' shinyApp(ui, server)
-#' }
+#' @section Server value: A vector of character strings, usually of length
+#'   1, with the value of the selected items. When `multiple=TRUE` and
+#'   nothing is selected, this value will be `NULL`.
+#'
 #' @export
 selectInput <- function(inputId, label, choices, selected = NULL,
-                        multiple = FALSE, selectize = TRUE, width = NULL,
-                        size = NULL) {
+  multiple = FALSE, selectize = TRUE, width = NULL,
+  size = NULL) {
 
   selected <- restoreInput(id = inputId, default = selected)
 
@@ -63,7 +89,7 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   # default value if it's not specified
   if (is.null(selected)) {
     if (!multiple) selected <- firstChoice(choices)
-  } else selected <- validateSelected(selected, choices, inputId)
+  } else selected <- as.character(selected)
 
   if (!is.null(size) && selectize) {
     stop("'size' argument is incompatible with 'selectize=TRUE'.")
@@ -83,7 +109,7 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   res <- div(
     class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     div(selectTag)
   )
 
@@ -131,21 +157,21 @@ needOptgroup <- function(choices) {
 }
 
 #' @rdname selectInput
-#' @param ... Arguments passed to \code{selectInput()}.
+#' @param ... Arguments passed to `selectInput()`.
 #' @param options A list of options. See the documentation of \pkg{selectize.js}
-#'   for possible options (character option values inside \code{\link{I}()} will
-#'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
+#'   for possible options (character option values inside [base::I()] will
+#'   be treated as literal JavaScript code; see [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
+#' @param width The width of the input, e.g. `'400px'`, or `'100%'`;
+#'   see [validateCssUnit()].
+#' @note The selectize input created from `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
+#'   `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)}.
+#'   `choices` argument. This is to keep compatibility with
+#'   `selectInput(..., selectize = FALSE)`.
 #' @export
 selectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
   selectizeIt(
@@ -172,7 +198,7 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   if ('drag_drop' %in% options$plugins) {
     selectizeDep <- list(selectizeDep, htmlDependency(
-      'jqueryui', '1.11.4', c(href = 'shared/jqueryui'),
+      'jqueryui', '1.12.1', c(href = 'shared/jqueryui'),
       script = 'jquery-ui.min.js'
     ))
   }
@@ -190,3 +216,136 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   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.
+#'
+#' By default, `varSelectInput()` and `selectizeInput()` use the
+#' JavaScript library \pkg{selectize.js}
+#' (<https://github.com/selectize/selectize.js>) to instead of the basic
+#' select input element. To use the standard HTML select input element, use
+#' `selectInput()` with `selectize=FALSE`.
+#'
+#' @inheritParams selectInput
+#' @param data A data frame. Used to retrieve the column names as choices for a [selectInput()]
+#' @return A variable select list control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso [updateSelectInput()]
+#'
+#' @section Server value:
+#' The resulting server `input` value will be returned as:
+#'
+#'  * A symbol if `multiple = FALSE`. The `input` value should be
+#'  used with rlang's [rlang::!!()]. For example,
+#'  `ggplot2::aes(!!input$variable)`.
+#'  * A list of symbols if `multiple = TRUE`. The `input` value
+#'  should be used with rlang's [rlang::!!!()] to expand
+#'  the symbol list as individual arguments. For example,
+#'  `dplyr::select(mtcars, !!!input$variabls)` which is
+#'  equivalent to `dplyr::select(mtcars, !!input$variabls[[1]], !!input$variabls[[2]], ..., !!input$variabls[[length(input$variabls)]])`.
+#'
+#' @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 `varSelectInput()`.
+#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#'   for possible options (character option values inside [base::I()] will
+#'   be treated as literal JavaScript code; see [renderDataTable()]
+#'   for details).
+#' @param width The width of the input, e.g. `'400px'`, or `'100%'`;
+#'   see [validateCssUnit()].
+#' @note The variable selectize input created from `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
+#'   `selectInput(..., selectize = TRUE)` will ignore the empty string
+#'   value when it is a single choice input and the empty string is not in the
+#'   `choices` argument. This is to keep compatibility with
+#'   `selectInput(..., selectize = FALSE)`.
+#' @export
+varSelectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
+  selectizeIt(
+    inputId,
+    varSelectInput(inputId, ..., selectize = FALSE, width = width),
+    options
+  )
+}

R/input-slider.R

@@ -8,49 +8,50 @@
 #' @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}.
+#'   fit between `min` and `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
+#'   slider (if `NULL`, a heuristic is used to determine the step size). If
+#'   the values are dates, `step` is in days; if the values are times
+#'   (POSIXt), `step` is in seconds.
+#' @param round `TRUE` to round all values to the nearest integer;
+#'   `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
+#' @param ticks `FALSE` to hide tick marks, `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 animate `TRUE` to show simple animation controls with default
+#'   settings; `FALSE` not to; or a custom settings list, such as those
+#'   created using [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
+#'   values). If `TRUE` (the default), the range can be dragged. In other
+#'   words, the min and max can be dragged together. If `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
+#'   <https://github.com/samsonjs/strftime> for more details. The allowed
 #'   format specifications are very similar, but not identical, to those for R's
-#'   \code{\link{strftime}} function. For Dates, the default is \code{"\%F"}
-#'   (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"}
-#'   (like \code{"2015-07-01 15:32:10"}).
+#'   [base::strftime()] function. For Dates, the default is `"%F"`
+#'   (like `"2015-07-01"`), and for POSIXt, the default is `"%F %T"`
+#'   (like `"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
+#'   `"+HHMM"` or `"-HHMM"`. If `NULL` (the default), times will
+#'   be displayed in the browser's time zone. The value `"+0000"` will
 #'   result in UTC time.
 #' @inheritParams selectizeInput
 #' @family input elements
-#' @seealso \code{\link{updateSliderInput}}
+#' @seealso [updateSliderInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   sliderInput("obs", "Number of observations:",
@@ -69,6 +70,10 @@
 #' # Complete app with UI and server components
 #' shinyApp(ui, server)
 #' }
+#'
+#' @section Server value:
+#' A number, or in the case of slider range, a vector of two numbers.
+#'
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
                         round = FALSE, format = NULL, locale = NULL,
@@ -85,40 +90,25 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
-  value <- restoreInput(id = inputId, default = value)
+  dataType <- getSliderType(min, max, value)
 
-  # If step is NULL, use heuristic to set the step size.
-  findStepSize <- function(min, max, step) {
-    if (!is.null(step)) return(step)
-
-    range <- max - min
-    # If short range or decimals, use continuous decimal with ~100 points
-    if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
-      step <- pretty(c(min, max), n = 100)
-      step[2] - step[1]
-    } else {
-      1
-    }
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if (inherits(min, "Date")) {
-    if (!inherits(max, "Date") || !inherits(value, "Date"))
-      stop("`min`, `max`, and `value must all be Date or non-Date objects")
-    dataType <- "date"
+  # 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.null(timeFormat))
-      timeFormat <- "%F"
-
-  } else if (inherits(min, "POSIXt")) {
-    if (!inherits(max, "POSIXt") || !inherits(value, "POSIXt"))
-      stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
-    dataType <- "datetime"
-
-    if (is.null(timeFormat))
-      timeFormat <- "%F %T"
-
-  } else {
-    dataType <- "number"
+  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)
@@ -164,11 +154,13 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-grid-num` = n_ticks,
     `data-grid-snap` = FALSE,
     `data-prettify-separator` = sep,
+    `data-prettify-enabled` = (sep != ""),
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
-    `data-keyboard-step` = step / (max - min) * 100,
-    `data-drag-interval` = dragRange,
+    # This value is only relevant for range sliders; for non-range sliders it
+    # causes problems since ion.RangeSlider 2.1.2 (issue #1605).
+    `data-drag-interval` = if (length(value) > 1) dragRange,
     # The following are ignored by the ion.rangeSlider, but are used by Shiny.
     `data-data-type` = dataType,
     `data-time-format` = timeFormat,
@@ -184,7 +176,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
 
   sliderTag <- div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    if (!is.null(label)) controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     do.call(tags$input, sliderProps)
   )
 
@@ -214,7 +206,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   }
 
   dep <- list(
-    htmlDependency("ionrangeslider", "2.1.2", c(href="shared/ionrangeslider"),
+    htmlDependency("ionrangeslider", "2.1.6", c(href="shared/ionrangeslider"),
       script = "js/ion.rangeSlider.min.js",
       # ion.rangeSlider also needs normalize.css, which is already included in
       # Bootstrap.
@@ -234,16 +226,44 @@ hasDecimals <- function(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
+#' @param loop `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.
+#'   or list of tags (using [tag()] and friends), or raw HTML (using
+#'   [HTML()]).
+#' @param pauseButton Similar to `playButton`, but for the pause button.
 #' @export
 animationOptions <- function(interval=1000,
                              loop=FALSE,

R/input-submit.R

@@ -1,20 +1,57 @@
 #' Create a submit button
 #'
-#' Create a submit button for an input form. Forms that include a submit
+#' Create a submit button for an app. Apps that include a submit
 #' button do not automatically update their outputs when inputs change,
 #' rather they wait until the user explicitly clicks the submit button.
+#' The use of `submitButton` is generally discouraged in favor of
+#' the more versatile [actionButton()] (see details below).
+#'
+#' Submit buttons are unusual Shiny inputs, and we recommend using
+#' [actionButton()] instead of `submitButton` when you
+#' want to delay a reaction.
+#' See [this
+#' article](http://shiny.rstudio.com/articles/action-buttons.html) for more information (including a demo of how to "translate"
+#' code using a `submitButton` to code using an `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 *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 [renderUI()]
+#' or [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}}.
+#' @param icon Optional [icon()] to appear on the button
+#' @param width The width of the button, e.g. `'400px'`, or `'100%'`;
+#'   see [validateCssUnit()].
 #' @return A submit button that can be added to a UI definition.
 #'
 #' @family input elements
 #'
 #' @examples
-#' submitButton("Update View")
-#' submitButton("Update View", icon("refresh"))
+#' if (interactive()) {
+#'
+#' shinyApp(
+#'   ui = basicPage(
+#'     numericInput("num", label = "Make changes", value = 1),
+#'     submitButton("Update View", icon("refresh")),
+#'     helpText("When you click the button above, you should see",
+#'              "the output below update to reflect the value you",
+#'              "entered at the top:"),
+#'     verbatimTextOutput("value")
+#'   ),
+#'   server = function(input, output) {
+#'
+#'     # submit buttons do not have a value of their own,
+#'     # they control when the app accesses values of other widgets.
+#'     # input$num is the value of the number widget.
+#'     output$value <- renderPrint({ input$num })
+#'   }
+#' )
+#' }
 #' @export
 submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
   div(

R/input-text.R

@@ -2,18 +2,18 @@
 #'
 #' 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 inputId The `input` slot that will be used to access the value.
+#' @param label Display label for the control, or `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 width The width of the input, e.g. `'400px'`, or `'100%'`;
+#'   see [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}}
+#' @seealso [updateTextInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -28,6 +28,11 @@
 #' }
 #' shinyApp(ui, server)
 #' }
+#'
+#' @section Server value:
+#' A character string of the text input. The default value is `""`
+#' unless `value` is provided.
+#'
 #' @export
 textInput <- function(inputId, label, value = "", width = NULL,
   placeholder = NULL) {
@@ -36,7 +41,7 @@ textInput <- function(inputId, label, value = "", width = NULL,
 
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
     tags$input(id = inputId, type="text", class="form-control", value=value,
       placeholder = placeholder)
   )

R/input-textarea.R

@@ -3,22 +3,23 @@
 #' 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 height The height of the input, e.g. `'400px'`, or `'100%'`; see
+#'   [validateCssUnit()].
+#' @param cols Value of the visible character columns of the input, e.g. `80`.
+#'   This argument will only take effect if there is not a CSS `width` rule
+#'   defined for this element; such a rule could come from the `width` argument
+#'   of this function or from a containing page layout such as
+#'   [fluidPage()].
+#' @param rows The value of the visible character rows of the input, e.g. `6`.
+#'   If the `height` argument is specified, `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.
+#'   `"both"`, `"none"`, `"vertical"`, and `"horizontal"`. The default, `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}}
+#' @seealso [updateTextAreaInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -34,6 +35,11 @@
 #' shinyApp(ui, server)
 #'
 #' }
+#'
+#' @section Server value:
+#' A character string of the text input. The default value is `""`
+#' unless `value` is provided.
+#'
 #' @export
 textAreaInput <- function(inputId, label, value = "", width = NULL, height = NULL,
   cols = NULL, rows = NULL, placeholder = NULL, resize = NULL) {
@@ -55,7 +61,7 @@ textAreaInput <- function(inputId, label, value = "", width = NULL, height = NUL
   if (length(style) == 0) style <- NULL
 
   div(class = "form-group shiny-input-container",
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
     tags$textarea(
       id = inputId,
       class = "form-control",

R/input-utils.R

@@ -1,43 +1,68 @@
-controlLabel <- function(controlName, label) {
-  label %AND% tags$label(class = "control-label", `for` = controlName, label)
+shinyInputLabel <- function(inputId, label = NULL) {
+  tags$label(
+    label,
+    class = "control-label",
+    class = if (is.null(label)) "shiny-label-null",
+    `for` = inputId
+  )
 }
 
-
-# Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
-# refers to values. Below is a function for backward compatibility.
-validateSelected <- function(selected, choices, inputId) {
-  # drop names, otherwise toJSON() keeps them too
-  selected <- unname(selected)
-  # if you are using optgroups, you're using shiny > 0.10.0, and you should
-  # already know that `selected` must be a value instead of a label
-  if (needOptgroup(choices)) return(selected)
-
-  if (is.list(choices)) choices <- unlist(choices)
-
-  nms <- names(choices)
-  # labels and values are identical, no need to validate
-  if (identical(nms, unname(choices))) return(selected)
-  # when selected labels instead of values
-  i <- (selected %in% nms) & !(selected %in% choices)
-  if (any(i)) {
-    warnFun <- if (all(i)) {
-      # replace names with values
-      selected <- unname(choices[selected])
-      warning
-    } else stop  # stop when it is ambiguous (some labels == values)
-    warnFun("'selected' must be the values instead of names of 'choices' ",
-            "for the input '", inputId, "'")
+# This function takes in either a list or vector for `choices` (and
+# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
+# in a list or vector for both `choiceNames` and `choiceValues` (and
+# `choices` is passed as NULL) and returns a list of two elements:
+#    - `choiceNames` is a vector or list that holds the options names
+#      (each element can be arbitrary UI, or simple text)
+#    - `choiceValues` is a vector or list that holds the options values
+#       (each element must be simple text)
+normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
+  mustExist = TRUE) {
+  # if-else to check that either choices OR (choiceNames + choiceValues)
+  # were correctly provided
+  if (is.null(choices)) {
+    if (is.null(choiceNames) || is.null(choiceValues)) {
+      if (mustExist) {
+        stop("Please specify a non-empty vector for `choices` (or, ",
+             "alternatively, for both `choiceNames` AND `choiceValues`).")
+      } else {
+        if (is.null(choiceNames) && is.null(choiceValues)) {
+          # this is useful when we call this function from `updateInputOptions()`
+          # in which case, all three `choices`, `choiceNames` and `choiceValues`
+          # may legitimately be NULL
+          return(list(choiceNames = NULL, choiceValues = NULL))
+        } else {
+          stop("One of `choiceNames` or `choiceValues` was set to ",
+               "NULL, but either both or none should be NULL.")
+        }
+      }
+    }
+    if (length(choiceNames) != length(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must have the same length.")
+    }
+    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must not be named.")
+    }
+  } else {
+    if (!is.null(choiceNames) || !is.null(choiceValues)) {
+      warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
+    }
+    choices <- choicesWithNames(choices) # resolve names if not specified
+    choiceNames <- names(choices)
+    choiceValues <- unname(choices)
   }
-  selected
-}
 
+  return(list(choiceNames = as.list(choiceNames),
+              choiceValues = as.list(as.character(choiceValues))))
+}
 
 # generate options for radio buttons and checkbox groups (type = 'checkbox' or
 # 'radio')
-generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox') {
+generateOptions <- function(inputId, selected, inline, type = 'checkbox',
+                            choiceNames, choiceValues,
+                            session = getDefaultReactiveDomain()) {
   # generate a list of <input type=? [checked] />
   options <- mapply(
-    choices, names(choices),
+    choiceValues, choiceNames,
     FUN = function(value, name) {
       inputTag <- tags$input(
         type = type, name = inputId, value = value
@@ -45,14 +70,18 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
       if (value %in% selected)
         inputTag$attribs$checked <- "checked"
 
+      # in case, the options include UI code other than text
+      # (arbitrary HTML using the tags() function or equivalent)
+      pd <- processDeps(name, session)
+
       # If inline, there's no wrapper div, and the label needs a class like
       # checkbox-inline.
       if (inline) {
-        tags$label(class = paste0(type, "-inline"), inputTag, tags$span(name))
+        tags$label(class = paste0(type, "-inline"), inputTag,
+                   tags$span(pd$html, pd$deps))
       } else {
-        tags$div(class = type,
-          tags$label(inputTag, tags$span(name))
-        )
+        tags$div(class = type, tags$label(inputTag,
+                 tags$span(pd$html, pd$deps)))
       }
     },
     SIMPLIFY = FALSE, USE.NAMES = FALSE
@@ -61,45 +90,83 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
   div(class = "shiny-options-group", options)
 }
 
-
-# Takes a vector or list, and adds names (same as the value) to any entries
-# without names.
-choicesWithNames <- function(choices) {
-  # Take a vector or list, and convert to list. Also, if any children are
-  # vectors with length > 1, convert those to list. If the list is unnamed,
-  # convert it to a named list with blank names.
-  listify <- function(obj) {
-    # If a list/vector is unnamed, give it blank names
-    makeNamed <- function(x) {
-      if (is.null(names(x))) names(x) <- character(length(x))
-      x
-    }
-
-    res <- lapply(obj, function(val) {
-      if (is.list(val))
-        listify(val)
-      else if (length(val) == 1 && is.null(names(val)))
-        val
-      else
-        makeNamed(as.list(val))
-    })
-
-    makeNamed(res)
-  }
-
-  choices <- listify(choices)
-  if (length(choices) == 0) return(choices)
-
-  # Recurse into any subgroups
-  choices <- mapply(choices, names(choices), FUN = function(choice, name) {
-    if (!is.list(choice)) return(choice)
-    if (name == "") stop('All sub-lists in "choices" must be named.')
-    choicesWithNames(choice)
-  }, SIMPLIFY = FALSE)
-
-  # default missing names to choice values
-  missing <- names(choices) == ""
-  names(choices)[missing] <- as.character(choices)[missing]
-
-  choices
+# True when a choice list item represents a group of related inputs.
+isGroup <- function(choice) {
+  is.list(choice) ||
+    !is.null(names(choice)) ||
+    length(choice) > 1 ||
+    length(choice) == 0
+}
+
+# True when choices is a list and contains at least one group of related inputs.
+hasGroups <- function(choices) {
+  is.list(choices) && any(vapply(choices, isGroup, logical(1)))
+}
+
+# Assigns empty names to x if it's unnamed, and then fills any empty names with
+# the corresponding value coerced to a character(1).
+setDefaultNames <- function(x) {
+  x <- asNamed(x)
+  emptyNames <- names(x) == ""
+  names(x)[emptyNames] <- as.character(x)[emptyNames]
+  x
+}
+
+# Makes a character vector out of x in a way that preserves names.
+asCharacter <- function(x) {
+  stats::setNames(as.character(x), names(x))
+}
+
+# Processes a "flat" set of choices, or a collection of choices not containing
+# any named groups. choices should be a list without any list children, or an
+# atomic vector. choices may be named or unnamed. Any empty names are replaced
+# with the corresponding value coerced to a character.
+processFlatChoices <- function(choices) {
+  choices <- setDefaultNames(asCharacter(choices))
+  as.list(choices)
+}
+
+# Processes a "nested" set of choices, or a collection of choices that contains
+# one or more named groups of related choices and zero or more "flat" choices.
+# choices should be a named list, and any choice group must have a non-empty
+# name. Empty names of remaining "flat" choices are replaced with that choice's
+# value coerced to a character.
+processGroupedChoices <- function(choices) {
+  # We assert choices is a list, since only a list may contain a group.
+  stopifnot(is.list(choices))
+  # The list might be unnamed by this point. We add default names of "" so that
+  # names(choices) is not zero-length and mapply can work. Within mapply, we
+  # error if any group's name is ""
+  choices <- asNamed(choices)
+  choices <- mapply(function(name, choice) {
+    choiceIsGroup <- isGroup(choice)
+    if (choiceIsGroup && name == "") {
+      # If the choice is a group, and if its name is empty, produce an error. We
+      # error here because the composite nature of the choice prevents us from
+      # meaningfully automatically naming it. Note that while not documented,
+      # groups are not necessarily lists (aka generic vectors) but can also be
+      # any named atomic vector, or any atomic vector of length > 1.
+      stop('All sub-lists in "choices" must be named.')
+    } else if (choiceIsGroup) {
+      # The choice is a group, but it is named. Process it using the same
+      # function we use for "top level" choices.
+      processFlatChoices(choice)
+    } else {
+      # The choice was not named and is not a group; it is a "leaf".
+      as.character(choice)
+    }
+  }, names(choices), choices, SIMPLIFY = FALSE)
+  # By this point, any leaves in the choices list might still have empty names,
+  # so we're sure to automatically name them.
+  setDefaultNames(choices)
+}
+
+# Takes a vector/list/factor, and adds names (same as the value) to any entries
+# without names. Coerces all leaf nodes to `character`.
+choicesWithNames <- function(choices) {
+  if (hasGroups(choices)) {
+    processGroupedChoices(choices)
+  } else {
+    processFlatChoices(choices)
+  }
 }

R/insert-tab.R

@@ -0,0 +1,325 @@
+#' Dynamically insert/remove a tabPanel
+#'
+#' Dynamically insert or remove a [tabPanel()] (or a
+#' [navbarMenu()]) from an existing [tabsetPanel()],
+#' [navlistPanel()] or [navbarPage()].
+#'
+#' When you want to insert a new tab before or after an existing tab, you
+#' should use `insertTab`. When you want to prepend a tab (i.e. add a
+#' tab to the beginning of the `tabsetPanel`), use `prependTab`.
+#' When you want to append a tab (i.e. add a tab to the end of the
+#' `tabsetPanel`), use `appendTab`.
+#'
+#' For `navbarPage`, you can insert/remove conventional
+#' `tabPanel`s (whether at the top level or nested inside a
+#' `navbarMenu`), as well as an entire [navbarMenu()].
+#' For the latter case, `target` should be the `menuName` that
+#' you gave your `navbarMenu` when you first created it (by default,
+#' this is equal to the value of the `title` argument).
+#'
+#' @param inputId The `id` of the `tabsetPanel` (or
+#'   `navlistPanel` or `navbarPage`) into which `tab` will
+#'   be inserted/removed.
+#'
+#' @param tab The item to be added (must be created with `tabPanel`,
+#'   or with `navbarMenu`).
+#'
+#' @param target If inserting: the `value` of an existing
+#'   `tabPanel`, next to which `tab` will be added.
+#'   If removing: the `value` of the `tabPanel` that
+#'   you want to remove. See Details if you want to insert next to/remove
+#'   an entire `navbarMenu` instead.
+#'
+#' @param position Should `tab` be added before or after the
+#'   `target` tab?
+#'
+#' @param select Should `tab` be selected upon being inserted?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso [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) `tab` to the beginning (or end) of an
+#'   existing [navbarMenu()] (which must itself be part of
+#'   an existing [navbarPage()]). In this case, this argument
+#'   should be the `menuName` that you gave your `navbarMenu`
+#'   when you first created it (by default, this is equal to the value
+#'   of the `title` argument). Note that you still need to set the
+#'   `inputId` argument to whatever the `id` of the parent
+#'   `navbarPage` is. If `menuName` is left as `NULL`,
+#'   `tab` will be prepended (or appended) to whatever
+#'   `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 [tabPanel()] (or a
+#' [navbarMenu()])from an existing [tabsetPanel()],
+#' [navlistPanel()] or [navbarPage()].
+#'
+#' For `navbarPage`, you can hide/show conventional
+#' `tabPanel`s (whether at the top level or nested inside a
+#' `navbarMenu`), as well as an entire [navbarMenu()].
+#' For the latter case, `target` should be the `menuName` that
+#' you gave your `navbarMenu` when you first created it (by default,
+#' this is equal to the value of the `title` argument).
+#'
+#' @param inputId The `id` of the `tabsetPanel` (or
+#'   `navlistPanel` or `navbarPage`) in which to find
+#'   `target`.
+#'
+#' @param target The `value` of the `tabPanel` to be
+#'   hidden/shown. See Details if you want to hide/show an entire
+#'   `navbarMenu` instead.
+#'
+#' @param select Should `target` be selected upon being shown?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso [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

@@ -1,55 +1,54 @@
-#' Insert UI objects
+#' Insert and remove 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
+#' These functions allow you to dynamically add and remove arbirary UI
+#' into your app, whenever you want, as many times as you want.
+#' Unlike [renderUI()], the UI generated with `insertUI()` is persistent:
+#' once it's created, it stays there until removed by `removeUI()`. Each
+#' new call to `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}}.
+#' appropriate `render` function or a customized `reactive`
+#' 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) relative to which you want to insert your
-#' UI object.
+#' It's particularly useful to pair `removeUI` with `insertUI()`, but there is
+#' no restriction on what you can use 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 `s` to be placed in a `$(s)` jQuery call).
+#'
+#'   For `insertUI()` this determines the element(s) relative to which you
+#'   want to insert your UI object. For `removeUI()` this 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 `<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 `<div>` with an id.)
 #' @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}.
-#'
+#'   \describe{
+#'     \item{`beforeBegin`}{Before the selector element itself}
+#'     \item{`afterBegin`}{Just inside the selector element, before its
+#'     first child}
+#'     \item{`beforeEnd`}{Just inside the selector element, after its
+#'     last child (default)}
+#'     \item{`afterEnd`}{After the selector element itself}
+#'   }
+#'   Adapted from <https://developer.mozilla.org/en-US/docs/Web/API/Element/insertAdjacentHTML>.
 #' @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()}.
-#'
+#'   you usually put inside your apps's `ui` function. If you're inserting
+#'   multiple elements in one call, make sure to wrap them in either a
+#'   `tagList()` or a `tags$div()` (the latter option has the
+#'   advantage that you can give it an `id` to make it easier to
+#'   reference or remove it later on). If you want to insert raw html, use
+#'   `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}}
-#'
+#'   `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
+#'   or removed, or whether Shiny should wait until all outputs have been
+#'   updated and all observers have been run (default).
+#' @param session The shiny session. Advanced use only.
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
@@ -73,6 +72,26 @@
 #' # Complete app with UI and server components
 #' shinyApp(ui, server)
 #' }
+#'
+#' 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
 insertUI <- function(selector,
   where = c("beforeBegin", "afterBegin", "beforeEnd", "afterEnd"),
@@ -100,60 +119,7 @@ insertUI <- function(selector,
 }
 
 
-#' 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)
-#' }
+#' @rdname insertUI
 #' @export
 removeUI <- function(selector,
   multiple = FALSE,

R/jqueryui.R

@@ -2,32 +2,32 @@
 #'
 #' Creates a panel whose contents are absolutely positioned.
 #'
-#' The \code{absolutePanel} function creates a \code{<div>} tag whose CSS
-#' position is set to \code{absolute} (or fixed if \code{fixed = TRUE}). The way
+#' The `absolutePanel` function creates a `<div>` tag whose CSS
+#' position is set to `absolute` (or fixed if `fixed = TRUE`). The way
 #' absolute positioning works in HTML is that absolute coordinates are specified
 #' relative to its nearest parent element whose position is not set to
-#' \code{static} (which is the default), and if no such parent is found, then
+#' `static` (which is the default), and if no such parent is found, then
 #' relative to the page borders. If you're not sure what that means, just keep
-#' in mind that you may get strange results if you use \code{absolutePanel} from
+#' in mind that you may get strange results if you use `absolutePanel` from
 #' inside of certain types of panels.
 #'
-#' The \code{fixedPanel} function is the same as \code{absolutePanel} with
-#' \code{fixed = TRUE}.
+#' The `fixedPanel` function is the same as `absolutePanel` with
+#' `fixed = TRUE`.
 #'
-#' The position (\code{top}, \code{left}, \code{right}, \code{bottom}) and size
-#' (\code{width}, \code{height}) parameters are all optional, but you should
-#' specify exactly two of \code{top}, \code{bottom}, and \code{height} and
-#' exactly two of \code{left}, \code{right}, and \code{width} for predictable
+#' The position (`top`, `left`, `right`, `bottom`) and size
+#' (`width`, `height`) parameters are all optional, but you should
+#' specify exactly two of `top`, `bottom`, and `height` and
+#' exactly two of `left`, `right`, and `width` for predictable
 #' results.
 #'
 #' Like most other distance parameters in Shiny, the position and size
 #' parameters take a number (interpreted as pixels) or a valid CSS size string,
-#' such as \code{"100px"} (100 pixels) or \code{"25\%"}.
+#' such as `"100px"` (100 pixels) or `"25%"`.
 #'
 #' For arcane HTML reasons, to have the panel fill the page or parent you should
-#' specify \code{0} for \code{top}, \code{left}, \code{right}, and \code{bottom}
-#' rather than the more obvious \code{width = "100\%"} and \code{height =
-#' "100\%"}.
+#' specify `0` for `top`, `left`, `right`, and `bottom`
+#' rather than the more obvious `width = "100%"` and `height =
+#' "100%"`.
 #'
 #' @param ... Attributes (named arguments) or children (unnamed arguments) that
 #'   should be included in the panel.
@@ -42,16 +42,16 @@
 #'   page or parent container.
 #' @param width Width of the panel.
 #' @param height Height of the panel.
-#' @param draggable If \code{TRUE}, allows the user to move the panel by
+#' @param draggable If `TRUE`, allows the user to move the panel by
 #'   clicking and dragging.
 #' @param fixed Positions the panel relative to the browser window and prevents
 #'   it from being scrolled with the rest of the page.
 #' @param cursor The type of cursor that should appear when the user mouses over
-#'   the panel. Use \code{"move"} for a north-east-south-west icon,
-#'   \code{"default"} for the usual cursor arrow, or \code{"inherit"} for the
+#'   the panel. Use `"move"` for a north-east-south-west icon,
+#'   `"default"` for the usual cursor arrow, or `"inherit"` for the
 #'   usual cursor behavior (including changing to an I-beam when the cursor is
-#'   over text). The default is \code{"auto"}, which is equivalent to
-#'   \code{ifelse(draggable, "move", "inherit")}.
+#'   over text). The default is `"auto"`, which is equivalent to
+#'   `ifelse(draggable, "move", "inherit")`.
 #' @return An HTML element or list of elements.
 #' @export
 absolutePanel <- function(...,
@@ -79,8 +79,6 @@ absolutePanel <- function(...,
   if (isTRUE(draggable)) {
     divTag <- tagAppendAttributes(divTag, class='draggable')
     return(tagList(
-      # IMPORTANT NOTE: If you update jqueryui, make sure you DON'T include the datepicker,
-      # as it collides with our bootstrap datepicker!
       singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
       divTag,
       tags$script('$(".draggable").draggable();')

R/map.R

@@ -9,63 +9,58 @@
 # Remove of unknown key does nothing
 # Setting a key twice always results in last-one-wins
 # /TESTS
+
+# Note that Map objects can't be saved in one R session and restored in
+# another, because they are based on fastmap, which uses an external pointer,
+# and external pointers can't be saved and restored in another session.
+#' @importFrom fastmap fastmap
 Map <- R6Class(
   'Map',
   portable = FALSE,
   public = list(
     initialize = function() {
-      private$env <- new.env(parent=emptyenv())
+      private$map <<- fastmap()
     },
     get = function(key) {
-      env[[key]]
+      map$get(key)
     },
     set = function(key, value) {
-      env[[key]] <- value
+      map$set(key, value)
       value
     },
     mget = function(keys) {
-      base::mget(keys, env)
+      map$mget(keys)
     },
     mset = function(...) {
-      args <- list(...)
-      if (length(args) == 0)
-        return()
-
-      arg_names <- names(args)
-      if (is.null(arg_names) || any(!nzchar(arg_names)))
-        stop("All elements must be named")
-
-      list2env(args, envir = env)
+      map$mset(...)
     },
     remove = function(key) {
-      if (!self$containsKey(key))
+      if (!map$has(key))
         return(NULL)
 
-      result <- env[[key]]
-      rm(list=key, envir=env, inherits=FALSE)
+      result <- map$get(key)
+      map$remove(key)
       result
     },
     containsKey = function(key) {
-      exists(key, envir=env, inherits=FALSE)
+      map$has(key)
     },
-    keys = function() {
-      # Sadly, this is much faster than ls(), because it doesn't sort the keys.
-      names(as.list(env, all.names=TRUE))
+    keys = function(sort = FALSE) {
+      map$keys(sort = sort)
     },
-    values = function() {
-      as.list(env, all.names=TRUE)
+    values = function(sort = FALSE) {
+      map$as_list(sort = sort)
     },
     clear = function() {
-      private$env <- new.env(parent=emptyenv())
-      invisible(NULL)
+      map$reset()
     },
     size = function() {
-      length(env)
+      map$size()
     }
   ),
 
   private = list(
-    env = 'environment'
+    map = NULL
   )
 )
 

R/middleware-shiny.R

@@ -2,19 +2,64 @@
 NULL
 
 reactLogHandler <- function(req) {
-  if (!identical(req$PATH_INFO, '/reactlog'))
-    return(NULL)
+  if (! rLog$isLogging()) {
+    if (
+      identical(req$PATH_INFO, "/reactlog/mark") ||
+      identical(req$PATH_INFO, "/reactlog")
+    ) {
+      # is not logging, but is a reactlog path...
+
+      return(
+        httpResponse(
+          # Not Implemented
+          # - The server either does not recognize the request method, or it lacks the ability to fulfil the request.
+          status = 501,
+          content_type = "text/plain; charset=utf-8",
+          content = "To enable reactlog, set the following option before running the application: \n\noptions(shiny.reactlog = TRUE)"
+        )
+      )
+
+    } else {
+      # continue on like normal
+      return(NULL)
+    }
 
-  if (!isTRUE(getOption('shiny.reactlog'))) {
-    return(NULL)
   }
 
-  sessionToken <- parseQueryString(req$QUERY_STRING)$s
+  if (identical(req$PATH_INFO, "/reactlog/mark")) {
+    sessionToken <- parseQueryString(req$QUERY_STRING)$s
+    shinysession <- appsByToken$get(sessionToken)
 
-  return(httpResponse(
-    status=200,
-    content=list(file=renderReactLog(sessionToken), owned=TRUE)
-  ))
+    # log time
+    withReactiveDomain(shinysession, {
+      rLog$userMark(getDefaultReactiveDomain())
+    })
+
+    return(httpResponse(
+      status = 200,
+      content = "marked",
+      content_type = "text/plain"
+    ))
+
+  } else if (identical(req$PATH_INFO, "/reactlog")){
+
+    sessionToken <- parseQueryString(req$QUERY_STRING)$s
+
+    # `renderReactLog` will check/throw if reactlog doesn't exist
+    reactlogFile <- renderReactlog(sessionToken)
+
+    return(httpResponse(
+      status = 200,
+      content = list(
+        file = reactlogFile,
+        owned = TRUE
+      )
+    ))
+
+  } else {
+    # continue on like normal
+    return(NULL)
+  }
 }
 
 sessionHandler <- function(req) {

R/middleware.R

@@ -191,7 +191,7 @@ staticHandler <- function(root) {
     if (!identical(req$REQUEST_METHOD, 'GET'))
       return(NULL)
 
-    path <- req$PATH_INFO
+    path <- URLdecode(req$PATH_INFO)
 
     if (is.null(path))
       return(httpResponse(400, content="<h1>Bad Request</h1>"))
@@ -199,6 +199,9 @@ staticHandler <- function(root) {
     if (path == '/')
       path <- '/index.html'
 
+    if (grepl('\\', path, fixed = TRUE))
+      return(NULL)
+
     abs.path <- resolve(root, path)
     if (is.null(abs.path))
       return(NULL)
@@ -321,21 +324,20 @@ HandlerManager <- R6Class("HandlerManager",
               }
             )
           },
-          getOption('shiny.sharedSecret')
+          loadSharedSecret()
         ),
         onWSOpen = function(ws) {
           return(wsHandlers$invoke(ws))
         }
       )
     },
-    .httpServer = function(handler, sharedSecret) {
+    .httpServer = function(handler, checkSharedSecret) {
       filter <- getOption('shiny.http.response.filter')
       if (is.null(filter))
         filter <- function(req, response) response
 
       function(req) {
-        if (!is.null(sharedSecret)
-          && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
+        if (!checkSharedSecret(req$HTTP_SHINY_SHARED_SECRET)) {
           return(list(status=403,
             body='<h1>403 Forbidden</h1><p>Shared secret mismatch</p>',
             headers=list('Content-Type' = 'text/html')))
@@ -351,38 +353,72 @@ HandlerManager <- R6Class("HandlerManager",
         }
 
         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
+        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
+              ))
+            }
 
-          response <- filter(req, response)
-          if (head_request) {
-            headers$`Content-Length` <- nchar(response$content, type = "bytes")
-            return(list(
-              status = response$status,
-              body = "",
-              headers = headers
-            ))
           } else {
-            return(list(
-              status = response$status,
-              body = response$content,
-              headers = headers
-            ))
+            # Assume it's a Rook-compatible response
+            return(response)
           }
-
-        } 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/mock-session.R

@@ -0,0 +1,455 @@
+# Promise helpers taken from:
+#   https://github.com/rstudio/promises/blob/master/tests/testthat/common.R
+# Block until all pending later tasks have executed
+wait_for_it <- function() {
+  while (!later::loop_empty()) {
+    later::run_now(0.1)
+  }
+}
+
+# Block until the promise is resolved/rejected. If resolved, return the value.
+# If rejected, throw (yes throw, not return) the error.
+#' @importFrom promises %...!%
+#' @importFrom promises %...>%
+extract <- function(promise) {
+  promise_value <- NULL
+  error <- NULL
+  promise %...>%
+    (function(value) promise_value <<- value) %...!%
+    (function(reason) error <<- reason)
+
+  wait_for_it()
+  if (!is.null(error))
+    stop(error)
+  else
+    promise_value
+}
+
+# TODO: is there a way to get this behavior without exporting these functions? R6?
+# TODO: clientData is documented as a reactiveValues, which this is not. Is it possible that
+#   users are currently assigning into clientData? That would not work as expected here.
+#' @noRd
+#' @export
+`$.mockclientdata` <- function(x, name) {
+  if (name == "allowDataUriScheme") { return(TRUE) }
+  if (name == "pixelratio") { return(1) }
+  if (name == "url_protocol") { return("http:") }
+  if (name == "url_hostname") { return("mocksession") }
+  if (name == "url_port") { return(1234) }
+  if (name == "url_pathname") { return("/mockpath") }
+  if (name == "url_hash") { return("#mockhash") }
+  if (name == "url_hash_initial") { return("#mockhash") }
+  if (name == "url_search") { return("?mocksearch=1") }
+
+  clientRE <- "^output_(.+)_([^_]+)$"
+  if(grepl(clientRE, name)) {
+    # TODO: use proper regex group matching here instead of redundantly parsing
+    el <- sub(clientRE, "\\1", name)
+    att <- sub(clientRE, "\\2", name)
+
+    if (att == "width") {
+      return(600)
+    } else if (att == "height") {
+      return(400)
+    } else if (att == "hidden") {
+      return(FALSE)
+    }
+  }
+  warning("Unexpected clientdata attribute accessed: ", name)
+  return(NULL)
+}
+
+#' @noRd
+#' @export
+`[[.mockclientdata` <- `$.mockclientdata`
+
+#' @noRd
+#' @export
+`[.mockclientdata` <- function(values, name) {
+  stop("Single-bracket indexing of mockclientdata is not allowed.")
+}
+
+#' @noRd
+mapNames <- function(func, ...) {
+  vals <- list(...)
+  names(vals) <- vapply(names(vals), func, character(1))
+  vals
+}
+
+#' Mock Shiny Session
+#'
+#' @description
+#' An R6 class suitable for testing that simulates the `session` parameter
+#' provided to Shiny server functions or modules.
+#'
+#' @include timer.R
+#' @export
+MockShinySession <- R6Class(
+  'MockShinySession',
+  portable = FALSE,
+  public = list(
+    #' @field env The environment associated with the session.
+    env = NULL,
+    #' @field returned The value returned by the module.
+    returned = NULL,
+    #' @field singletons Hardcoded as empty. Needed for rendering HTML (i.e. renderUI)
+    singletons = character(0),
+    #' @field clientData Mock client data that always returns a size for plots
+    clientData = structure(list(), class="mockclientdata"),
+    #' @description No-op
+    #' @param logEntry Not used
+    reactlog = function(logEntry){},
+    #' @description No-op
+    incrementBusyCount = function(){},
+    #' @field output The shinyoutputs associated with the session
+    output = NULL,
+    #' @field input The reactive inputs associated with the session
+    input = NULL,
+    #' @field userData An environment initialized as empty.
+    userData = NULL,
+    #' @field progressStack A stack of progress objects
+    progressStack = 'Stack',
+
+    #' @description Create a new MockShinySession
+    initialize = function() {
+      private$.input <- ReactiveValues$new(dedupe = FALSE, label = "input")
+      private$flushCBs <- Callbacks$new()
+      private$flushedCBs <- Callbacks$new()
+      private$endedCBs <- Callbacks$new()
+      private$timer <- MockableTimerCallbacks$new()
+      self$progressStack <- Stack$new()
+
+      self$userData <- new.env(parent=emptyenv())
+
+      # create output
+      out <- .createOutputWriter(self)
+      class(out) <- "shinyoutput"
+      self$output <- out
+
+      # Create a read-only copy of the inputs reactive.
+      self$input <- .createReactiveValues(private$.input, readonly = TRUE)
+    },
+    #' @description Define a callback to be invoked before a reactive flush
+    #' @param fun The function to invoke
+    #' @param once If `TRUE`, will only run once. Otherwise, will run every time reactives are flushed.
+    onFlush = function(fun, once=TRUE) {
+      if (!isTRUE(once)) {
+        return(private$flushCBs$register(fun))
+      } else {
+        dereg <- private$flushCBs$register(function() {
+          dereg()
+          fun()
+        })
+        return(dereg)
+      }
+    },
+    #' @description Define a callback to be invoked after a reactive flush
+    #' @param fun The function to invoke
+    #' @param once If `TRUE`, will only run once. Otherwise, will run every time reactives are flushed.
+    onFlushed = function(fun, once=TRUE) {
+      if (!isTRUE(once)) {
+        return(private$flushedCBs$register(fun))
+      } else {
+        dereg <- private$flushedCBs$register(function() {
+          dereg()
+          fun()
+        })
+        return(dereg)
+      }
+    },
+    #' @description Define a callback to be invoked when the session ends
+    #' @param sessionEndedCallback The callback to invoke when the session has ended.
+    onEnded = function(sessionEndedCallback) {
+      private$endedCBs$register(sessionEndedCallback)
+    },
+
+    #' @description Returns `FALSE` if the session has not yet been closed
+    isEnded = function(){ private$closed },
+    #' @description Returns `FALSE` if the session has not yet been closed
+    isClosed = function(){ private$closed },
+    #' @description Closes the session
+    close = function(){ private$closed <- TRUE },
+
+    #FIXME: this is wrong. Will need to be more complex.
+    #' @description Unsophisticated mock implementation that merely invokes
+    #'   the given callback immediately.
+    #' @param callback The callback ato be invoked.
+    cycleStartAction = function(callback){ callback() },
+
+    #' @description Base64-encode the given file. Needed for image rendering.
+    #' @param name Not used
+    #' @param file The file to be encoded
+    #' @param contentType The content type of the base64-encoded string
+    fileUrl = function(name, file, contentType='application/octet-stream') {
+      bytes <- file.info(file)$size
+      if (is.na(bytes))
+        return(NULL)
+
+      fileData <- readBin(file, 'raw', n=bytes)
+      b64 <- rawToBase64(fileData)
+      return(paste('data:', contentType, ';base64,', b64, sep=''))
+    },
+
+    #' @description Sets reactive values associated with the `session$inputs` object
+    #'   and flushes the reactives.
+    #' @param ... The inputs to set.
+    #' @examples
+    #' s <- MockShinySession$new()
+    #' s$setInputs(x=1, y=2)
+    setInputs = function(...) {
+      vals <- list(...)
+      mapply(names(vals), vals, FUN = function(name, value) {
+        private$.input$set(name, value)
+      })
+      private$flush()
+    },
+
+    #' @description An internal method which shouldn't be used by others.
+    #' @param millis The number of milliseconds on which to schedule a callback
+    #' @param callback The function to schedule
+    .scheduleTask = function(millis, callback) {
+      id <- private$timer$schedule(millis, callback)
+
+      # Return a deregistration callback
+      function() {
+        invisible(private$timer$unschedule(id))
+      }
+    },
+
+    #' @description Simulate the passing of time by the given number of milliseconds.
+    #' @param millis The number of milliseconds to advance time.
+    elapse = function(millis) {
+      msLeft <- millis
+
+      while (msLeft > 0){
+        t <- private$timer$timeToNextEvent()
+
+        if (is.infinite(t) || t <= 0 || msLeft < t){
+          # Either there's no good upcoming event or we can't make it to it in the allotted time.
+          break
+        }
+        msLeft <- msLeft - t
+        private$timer$elapse(t)
+
+        # timerCallbacks must run before flushReact.
+        private$timer$executeElapsed()
+        private$flush()
+      }
+
+      private$timer$elapse(msLeft)
+
+      # Run again in case our callbacks resulted in a scheduled
+      # function that needs executing.
+      private$timer$executeElapsed()
+      private$flush()
+    },
+
+    #' @description An internal method which shouldn't be used by others.
+    .now = function() {
+      # Returns elapsed time in milliseconds
+      private$timer$getElapsed()
+    },
+
+    #' @description An internal method which shouldn't be used by others.
+    #' @param name The name of the output
+    #' @param func The render definition
+    #' @param label Not used
+    defineOutput = function(name, func, label) {
+      force(name)
+
+      if (!is.null(private$outs[[name]]$obs)) {
+        private$outs[[name]]$obs$destroy()
+      }
+
+      if (is.null(func)) func <- missingOutput
+
+      if (!is.function(func))
+        stop(paste("Unexpected", class(func), "output for", name))
+
+      obs <- observe({
+        # We could just stash the promise, but we get an "unhandled promise error". This bypasses
+        prom <- NULL
+        tryCatch({
+          v <- func(self, name)
+          if (!promises::is.promise(v)){
+            # Make our sync value into a promise
+            prom <- promises::promise(function(resolve, reject){ resolve(v) })
+          } else {
+            prom <- v
+          }
+        }, error=function(e){
+          # Error running value()
+          prom <<- promises::promise(function(resolve, reject){ reject(e) })
+        })
+
+        private$outs[[name]]$promise <- hybrid_chain(
+          prom,
+          function(v){
+            list(val = v, err = NULL)
+          }, catch=function(e){
+            list(val = NULL, err = e)
+          })
+      })
+      private$outs[[name]] <- list(obs = obs, func = func, promise = NULL)
+    },
+
+    #' @description An internal method which shouldn't be used by others.
+    #' @param name The name of the output
+    getOutput = function(name) {
+      # Unlike the real outputs, we're going to return the last value rather than the unevaluated function
+      if (is.null(private$outs[[name]])) {
+        stop("The test referenced an output that hasn't been defined yet: output$", name)
+      }
+
+      if (is.null(private$outs[[name]]$promise)) {
+        # Means the output was defined but the observer hasn't had a chance to run
+        # yet. Run flushReact() now to force the observer to run.
+        flushReact()
+
+        if (is.null(private$outs[[name]]$promise)) {
+          stop("output$", name, " encountered an unexpected error resolving its promise")
+        }
+      }
+
+      # Make promise return
+      v <- extract(private$outs[[name]]$promise)
+      if (!is.null(v$err)){
+        stop(v$err)
+      } else {
+        v$val
+      }
+    },
+
+    #' @description No-op
+    #' @param name Not used
+    #' @param data Not used
+    #' @param filterFunc Not used
+    registerDataObj = function(name, data, filterFunc) {},
+    #' @description No-op
+    #' @param value Not used
+    allowReconnect = function(value) {},
+    #' @description No-op
+    reload = function() {},
+    #' @description No-op
+    #' @param brushId Not used
+    resetBrush = function(brushId) {
+      warning("session$brush isn't meaningfully mocked on the MockShinySession")
+    },
+    #' @description No-op
+    #' @param type Not used
+    #' @param message Not used
+    sendCustomMessage = function(type, message) {},
+    #' @description No-op
+    #' @param type Not used
+    #' @param message Not used
+    sendBinaryMessage = function(type, message) {},
+    #' @description No-op
+    #' @param inputId Not used
+    #' @param message Not used
+    sendInputMessage = function(inputId, message) {},
+    #' @description No-op
+    #' @param names Not used
+    setBookmarkExclude = function(names) {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    #' @description No-op
+    getBookmarkExclude = function() {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    #' @description No-op
+    #' @param fun Not used
+    onBookmark = function(fun) {},
+    #' @description No-op
+    #' @param fun Not used
+    onBookmarked = function(fun) {},
+    #' @description No-op
+    doBookmark = function() {
+      warning("Bookmarking isn't meaningfully mocked in MockShinySession")
+    },
+    #' @description No-op
+    #' @param fun Not used
+    onRestore = function(fun) {},
+    #' @description No-op
+    #' @param fun Not used
+    onRestored = function(fun) {},
+    #' @description No-op
+    exportTestValues = function() {},
+    #' @description No-op
+    #' @param input Not used
+    #' @param output Not used
+    #' @param export Not used
+    #' @param format Not used
+    getTestSnapshotUrl = function(input=TRUE, output=TRUE, export=TRUE, format="json") {},
+    #' @description Returns the given id prefixed by this namespace's id.
+    #' @param id The id to modify.
+    ns = function(id) {
+      NS(private$nsPrefix, id)
+    },
+    #' @description Trigger a reactive flush right now.
+    flushReact = function(){
+      private$flush()
+    },
+    #' @description Create and return a namespace-specific session proxy.
+    #' @param namespace Character vector indicating a namespace.
+    makeScope = function(namespace) {
+      ns <- NS(namespace)
+      createSessionProxy(
+        self,
+        input = .createReactiveValues(private$.input, readonly = TRUE, ns = ns),
+        output = structure(.createOutputWriter(self, ns = ns), class = "shinyoutput"),
+        makeScope = function(namespace) self$makeScope(ns(namespace)),
+        ns = function(namespace) ns(namespace),
+        setInputs = function(...) do.call(self$setInputs, mapNames(ns, ...))
+      )
+    },
+    #' @description Set the environment associated with a testServer() call.
+    #' @param env The environment to retain.
+    setEnv = function(env) {
+      self$env <- env
+    },
+    #' @description Set the value returned by the module call and proactively flush.
+    #' @param value The value returned from the module
+    setReturned = function(value) {
+      self$returned <- value
+      private$flush()
+      value
+    },
+    #' @description Get the value returned by the module call.
+    getReturned = function() self$returned,
+    #' @description Return a distinct character identifier for use as a proxy
+    #'   namespace.
+    genId = function() {
+      private$idCounter <- private$idCounter + 1
+      paste0("proxy", private$idCounter)
+    }
+  ),
+  private = list(
+    .input = NULL,
+    flushCBs = NULL,
+    flushedCBs = NULL,
+    endedCBs = NULL,
+    timer = NULL,
+    closed = FALSE,
+    outs = list(),
+    nsPrefix = "mock-session",
+    idCounter = 0,
+
+    flush = function(){
+      isolate(private$flushCBs$invoke(..stacktraceon = TRUE))
+      shiny:::flushReact() # namespace to avoid calling our own method
+      isolate(private$flushedCBs$invoke(..stacktraceon = TRUE))
+      later::run_now()
+    }
+  ),
+  active = list(
+    #' @field request An empty environment where the request should be. The request isn't meaningfully mocked currently.
+    request = function(value) {
+      if (!missing(value)){
+        stop("session$request can't be assigned to")
+      }
+      warning("session$request doesn't currently simulate a realistic request on MockShinySession")
+      new.env(parent=emptyenv())
+    }
+  )
+)
+

R/modal.R

@@ -1,13 +1,13 @@
 #' 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}}.
+#' typically used with [modalDialog()].
 #'
 #' @param ui UI content to show in the modal.
-#' @param session The \code{session} object passed to function given to
-#'   \code{shinyServer}.
+#' @param session The `session` object passed to function given to
+#'   `shinyServer`.
 #'
-#' @seealso \code{\link{modalDialog}} for examples.
+#' @seealso [modalDialog()] for examples.
 #' @export
 showModal <- function(ui, session = getDefaultReactiveDomain()) {
   res <- processDeps(ui, session)
@@ -35,14 +35,16 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #'
 #' @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
+#' @param footer UI for footer. Use `NULL` for no footer.
+#' @param size One of `"s"` for small, `"m"` (the default) for medium,
+#'   or `"l"` for large.
+#' @param easyClose If `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
+#'   `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.
+#'   from a call to [removeModal()] on the server.
+#' @param fade If `FALSE`, the modal dialog will have no fade-in animation
+#'   (it will simply appear rather than fade in to view).
 #'
 #' @examples
 #' if (interactive()) {
@@ -143,11 +145,12 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #' }
 #' @export
 modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
-  size = c("m", "s", "l"), easyClose = FALSE) {
+  size = c("m", "s", "l"), easyClose = FALSE, fade = TRUE) {
 
   size <- match.arg(size)
 
-  div(id = "shiny-modal", class = "modal fade", tabindex = "-1",
+  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",
 
@@ -168,10 +171,10 @@ modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
 
 #' Create a button for a modal dialog
 #'
-#' When clicked, a \code{modalButton} will dismiss the modal dialog.
+#' When clicked, a `modalButton` will dismiss the modal dialog.
 #'
 #' @inheritParams actionButton
-#' @seealso \code{\link{modalDialog}} for examples.
+#' @seealso [modalDialog()] for examples.
 #' @export
 modalButton <- function(label, icon = NULL) {
   tags$button(type = "button", class = "btn btn-default",

R/modules.R

@@ -26,30 +26,127 @@ createSessionProxy <- function(parentSession, ...) {
 
 #' @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 modules
 #'
 #' 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.
+#' <http://shiny.rstudio.com/articles/modules.html> to learn more.
 #'
-#' @param module A Shiny module server function
+#' Starting in Shiny 1.5.0, we recommend using `moduleServer` instead of
+#' `callModule`, because the syntax is a little easier to understand, and
+#' modules created with `moduleServer` can be tested with [`testServer()`].
+#'
+#' @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
+#'   UI function.
+#' @param ... For `callModule`, 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)
+#'   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}
+#' @seealso <http://shiny.rstudio.com/articles/modules.html>
+#'
+#' @examples
+#' # Define the UI for a module
+#' counterUI <- function(id, label = "Counter") {
+#'   ns <- NS(id)
+#'   tagList(
+#'     actionButton(ns("button"), label = label),
+#'     verbatimTextOutput(ns("out"))
+#'   )
+#' }
+#'
+#' # Define the server logic for a module
+#' counterServer <- function(id) {
+#'   moduleServer(
+#'     id,
+#'     function(input, output, session) {
+#'       count <- reactiveVal(0)
+#'       observeEvent(input$button, {
+#'         count(count() + 1)
+#'       })
+#'       output$out <- renderText({
+#'         count()
+#'       })
+#'       count
+#'     }
+#'   )
+#' }
+#'
+#' # Use the module in an app
+#' ui <- fluidPage(
+#'   counterUI("counter1", "Counter #1"),
+#'   counterUI("counter2", "Counter #2")
+#' )
+#' server <- function(input, output, session) {
+#'   counterServer("counter1")
+#'   counterServer("counter2")
+#' }
+#' if (interactive()) {
+#'   shinyApp(ui, server)
+#' }
+#'
+#'
+#'
+#' # If you want to pass extra parameters to the module's server logic, you can
+#' # add them to your function. In this case `prefix` is text that will be
+#' # printed before the count.
+#' counterServer2 <- function(id, prefix = NULL) {
+#'   moduleServer(
+#'     id,
+#'     function(input, output, session) {
+#'       count <- reactiveVal(0)
+#'       observeEvent(input$button, {
+#'         count(count() + 1)
+#'       })
+#'       output$out <- renderText({
+#'         paste0(prefix, count())
+#'       })
+#'       count
+#'     }
+#'   )
+#' }
+#'
+#' ui <- fluidPage(
+#'   counterUI("counter", "Counter"),
+#' )
+#' server <- function(input, output, session) {
+#'   counterServer2("counter", "The current count is: ")
+#' }
+#' if (interactive()) {
+#'   shinyApp(ui, server)
+#' }
+#'
+#' @export
+moduleServer <- function(id, module, session = getDefaultReactiveDomain()) {
+  if (inherits(session, "MockShinySession")) {
+    body(module) <- rlang::expr({
+      session$setEnv(base::environment())
+      session$setReturned({ !!!body(module) })
+    })
+  }
+  callModule(module, id, session = session)
+}
+
+
+#' @rdname moduleServer
 #' @export
 callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
+  if (!inherits(session, c("ShinySession", "session_proxy", "MockShinySession"))) {
+    stop("session must be a ShinySession or session_proxy object.")
+  }
   childScope <- session$makeScope(id)
 
   withReactiveDomain(childScope, {

R/notifications.R

@@ -4,19 +4,21 @@
 #'
 #' @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}
+#'   could be a link that the user can click on. This is separate from `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
+#'   disappears. Use `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 closeButton If `TRUE`, display a button which will make the
+#'   notification disappear when clicked. If `FALSE` do not display.
+#' @param id A unique identifier for the notification.
+#'
+#'   `id` is optional for `showNotification()`: Shiny will automatically create
+#'   one if needed. If you do supply it, Shiny will update an existing
+#'   notification if it exists, otherwise it will create a new one.
+#'
+#'   `id` is required for `removeNotification()`.
 #' @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.
@@ -97,10 +99,8 @@ showNotification <- function(ui, action = NULL, duration = 5,
 
 #' @rdname showNotification
 #' @export
-removeNotification <- function(id = NULL, session = getDefaultReactiveDomain()) {
-  if (is.null(id)) {
-    stop("id is required.")
-  }
+removeNotification <- function(id, session = getDefaultReactiveDomain()) {
+  force(id)
   session$sendNotification("remove", id)
   id
 }

R/progress.R

@@ -3,68 +3,29 @@
 #' Reports progress to the user during long-running operations.
 #'
 #' This package exposes two distinct programming APIs for working with
-#' progress. \code{\link{withProgress}} and \code{\link{setProgress}}
+#' progress. [withProgress()] and [setProgress()]
 #' together provide a simple function-based interface, while the
-#' \code{Progress} reference class provides an object-oriented API.
+#' `Progress` reference class provides an object-oriented API.
 #'
-#' Instantiating a \code{Progress} object causes a progress panel to be
-#' created, and it will be displayed the first time the \code{set}
-#' method is called. Calling \code{close} will cause the progress panel
+#' Instantiating a `Progress` object causes a progress panel to be
+#' created, and it will be displayed the first time the `set`
+#' method is called. Calling `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
+#' CSS), you can use `style="old"` each time you call
+#' `Progress$new()`. If you don't want to set the style each time
+#' `Progress$new` is called, you can instead call
+#' [`shinyOptions(progress.style="old")`][shinyOptions] just once, inside the server
 #' function.
 #'
-#' \strong{Methods}
-#'   \describe{
-#'     \item{\code{initialize(session, min = 0, max = 1)}}{
-#'       Creates a new progress panel (but does not display it).
-#'     }
-#'     \item{\code{set(value = NULL, message = NULL, detail = NULL)}}{
-#'       Updates the progress panel. When called the first time, the
-#'       progress panel is displayed.
-#'     }
-#'     \item{\code{inc(amount = 0.1, message = NULL, detail = NULL)}}{
-#'       Like \code{set}, this updates the progress panel. The difference is
-#'       that \code{inc} increases the progress bar by \code{amount}, instead
-#'       of setting it to a specific value.
-#'     }
-#'     \item{\code{close()}}{
-#'       Removes the progress panel. Future calls to \code{set} and
-#'       \code{close} will be ignored.
-#'     }
-#'   }
-#'
-#' @param session The Shiny session object, as provided by
-#'   \code{shinyServer} to the server function.
-#' @param min The value that represents the starting point of the
-#'   progress bar. Must be less tham \code{max}.
-#' @param max The value that represents the end of the progress bar.
-#'   Must be greater than \code{min}.
 #' @param message A single-element character vector; the message to be
-#'   displayed to the user, or \code{NULL} to hide the current message
-#'   (if any).
-#' @param detail A single-element character vector; the detail message
-#'   to be 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 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.
-#' @param amount For the \code{inc()} method, a numeric value to increment the
-#'   progress bar.
+#'   displayed to the user, or `NULL` to hide the current message (if any).
+#' @param detail A single-element character vector; the detail message to be
+#'   displayed to the user, or `NULL` to hide the current detail message (if
+#'   any). The detail message will be shown with a de-emphasized appearance
+#'   relative to `message`.
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -92,15 +53,25 @@
 #'
 #' shinyApp(ui, server)
 #' }
-#' @seealso \code{\link{withProgress}}
+#' @seealso [withProgress()]
 #' @format NULL
 #' @usage NULL
 #' @export
 Progress <- R6Class(
   'Progress',
-  portable = TRUE,
   public = list(
 
+    #' @description Creates a new progress panel (but does not display it).
+    #' @param session The Shiny session object, as provided by `shinyServer` to
+    #'   the server function.
+    #' @param min The value that represents the starting point of the progress
+    #'   bar. Must be less than `max`.
+    #' @param max The value that represents the end of the progress bar. Must be
+    #'   greater than `min`.
+    #' @param style Progress display style. If `"notification"` (the default),
+    #'   the progress indicator will show using Shiny's notification API. If
+    #'   `"old"`, use the same HTML and CSS used in Shiny 0.13.2 and below (this
+    #'   is for backward-compatibility).
     initialize = function(session = getDefaultReactiveDomain(),
       min = 0, max = 1,
       style = getShinyOption("progress.style", default = "notification"))
@@ -112,28 +83,33 @@ Progress <- R6Class(
       private$id <- createUniqueId(8)
       private$min <- min
       private$max <- max
-      private$style <- match.arg(style, choices = c("notification", "old"))
       private$value <- NULL
+      private$style <- match.arg(style, choices = c("notification", "old"))
       private$closed <- FALSE
 
       session$sendProgress('open', list(id = private$id, style = private$style))
     },
 
+    #' @description Updates the progress panel. When called the first time, the
+    #'   progress panel is displayed.
+    #' @param value Single-element numeric vector; the value at which to set the
+    #'   progress bar, relative to `min` and `max`. `NULL` hides the progress
+    #'   bar, if it is currently visible.
     set = function(value = NULL, message = NULL, detail = NULL) {
       if (private$closed) {
         warning("Attempting to set progress, but progress already closed.")
         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,
@@ -142,23 +118,33 @@ Progress <- R6Class(
         style = private$style
       ))
 
-       private$session$sendProgress('update', data)
+      private$session$sendProgress('update', data)
     },
 
+    #' @description Like `set`, this updates the progress panel. The difference
+    #'   is that `inc` increases the progress bar by `amount`, instead of
+    #'   setting it to a specific value.
+    #' @param amount For the `inc()` method, a numeric value to increment the
+    #'   progress bar.
     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)
     },
 
+    #' @description Returns the minimum value.
     getMin = function() private$min,
 
+    #' @description Returns the maximum value.
     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
-    },
+    #' @description Returns the current value.
+    getValue = function() private$value,
 
+    #' @description Removes the progress panel. Future calls to `set` and
+    #'   `close` will be ignored.
     close = function() {
       if (private$closed) {
         warning("Attempting to close progress, but progress already closed.")
@@ -173,12 +159,12 @@ Progress <- R6Class(
   ),
 
   private = list(
-    session = 'environment',
+    session = 'ShinySession',
     id = character(0),
     min = numeric(0),
     max = numeric(0),
     style = character(0),
-    value = NULL,
+    value = numeric(0),
     closed = logical(0)
   )
 )
@@ -188,63 +174,63 @@ Progress <- R6Class(
 #' Reports progress to the user during long-running operations.
 #'
 #' This package exposes two distinct programming APIs for working with progress.
-#' Using \code{withProgress} with \code{incProgress} or \code{setProgress}
-#' provide a simple function-based interface, while the \code{\link{Progress}}
+#' Using `withProgress` with `incProgress` or `setProgress`
+#' provide a simple function-based interface, while the [Progress()]
 #' reference class provides an object-oriented API.
 #'
-#' Use \code{withProgress} to wrap the scope of your work; doing so will cause a
+#' Use `withProgress` to wrap the scope of your work; doing so will cause a
 #' new progress panel to be created, and it will be displayed the first time
-#' \code{incProgress} or \code{setProgress} are called. When \code{withProgress}
+#' `incProgress` or `setProgress` are called. When `withProgress`
 #' exits, the corresponding progress panel will be removed.
 #'
-#' The \code{incProgress} function increments the status bar by a specified
-#' amount, whereas the \code{setProgress} function sets it to a specific value,
+#' The `incProgress` function increments the status bar by a specified
+#' amount, whereas the `setProgress` function sets it to a specific value,
 #' and can also set the text displayed.
 #'
-#' Generally, \code{withProgress}/\code{incProgress}/\code{setProgress} should
+#' Generally, `withProgress`/`incProgress`/`setProgress` should
 #' be sufficient; the exception is if the work to be done is asynchronous (this
 #' is not common) or otherwise cannot be encapsulated by a single scope. In that
-#' case, you can use the \code{Progress} reference class.
+#' case, you can use the `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
+#' CSS), you can use `style="old"` each time you call
+#' `withProgress()`. If you don't want to set the style each time
+#' `withProgress` is called, you can instead call
+#' [`shinyOptions(progress.style="old")`][shinyOptions] just once, inside the server
 #' function.
 #'
-#' @param session The Shiny session object, as provided by \code{shinyServer} to
+#' @param session The Shiny session object, as provided by `shinyServer` to
 #'   the server function. The default is to automatically find the session by
 #'   using the current reactive domain.
 #' @param expr The work to be done. This expression should contain calls to
-#'   \code{setProgress}.
+#'   `setProgress`.
 #' @param min The value that represents the starting point of the progress bar.
-#'   Must be less tham \code{max}. Default is 0.
+#'   Must be less tham `max`. Default is 0.
 #' @param max The value that represents the end of the progress bar. Must be
-#'   greater than \code{min}. Default is 1.
-#' @param amount For \code{incProgress}, the amount to increment the status bar.
+#'   greater than `min`. Default is 1.
+#' @param amount For `incProgress`, the amount to increment the status bar.
 #'   Default is 0.1.
-#' @param env The environment in which \code{expr} should be evaluated.
-#' @param quoted Whether \code{expr} is a quoted expression (this is not
+#' @param env The environment in which `expr` should be evaluated.
+#' @param quoted Whether `expr` is a quoted expression (this is not
 #'   common).
 #' @param message A single-element character vector; the message to be displayed
-#'   to the user, or \code{NULL} to hide the current message (if any).
+#'   to the user, or `NULL` to hide the current message (if any).
 #' @param detail A single-element character vector; the detail message to be
-#'   displayed to the user, or \code{NULL} to hide the current detail message
+#'   displayed to the user, or `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),
+#'   relative to `message`.
+#' @param style Progress display style. If `"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
+#'   `"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 `min` and `max`.
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   plotOutput("plot")
@@ -265,7 +251,7 @@ Progress <- R6Class(
 #'
 #' shinyApp(ui, server)
 #' }
-#' @seealso \code{\link{Progress}}
+#' @seealso [Progress()]
 #' @rdname withProgress
 #' @export
 withProgress <- function(expr, min = 0, max = 1,

R/react.R

@@ -1,38 +1,80 @@
+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())
+  }
+})
+
+#' @include graph.R
 Context <- R6Class(
   'Context',
   portable = FALSE,
   class = FALSE,
   public = list(
     id = character(0),
+    .reactId = character(0),
+    .reactType = "other",
     .label = character(0),      # For debug purposes
     .invalidated = FALSE,
     .invalidateCallbacks = list(),
     .flushCallbacks = list(),
     .domain = NULL,
+    .pid = NULL,
+    .weak = NULL,
 
-    initialize = function(domain, label='', type='other', prevId='') {
-      id <<- .getReactiveEnvironment()$nextId()
+    initialize = function(
+      domain, label='', type='other', prevId='',
+      reactId = rLog$noReactId,
+      id = .getReactiveEnvironment()$nextId(), # For dummy context
+      weak = FALSE
+    ) {
+      id <<- id
       .label <<- label
       .domain <<- domain
-      .graphCreateContext(id, label, type, prevId, domain)
+      .pid <<- processId()
+      .reactId <<- reactId
+      .reactType <<- type
+      .weak <<- weak
+      rLog$createContext(id, label, type, prevId, domain)
     },
     run = function(func) {
       "Run the provided function under this context."
-      withReactiveDomain(.domain, {
-        env <- .getReactiveEnvironment()
-        .graphEnterContext(id)
-        on.exit(.graphExitContext(id), add = TRUE)
-        env$runWith(self, func)
+
+      promises::with_promise_domain(reactivePromiseDomain(), {
+        withReactiveDomain(.domain, {
+          env <- .getReactiveEnvironment()
+          rLog$enter(.reactId, id, .reactType, .domain)
+          on.exit(rLog$exit(.reactId, id, .reactType, .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
 
-      .graphInvalidate(id, .domain)
+      rLog$invalidateStart(.reactId, id, .reactType, .domain)
+      on.exit(rLog$invalidateEnd(.reactId, id, .reactType, .domain), add = TRUE)
+
       lapply(.invalidateCallbacks, function(func) {
         func()
       })
@@ -43,6 +85,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
@@ -52,9 +99,6 @@ Context <- R6Class(
     addPendingFlush = function(priority) {
       "Tell the reactive environment that this context should be flushed the
         next time flushReact() called."
-      if (!is.null(.domain)) {
-        .domain$incrementBusyCount()
-      }
       .getReactiveEnvironment()$addPendingFlush(self, priority)
     },
     onFlush = function(func) {
@@ -64,15 +108,12 @@ Context <- R6Class(
     executeFlushCallbacks = function() {
       "For internal use only."
 
-      on.exit({
-        if (!is.null(.domain)) {
-          .domain$decrementBusyCount()
-        }
-      }, add = TRUE)
-
       lapply(.flushCallbacks, function(flushCallback) {
         flushCallback()
       })
+    },
+    isWeak = function() {
+      .weak
     }
   )
 )
@@ -118,16 +159,24 @@ ReactiveEnvironment <- R6Class(
     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)
+      on.exit({
+        .inFlush <<- FALSE
+        rLog$idle(domain = NULL)
+      })
 
       while (hasPendingFlush()) {
         ctx <- .pendingFlush$dequeue()
         ctx$executeFlushCallbacks()
       }
+
+      invisible(TRUE)
     }
   )
 )
@@ -141,9 +190,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
@@ -151,15 +201,41 @@ flushReact <- function() {
 getCurrentContext <- function() {
   .getReactiveEnvironment()$currentContext()
 }
+hasCurrentContext <- function() {
+  !is.null(.getReactiveEnvironment()$.currentContext)
+}
 
-getDummyContext <- function() {}
-local({
-  dummyContext <- NULL
-  getDummyContext <<- function() {
-    if (is.null(dummyContext)) {
-      dummyContext <<- Context$new(getDefaultReactiveDomain(), '[none]',
-        type='isolate')
-    }
-    return(dummyContext)
+getDummyContext <- function() {
+  Context$new(
+    getDefaultReactiveDomain(), '[none]', type = 'isolate',
+    id = "Dummy", reactId = rLog$dummyReactId
+  )
+}
+
+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

@@ -95,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)
 }
 
 #
@@ -172,31 +168,31 @@ onReactiveDomainEnded <- function(domain, callback, failIfNull = FALSE) {
 #' them ends) and error handling.
 #'
 #' At any given time, there can be either a single "default" reactive domain
-#' object, or none (i.e. the reactive domain object is \code{NULL}). You can
+#' object, or none (i.e. the reactive domain object is `NULL`). You can
 #' access the current default reactive domain by calling
-#' \code{getDefaultReactiveDomain}.
+#' `getDefaultReactiveDomain`.
 #'
 #' Unless you specify otherwise, newly created observers and reactive
 #' expressions will be assigned to the current default domain (if any). You can
-#' override this assignment by providing an explicit \code{domain} argument to
-#' \code{\link{reactive}} or \code{\link{observe}}.
+#' override this assignment by providing an explicit `domain` argument to
+#' [reactive()] or [observe()].
 #'
 #' For advanced usage, it's possible to override the default domain using
-#' \code{withReactiveDomain}. The \code{domain} argument will be made the
-#' default domain while \code{expr} is evaluated.
+#' `withReactiveDomain`. The `domain` argument will be made the
+#' default domain while `expr` is evaluated.
 #'
-#' Implementers of new reactive primitives can use \code{onReactiveDomainEnded}
+#' Implementers of new reactive primitives can use `onReactiveDomainEnded`
 #' as a convenience function for registering callbacks. If the reactive domain
-#' is \code{NULL} and \code{failIfNull} is \code{FALSE}, then the callback will
+#' is `NULL` and `failIfNull` is `FALSE`, then the callback will
 #' never be invoked.
 #'
 #' @name domains
 #' @param domain A valid domain object (for example, a Shiny session), or
-#'   \code{NULL}
-#' @param expr An expression to evaluate under \code{domain}
+#'   `NULL`
+#' @param expr An expression to evaluate under `domain`
 #' @param callback A callback function to be invoked
-#' @param failIfNull If \code{TRUE} then an error is given if the \code{domain}
-#'   is \code{NULL}
+#' @param failIfNull If `TRUE` then an error is given if the `domain`
+#'   is `NULL`
 NULL
 
 #

R/reexports.R

@@ -0,0 +1,195 @@
+####
+# Generated by `./tools/updateReexports.R`: do not edit by hand
+# Please call `source('tools/updateReexports.R') from the root folder to update`
+####
+
+
+# fastmap key_missing.Rd -------------------------------------------------------
+
+#' @importFrom fastmap key_missing
+#' @export
+fastmap::key_missing
+
+#' @importFrom fastmap is.key_missing
+#' @export
+fastmap::is.key_missing
+
+
+
+# htmltools builder.Rd ---------------------------------------------------------
+
+#' @importFrom htmltools tags
+#' @export
+htmltools::tags
+
+#' @importFrom htmltools p
+#' @export
+htmltools::p
+
+#' @importFrom htmltools h1
+#' @export
+htmltools::h1
+
+#' @importFrom htmltools h2
+#' @export
+htmltools::h2
+
+#' @importFrom htmltools h3
+#' @export
+htmltools::h3
+
+#' @importFrom htmltools h4
+#' @export
+htmltools::h4
+
+#' @importFrom htmltools h5
+#' @export
+htmltools::h5
+
+#' @importFrom htmltools h6
+#' @export
+htmltools::h6
+
+#' @importFrom htmltools a
+#' @export
+htmltools::a
+
+#' @importFrom htmltools br
+#' @export
+htmltools::br
+
+#' @importFrom htmltools div
+#' @export
+htmltools::div
+
+#' @importFrom htmltools span
+#' @export
+htmltools::span
+
+#' @importFrom htmltools pre
+#' @export
+htmltools::pre
+
+#' @importFrom htmltools code
+#' @export
+htmltools::code
+
+#' @importFrom htmltools img
+#' @export
+htmltools::img
+
+#' @importFrom htmltools strong
+#' @export
+htmltools::strong
+
+#' @importFrom htmltools em
+#' @export
+htmltools::em
+
+#' @importFrom htmltools hr
+#' @export
+htmltools::hr
+
+
+# htmltools tag.Rd -------------------------------------------------------------
+
+#' @importFrom htmltools tag
+#' @export
+htmltools::tag
+
+#' @importFrom htmltools tagList
+#' @export
+htmltools::tagList
+
+#' @importFrom htmltools tagAppendAttributes
+#' @export
+htmltools::tagAppendAttributes
+
+#' @importFrom htmltools tagHasAttribute
+#' @export
+htmltools::tagHasAttribute
+
+#' @importFrom htmltools tagGetAttribute
+#' @export
+htmltools::tagGetAttribute
+
+#' @importFrom htmltools tagAppendChild
+#' @export
+htmltools::tagAppendChild
+
+#' @importFrom htmltools tagAppendChildren
+#' @export
+htmltools::tagAppendChildren
+
+#' @importFrom htmltools tagSetChildren
+#' @export
+htmltools::tagSetChildren
+
+
+# htmltools HTML.Rd ------------------------------------------------------------
+
+#' @importFrom htmltools HTML
+#' @export
+htmltools::HTML
+
+
+# htmltools include.Rd ---------------------------------------------------------
+
+#' @importFrom htmltools includeHTML
+#' @export
+htmltools::includeHTML
+
+#' @importFrom htmltools includeText
+#' @export
+htmltools::includeText
+
+#' @importFrom htmltools includeMarkdown
+#' @export
+htmltools::includeMarkdown
+
+#' @importFrom htmltools includeCSS
+#' @export
+htmltools::includeCSS
+
+#' @importFrom htmltools includeScript
+#' @export
+htmltools::includeScript
+
+
+# htmltools singleton.Rd -------------------------------------------------------
+
+#' @importFrom htmltools singleton
+#' @export
+htmltools::singleton
+
+#' @importFrom htmltools is.singleton
+#' @export
+htmltools::is.singleton
+
+
+# htmltools validateCssUnit.Rd -------------------------------------------------
+
+#' @importFrom htmltools validateCssUnit
+#' @export
+htmltools::validateCssUnit
+
+
+# htmltools htmlTemplate.Rd ----------------------------------------------------
+
+#' @importFrom htmltools htmlTemplate
+#' @export
+htmltools::htmlTemplate
+
+
+# htmltools suppressDependencies.Rd --------------------------------------------
+
+#' @importFrom htmltools suppressDependencies
+#' @export
+htmltools::suppressDependencies
+
+
+# htmltools withTags.Rd --------------------------------------------------------
+
+#' @importFrom htmltools withTags
+#' @export
+htmltools::withTags

R/render-cached-plot.R

@@ -0,0 +1,590 @@
+#' Plot output with cached images
+#'
+#' Renders a reactive plot, with plot images cached to disk.
+#'
+#' `expr` is an expression that generates a plot, similar to that in
+#' `renderPlot`. Unlike with `renderPlot`, this expression does not
+#' take reactive dependencies. It is re-executed only when the cache key
+#' changes.
+#'
+#' `cacheKeyExpr` is an expression which, when evaluated, returns an object
+#' which will be serialized and hashed using the [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 `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, `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
+#' [digest::digest()] function.
+#'
+#' Internally, the result from `cacheKeyExpr` is combined with the name of
+#' the output (if you assign it to `output$plot1`, it will be combined
+#' with `"plot1"`) to form the actual key that is used. As a result, even
+#' if there are multiple plots that have the same `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 `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 `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 `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 `"app"` or `"session"` is used, the cache will be 10 MB
+#'   in size, and will be stored stored in memory, using a
+#'   [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
+#'   [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
+#'   [shinyOptions()] at the top of your server function. To use
+#'   the session-scoped cache, you must also call `renderCachedPlot` with
+#'   `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 [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
+#'   `myapp-cache` (replace `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 [memoryCache()] or [diskCache()], and pass it
+#'   as the `cache` argument of `renderCachedPlot`.
+#'
+#' @section Interactive plots:
+#'
+#'   `renderCachedPlot` can be used to create interactive plots. See
+#'   [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, `width` and
+#'   `height`, and returns a list with `width` and `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 [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
+#'   `"app"` (the default), `"session"`, or a cache object like
+#'   a [diskCache()]. See the Cache Scoping section for more
+#'   information.
+#'
+#' @seealso See [renderPlot()] for the regular, non-cached version of
+#'   this function. For more about configuring caches, see
+#'   [memoryCache()] and [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(possiblyAsyncResult) {
+        hybrid_chain(possiblyAsyncResult, 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 [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-table.R

@@ -1,50 +1,50 @@
 #' Table Output
 #'
-#' Creates a reactive table that is suitable for assigning to an \code{output}
+#' Creates a reactive table that is suitable for assigning to an `output`
 #' slot.
 #'
-#' The corresponding HTML output tag should be \code{div} and have the CSS
-#' class name \code{shiny-html-output}.
+#' The corresponding HTML output tag should be `div` and have the CSS
+#' class name `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
+#'   [xtable::xtable()].
+#' @param striped,hover,bordered Logicals: if `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 spacing The spacing between the rows of the table (`xs`
+#'   stands for "extra small", `s` for "small", `m` for "medium"
+#'   and `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}
+#'   `'l'`, `'c'` or `'r'`, then all columns will be,
+#'   respectively, left-, center- or right-aligned. Otherwise, `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
+#'   `rownames = TRUE`, this will be equal to `ncol()+1`), with
+#'   the *i*-th character specifying the alignment for the
+#'   *i*-th column (besides `'l'`, `'c'` and
+#'   `'r'`, `'?'` is also permitted - `'?'` is a placeholder
 #'   for that particular column, indicating that it should keep its default
-#'   alignment). If \code{NULL}, then all numeric/integer columns (including
+#'   alignment). If `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
+#'   everything else will be left-aligned (`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
+#'   class). If `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.
+#'   `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()})?
+#'   (i.e. they either evaluate to `NA` or `NaN`).
+#' @param ... Arguments to be passed through to [xtable::xtable()]
+#'   and [xtable::print.xtable()].
+#' @param env The environment in which to evaluate `expr`.
+#' @param quoted Is `expr` a quoted expression (with `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
+#'   implicit call to [tableOutput()] when `renderTable` is
 #'   used in an interactive R Markdown document.
 #' @export
 renderTable <- function(expr, striped = FALSE, hover = FALSE,
@@ -81,143 +81,148 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
 
   dots <- list(...)  ## used later (but defined here because of scoping)
 
-  renderFunc <- function(shinysession, name, ...) {
-    striped <- stripedWrapper()
-    hover <- hoverWrapper()
-    bordered <- borderedWrapper()
-    format <- c(striped = striped, hover = hover, bordered = bordered)
-    spacing <- spacingWrapper()
-    width <- widthWrapper()
-    align <- alignWrapper()
-    rownames <- rownamesWrapper()
-    colnames <- colnamesWrapper()
-    digits <- digitsWrapper()
-    na <- naWrapper()
+  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=", ")))
-    }
+      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))
+      # For css styling
+      classNames <- paste0("table shiny-table",
+        paste0(" table-", names(format)[format], collapse = "" ),
+        paste0(" spacing-", spacing))
 
-    data <- func()
-    data <- as.data.frame(data)
+      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)
+      # 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)]
+      # 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"
-    }
+      # 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="")
+      # 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 {
-        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")
+        ## 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))
+      # 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), ";'"))
+      # 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))]
+      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")
+      # 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)
+      # 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)
+      # 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))
+        # 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"
+        # 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)
+        # Align each header accordingly (this guarantees that each header and its
+        # corresponding column have the same alignment)
+        for (i in seq_len(length(cols))) {
+          tab <- sub("<th>", paste0("<th style='text-align: ", cols[i], ";'>"), tab)
+        }
       }
-    }
-    return(tab)
-  }
-
-  # Main render function
-  markRenderFunction(tableOutput, renderFunc, outputArgs = outputArgs)
+      return(tab)
+    },
+    tableOutput, outputArgs
+  )
 }

R/run-url.R

@@ -1,24 +1,24 @@
 #' Run a Shiny application from a URL
 #'
-#' \code{runUrl()} downloads and launches a Shiny application that is hosted at
+#' `runUrl()` downloads and launches a Shiny application that is hosted at
 #' a downloadable URL. The Shiny application must be saved in a .zip, .tar, or
 #' .tar.gz file. The Shiny application files must be contained in the root
 #' directory or a subdirectory in the archive. For example, the files might be
-#' \code{myapp/server.r} and \code{myapp/ui.r}. The functions \code{runGitHub()}
-#' and \code{runGist()} are based on \code{runUrl()}, using URL's from GitHub
-#' (\url{https://github.com}) and GitHub gists (\url{https://gist.github.com}),
+#' `myapp/server.r` and `myapp/ui.r`. The functions `runGitHub()`
+#' and `runGist()` are based on `runUrl()`, using URL's from GitHub
+#' (<https://github.com>) and GitHub gists (<https://gist.github.com>),
 #' respectively.
 #' @param url URL of the application.
-#' @param filetype The file type (\code{".zip"}, \code{".tar"}, or
-#'   \code{".tar.gz"}. Defaults to the file extension taken from the url.
+#' @param filetype The file type (`".zip"`, `".tar"`, or
+#'   `".tar.gz"`. Defaults to the file extension taken from the url.
 #' @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}
+#'   you can use a path such as `"inst/shinyapp"`.
+#' @param destdir Directory to store the downloaded application files. If `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}.
+#' @param ... Other arguments to be passed to [runApp()], such as
+#'   `port` and `launch.browser`.
 #' @export
 #' @examples
 #' ## Only run this example in interactive R sessions
@@ -88,8 +88,8 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
 
 #' @rdname runUrl
 #' @param gist The identifier of the gist. For example, if the gist is
-#'   https://gist.github.com/jcheng5/3239667, then \code{3239667},
-#'   \code{'3239667'}, and \code{'https://gist.github.com/jcheng5/3239667'} are
+#'   https://gist.github.com/jcheng5/3239667, then `3239667`,
+#'   `'3239667'`, and `'https://gist.github.com/jcheng5/3239667'` are
 #'   all valid values.
 #' @export
 #' @examples
@@ -118,10 +118,10 @@ runGist <- function(gist, destdir = NULL, ...) {
 
 #' @rdname runUrl
 #' @param repo Name of the repository.
-#' @param username GitHub username. If \code{repo} is of the form
-#'   \code{"username/repo"}, \code{username} will be taken from \code{repo}.
+#' @param username GitHub username. If `repo` is of the form
+#'   `"username/repo"`, `username` will be taken from `repo`.
 #' @param ref Desired git reference. Could be a commit, tag, or branch name.
-#'   Defaults to \code{"master"}.
+#'   Defaults to `"master"`.
 #' @export
 #' @examples
 #' ## Only run this example in interactive R sessions

R/serializers.R

@@ -1,3 +1,22 @@
+#' 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
@@ -58,12 +77,12 @@ serializeReactiveValues <- function(values, exclude, stateDir = NULL) {
 
     # Get the serializer function for this input value. If none specified, use
     # the default.
-    serializer <- impl$getMeta(name, "shiny.serializer")
-    if (is.null(serializer))
-      serializer <- serializerDefault
+    serializer_fun <- impl$getMeta(name, "shiny.serializer")
+    if (is.null(serializer_fun))
+      serializer_fun <- serializerDefault
 
     # Apply serializer function.
-    serializer(val, stateDir)
+    serializer_fun(val, stateDir)
   })
 
   # Filter out any values that were marked as unserializable.

R/server-input-handlers.R

@@ -5,34 +5,34 @@ inputHandlers <- Map$new()
 #'
 #' 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.
+#' deserialized by jsonlite) before making it available in the `input`
+#' variable of the `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
+#' (unless Shiny is explicitly reloaded). For that reason, the `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}.
+#' Currently Shiny registers the following handlers: `shiny.matrix`,
+#' `shiny.number`, and `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
+#' The `type` of a custom Shiny Input widget will be deduced using the
+#' `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
+#'   `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 `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
+#' @param force If `TRUE`, will overwrite any existing handler without
+#' warning. If `FALSE`, will throw an error if this class already has
 #' a handler defined.
 #' @examples
 #' \dontrun{
@@ -48,7 +48,7 @@ inputHandlers <- Map$new()
 #' }
 #'
 #' }
-#' @seealso \code{\link{removeInputHandler}}
+#' @seealso [removeInputHandler()]
 #' @export
 registerInputHandler <- function(type, fun, force=FALSE){
   if (inputHandlers$containsKey(type) && !force){
@@ -63,14 +63,71 @@ registerInputHandler <- function(type, fun, force=FALSE){
 #' 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}}
+#' @return The handler previously associated with this `type`, if one
+#'   existed. Otherwise, `NULL`.
+#' @seealso [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 `"x:shiny.date"`. This function would apply the `"shiny.date"`
+#' input handler to the value, and then rename the result to `"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, ...) {
@@ -85,13 +142,14 @@ registerInputHandler("shiny.matrix", function(data, ...) {
   return(m)
 })
 
+
 registerInputHandler("shiny.number", function(val, ...){
   ifelse(is.null(val), NA, val)
 })
 
 registerInputHandler("shiny.password", function(val, shinysession, name) {
   # Mark passwords as not serializable
-  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
+  setSerializer(name, serializerUnserializable)
   val
 })
 
@@ -139,14 +197,45 @@ registerInputHandler("shiny.file", function(val, shinysession, name) {
   # The data will be a named list of lists; convert to a data frame.
   val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
 
-  # Make sure that the paths don't go up the directory tree, for security
-  # reasons.
-  if (any(grepl("..", val$datapath, fixed = TRUE))) {
-    stop("Invalid '..' found in file input path.")
+  # `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
-  val$datapath <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+  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/server.R

@@ -1,6 +1,7 @@
 #' @include server-input-handlers.R
 
 appsByToken <- Map$new()
+appsNeedingFlush <- Map$new()
 
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
@@ -21,6 +22,7 @@ registerClient <- function(client) {
 }
 
 
+.globals$resourcePaths <- list()
 .globals$resources <- list()
 
 .globals$showcaseDefault <- 0
@@ -29,64 +31,165 @@ registerClient <- function(client) {
 
 #' Resource Publishing
 #'
-#' Adds a directory of static resources to Shiny's web server, with the given
-#' path prefix. Primarily intended for package authors to make supporting
-#' JavaScript/CSS files available to their components.
+#' Add, remove, or list directory of static resources to Shiny's web server,
+#' with the given path prefix. Primarily intended for package authors to make
+#' supporting JavaScript/CSS files available to their components.
+#'
+#' Shiny provides two ways of serving static files (i.e., resources):
+#'
+#' 1. Static files under the `www/` directory are automatically made available
+#' under a request path that begins with `/`.
+#' 2. `addResourcePath()` makes static files in a `directoryPath` available
+#' under a request path that begins with `prefix`.
+#'
+#' The second approach is primarily intended for package authors to make
+#' supporting JavaScript/CSS files available to their components.
+#'
+#' Tools for managing static resources published by Shiny's web server:
+#'  * `addResourcePath()` adds a directory of static resources.
+#'  * `resourcePaths()` lists the currently active resource mappings.
+#'  * `removeResourcePath()` removes a directory of static resources.
 #'
 #' @param prefix The URL prefix (without slashes). Valid characters are a-z,
-#'   A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
-#'   For example, a value of 'foo' means that any request paths that begin with
-#'   '/foo' will be mapped to the given directory.
+#'   A-Z, 0-9, hyphen, period, and underscore. For example, a value of 'foo'
+#'   means that any request paths that begin with '/foo' will be mapped to the
+#'   given directory.
 #' @param directoryPath The directory that contains the static resources to be
 #'   served.
 #'
-#' @details You can call \code{addResourcePath} multiple times for a given
-#'   \code{prefix}; only the most recent value will be retained. If the
-#'   normalized \code{directoryPath} is different than the directory that's
-#'   currently mapped to the \code{prefix}, a warning will be issued.
-#'
-#' @seealso \code{\link{singleton}}
+#' @rdname resourcePaths
+#' @seealso [singleton()]
 #'
 #' @examples
 #' addResourcePath('datasets', system.file('data', package='datasets'))
+#' resourcePaths()
+#' removeResourcePath('datasets')
+#' resourcePaths()
+#'
+#' # make sure all resources are removed
+#' lapply(names(resourcePaths()), removeResourcePath)
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
-  prefix <- prefix[1]
-  if (!grepl('^[a-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+  if (length(prefix) != 1) stop("prefix must be of length 1")
+  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case = TRUE, perl = TRUE)) {
     stop("addResourcePath called with invalid prefix; please see documentation")
   }
-
   if (prefix %in% c('shared')) {
     stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
          "please use a different prefix")
   }
+  normalizedPath <- tryCatch(normalizePath(directoryPath, mustWork = TRUE),
+    error = function(e) {
+      stop("Couldn't normalize path in `addResourcePath`, with arguments: ",
+        "`prefix` = '", prefix, "'; `directoryPath` = '" , directoryPath, "'")
+    }
+  )
 
-  directoryPath <- normalizePath(directoryPath, mustWork=TRUE)
+  # # Often times overwriting a resource path is "what you want",
+  # # but sometimes it can lead to difficult to diagnose issues
+  # # (e.g. an implict dependency might set a resource path that
+  # # conflicts with what you, the app author, are trying to register)
+  # # Note that previous versions of shiny used to warn about this case,
+  # # but it was eventually removed since it caused confusion (#567).
+  # # It seems a good compromise is to throw a more information message.
+  # if (getOption("shiny.resourcePathChanges", FALSE) &&
+  #     prefix %in% names(.globals$resourcePaths)) {
+  #   existingPath <- .globals$resourcePaths[[prefix]]$path
+  #   if (normalizedPath != existingPath) {
+  #     message(
+  #       "The resource path '", prefix, "' used to point to ",
+  #       existingPath, ", but it now points to ", normalizedPath, ". ",
+  #       "If your app doesn't work as expected, you may want to ",
+  #       "choose a different prefix name."
+  #     )
+  #   }
+  # }
 
-  existing <- .globals$resources[[prefix]]
+  # If a shiny app is currently running, dynamically register this path with
+  # the corresponding httpuv server object.
+  if (!is.null(getShinyOption("server")))
+  {
+    getShinyOption("server")$setStaticPath(.list = stats::setNames(normalizedPath, prefix))
+  }
 
-  .globals$resources[[prefix]] <- list(directoryPath=directoryPath,
-                                       func=staticHandler(directoryPath))
+  # .globals$resourcePaths and .globals$resources persist across runs of applications.
+  .globals$resourcePaths[[prefix]] <- staticPath(normalizedPath)
+  # This is necessary because resourcePaths is only for serving assets out of C++;
+  # to support subapps, we also need assets to be served out of R, because those
+  # URLs are rewritten by R code (i.e. routeHandler) before they can be matched to
+  # a resource path.
+  .globals$resources[[prefix]] <- list(
+    directoryPath = normalizedPath,
+    func = staticHandler(normalizedPath)
+  )
 }
 
+#' @rdname resourcePaths
+#' @export
+resourcePaths <- function() {
+  urls <- names(.globals$resourcePaths)
+  paths <- vapply(.globals$resourcePaths, function(x) x$path, character(1))
+  stats::setNames(paths, urls)
+}
+
+hasResourcePath <- function(prefix) {
+  prefix %in% names(resourcePaths())
+}
+
+#' @rdname resourcePaths
+#' @export
+removeResourcePath <- function(prefix) {
+  if (length(prefix) > 1) stop("`prefix` must be of length 1.")
+  if (!hasResourcePath(prefix)) {
+    warning("Resource ", prefix, " not found.")
+    return(invisible(FALSE))
+  }
+  .globals$resourcePaths[[prefix]] <- NULL
+  .globals$resources[[prefix]] <- NULL
+  invisible(TRUE)
+}
+
+
+
+# This function handles any GET request with two or more path elements where the
+# first path element matches a prefix that was previously added using
+# addResourcePath().
+#
+# For example, if `addResourcePath("foo", "~/bar")` was called, then a GET
+# request for /foo/one/two.html would rewrite the PATH_INFO as /one/two.html and
+# send it to the resource path function for "foo". As of this writing, that
+# function will always be a staticHandler, which serves up a file if it exists
+# and NULL if it does not.
+#
+# Since Shiny 1.3.x, assets registered via addResourcePath should mostly be
+# served out of httpuv's native static file serving features. However, in the
+# specific case of subapps, the R code path must be used, because subapps insert
+# a giant random ID into the beginning of the URL that must be stripped off by
+# an R route handler (see addSubApp()).
 resourcePathHandler <- function(req) {
   if (!identical(req$REQUEST_METHOD, 'GET'))
     return(NULL)
 
+  # e.g. "/foo/one/two.html"
   path <- req$PATH_INFO
 
   match <- regexpr('^/([^/]+)/', path, perl=TRUE)
   if (match == -1)
     return(NULL)
   len <- attr(match, 'capture.length')
+  # e.g. "foo"
   prefix <- substr(path, 2, 2 + len - 1)
 
   resInfo <- .globals$resources[[prefix]]
   if (is.null(resInfo))
     return(NULL)
 
+  # e.g. "/one/two.html"
   suffix <- substr(path, 2 + len, nchar(path))
 
+  # Create a new request that's a clone of the current request, but adjust
+  # PATH_INFO and SCRIPT_NAME to reflect that we have already matched the first
+  # path element (e.g. "/foo"). See routeHandler() for more info.
   subreq <- as.environment(as.list(req, all.names=TRUE))
   subreq$PATH_INFO <- suffix
   subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, substr(path, 1, 2 + len), sep='')
@@ -98,23 +201,23 @@ resourcePathHandler <- function(req) {
 #'
 #' Defines the server-side logic of the Shiny application. This generally
 #' involves creating functions that map user inputs to various kinds of output.
-#' In older versions of Shiny, it was necessary to call \code{shinyServer()} in
-#' the \code{server.R} file, but this is no longer required as of Shiny 0.10.
-#' Now the \code{server.R} file may simply return the appropriate server
+#' In older versions of Shiny, it was necessary to call `shinyServer()` in
+#' the `server.R` file, but this is no longer required as of Shiny 0.10.
+#' Now the `server.R` file may simply return the appropriate server
 #' function (as the last expression in the code), without calling
-#' \code{shinyServer()}.
+#' `shinyServer()`.
 #'
-#' Call \code{shinyServer} from your application's \code{server.R}
+#' Call `shinyServer` from your application's `server.R`
 #' file, passing in a "server function" that provides the server-side logic of
 #' your application.
 #'
 #' The server function will be called when each client (web browser) first loads
-#' the Shiny application's page. It must take an \code{input} and an
-#' \code{output} parameter. Any return value will be ignored. It also takes an
-#' optional \code{session} parameter, which is used when greater control is
+#' the Shiny application's page. It must take an `input` and an
+#' `output` parameter. Any return value will be ignored. It also takes an
+#' optional `session` parameter, which is used when greater control is
 #' needed.
 #'
-#' See the \href{http://rstudio.github.com/shiny/tutorial/}{tutorial} for more
+#' See the [tutorial](http://rstudio.github.com/shiny/tutorial/) for more
 #' on how to write a server function.
 #'
 #' @param func The server function for this application. See the details section
@@ -141,6 +244,7 @@ resourcePathHandler <- function(req) {
 #' }
 #' }
 #' @export
+#' @keywords internal
 shinyServer <- function(func) {
   .globals$server <- list(func)
   invisible(func)
@@ -155,7 +259,7 @@ decodeMessage <- function(data) {
     # Treat message as UTF-8
     charData <- rawToChar(data)
     Encoding(charData) <- 'UTF-8'
-    return(jsonlite::fromJSON(charData, simplifyVector=FALSE))
+    return(safeFromJSON(charData, simplifyVector=FALSE))
   }
 
   i <- 5
@@ -184,7 +288,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
   # This value, if non-NULL, must be present on all HTTP and WebSocket
   # requests as the Shiny-Shared-Secret header or else access will be
   # denied (403 response for HTTP, and instant close for websocket).
-  sharedSecret <- getOption('shiny.sharedSecret')
+  checkSharedSecret <- loadSharedSecret()
 
   appHandlers <- list(
     http = joinHandlers(c(
@@ -192,10 +296,10 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       httpHandlers,
       sys.www.root,
       resourcePathHandler,
-      reactLogHandler)),
+      reactLogHandler
+    )),
     ws = function(ws) {
-      if (!is.null(sharedSecret)
-          && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
+      if (!checkSharedSecret(ws$request$HTTP_SHINY_SHARED_SECRET)) {
         ws$close()
         return(TRUE)
       }
@@ -218,14 +322,15 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
           if (is.character(msg))
             msg <- charToRaw(msg)
 
-          if (isTRUE(getOption('shiny.trace'))) {
+          traceOption <- getOption('shiny.trace', FALSE)
+          if (isTRUE(traceOption) || traceOption == "recv") {
             if (binary)
               message("RECV ", '$$binary data$$')
             else
               message("RECV ", rawToChar(msg))
           }
 
-          if (identical(charToRaw("\003\xe9"), msg))
+          if (isEmptyMessage(msg))
             return()
 
           msg <- decodeMessage(msg)
@@ -242,125 +347,87 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
             } else {
               # If there's bookmarked state, save it on the session object
               shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
+              shinysession$createBookmarkObservers()
             }
           }
 
-          withRestoreContext(shinysession$restoreContext, {
 
-            unpackInput <- function(name, val) {
-              splitName <- strsplit(name, ':')[[1]]
-              if (length(splitName) > 1) {
-                if (!inputHandlers$containsKey(splitName[[2]])) {
-                  # No input handler registered for this type
-                  stop("No handler registered for type ", name)
+          msg$data <- applyInputHandlers(msg$data)
+
+          switch(
+            msg$method,
+            init = {
+
+              serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+              if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+                appvars$server <- serverFunc
+                if (!is.null(appvars$server))
+                {
+                  # Tag this function as the Shiny server function. A debugger may use this
+                  # tag to give this function special treatment.
+                  # It's very important that it's appvars$server itself and NOT a copy that
+                  # is invoked, otherwise new breakpoints won't be picked up.
+                  attr(appvars$server, "shinyServerFunction") <- TRUE
+                  registerDebugHook("server", appvars, "Server Function")
                 }
-
-                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)
               }
-            }
 
-            msg$data <- mapply(unpackInput, names(msg$data), msg$data,
-                               SIMPLIFY = FALSE)
+              # Check for switching into/out of showcase mode
+              if (.globals$showcaseOverride &&
+                  exists(".clientdata_url_search", where = msg$data)) {
+                mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+                if (!is.null(mode))
+                  shinysession$setShowcase(mode)
+              }
 
-            # Convert names like "button1:shiny.action" to "button1"
-            names(msg$data) <- vapply(
-              names(msg$data),
-              function(name) { strsplit(name, ":")[[1]][1] },
-              FUN.VALUE = character(1)
-            )
+              # In shinysession$createBookmarkObservers() above, observers may be
+              # created, which puts the shiny session in busyCount > 0 state. That
+              # prevents the manageInputs here from taking immediate effect, by
+              # default. The manageInputs here needs to take effect though, because
+              # otherwise the bookmark observers won't find the clientData they are
+              # looking for. So use `now = TRUE` to force the changes to be
+              # immediate.
+              #
+              # FIXME: break createBookmarkObservers into two separate steps, one
+              # before and one after manageInputs, and put the observer creation
+              # in the latter. Then add an assertion that busyCount == 0L when
+              # this manageInputs is called.
+              shinysession$manageInputs(msg$data, now = TRUE)
 
+              # The client tells us what singletons were rendered into
+              # the initial page
+              if (!is.null(msg$data$.clientdata_singletons)) {
+                shinysession$singletons <- strsplit(
+                  msg$data$.clientdata_singletons, ',')[[1]]
+              }
 
-            switch(
-              msg$method,
-              init = {
+              local({
+                args <- argsForServerFunc(serverFunc, shinysession)
 
-                serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-                if (!identicalFunctionBodies(serverFunc, appvars$server)) {
-                  appvars$server <- serverFunc
-                  if (!is.null(appvars$server))
-                  {
-                    # Tag this function as the Shiny server function. A debugger may use this
-                    # tag to give this function special treatment.
-                    # It's very important that it's appvars$server itself and NOT a copy that
-                    # is invoked, otherwise new breakpoints won't be picked up.
-                    attr(appvars$server, "shinyServerFunction") <- TRUE
-                    registerDebugHook("server", appvars, "Server Function")
-                  }
-                }
-
-                # Check for switching into/out of showcase mode
-                if (.globals$showcaseOverride &&
-                    exists(".clientdata_url_search", where = msg$data)) {
-                  mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
-                  if (!is.null(mode))
-                    shinysession$setShowcase(mode)
-                }
-
-                shinysession$manageInputs(msg$data)
-
-                # The client tells us what singletons were rendered into
-                # the initial page
-                if (!is.null(msg$data$.clientdata_singletons)) {
-                  shinysession$singletons <- strsplit(
-                    msg$data$.clientdata_singletons, ',')[[1]]
-                }
-
-                local({
-                  args <- argsForServerFunc(serverFunc, shinysession)
-
-                  withReactiveDomain(shinysession, {
-                    do.call(
-                      # No corresponding ..stacktraceoff; the server func is pure
-                      # user code
-                      wrapFunctionLabel(appvars$server, "server",
-                        ..stacktraceon = TRUE
-                      ),
-                      args
-                    )
-                  })
+                withReactiveDomain(shinysession, {
+                  do.call(
+                    # No corresponding ..stacktraceoff; the server func is pure
+                    # user code
+                    wrapFunctionLabel(appvars$server, "server",
+                      ..stacktraceon = TRUE
+                    ),
+                    args
+                  )
                 })
-              },
-              update = {
-                shinysession$manageInputs(msg$data)
-              },
-              shinysession$dispatch(msg)
-            )
-            shinysession$manageHiddenOutputs()
+              })
+            },
+            update = {
+              shinysession$manageInputs(msg$data)
+            },
+            shinysession$dispatch(msg)
+          )
+          # The HTTP_GUID, if it exists, is for Shiny Server reporting purposes
+          shinysession$startTiming(ws$request$HTTP_GUID)
+          shinysession$requestFlush()
 
-            if (exists(".shiny__stdout", globalenv()) &&
-                exists("HTTP_GUID", ws$request)) {
-              # safe to assume we're in shiny-server
-              shiny_stdout <- get(".shiny__stdout", globalenv())
-
-              # eNter a flushReact
-              writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-
-              flushReact()
-
-              # eXit a flushReact
-              writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-            } else {
-              flushReact()
-            }
-
-            flushAllSessions()
-          })
+          # Make httpuv return control to Shiny quickly, instead of waiting
+          # for the usual timeout
+          httpuv::interrupt()
         })
       }
       ws$onMessage(function(binary, msg) {
@@ -371,6 +438,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       ws$onClose(function() {
         shinysession$wsClosed()
         appsByToken$remove(shinysession$token)
+        appsNeedingFlush$remove(shinysession$token)
       })
 
       return(TRUE)
@@ -400,9 +468,9 @@ argsForServerFunc <- function(serverFunc, session) {
 }
 
 getEffectiveBody <- function(func) {
-  # Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
-  # returns NULL.
-  if (isS4(func) && class(func) == "functionWithTrace")
+  if (is.null(func))
+    NULL
+  else if (isS4(func) && class(func) == "functionWithTrace")
     body(func@original)
   else
     body(func)
@@ -450,11 +518,78 @@ startApp <- function(appObj, port, host, quiet) {
   handlerManager$addHandler(appHandlers$http, "/", tail = TRUE)
   handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE)
 
+  httpuvApp <- handlerManager$createHttpuvApp()
+  httpuvApp$staticPaths <- c(
+    appObj$staticPaths,
+    list(
+      # Always handle /session URLs dynamically, even if / is a static path.
+      "session" = excludeStaticPath(),
+      "shared" = system.file(package = "shiny", "www", "shared")
+    ),
+    .globals$resourcePaths
+  )
+
+  # throw an informative warning if a subdirectory of the
+  # app's www dir conflicts with another resource prefix
+  wwwDir <- httpuvApp$staticPaths[["/"]]$path
+  if (length(wwwDir)) {
+    # although httpuv allows for resource prefixes like 'foo/bar',
+    # we won't worry about conflicts in sub-sub directories since
+    # addResourcePath() currently doesn't allow it
+    wwwSubDirs <- list.dirs(wwwDir, recursive = FALSE, full.names = FALSE)
+    resourceConflicts <- intersect(wwwSubDirs, names(httpuvApp$staticPaths))
+    if (length(resourceConflicts)) {
+      warning(
+        "Found subdirectories of your app's www/ directory that ",
+        "conflict with other resource URL prefixes. ",
+        "Consider renaming these directories: '",
+        paste0("www/", resourceConflicts, collapse = "', '"), "'",
+        call. = FALSE
+      )
+    }
+  }
+
+  # check for conflicts in each pairwise combinations of resource mappings
+  checkResourceConflict <- function(paths) {
+    if (length(paths) < 2) return(NULL)
+    # ensure paths is a named character vector: c(resource_path = local_path)
+    paths <- vapply(paths, function(x) if (inherits(x, "staticPath")) x$path else x, character(1))
+    # get all possible pairwise combinations of paths
+    pair_indices <- utils::combn(length(paths), 2, simplify = FALSE)
+    lapply(pair_indices, function(x) {
+      p1 <- paths[x[1]]
+      p2 <- paths[x[2]]
+      if (identical(names(p1), names(p2)) && (p1 != p2)) {
+        warning(
+          "Found multiple local file paths pointing the same resource prefix: ", names(p1), ". ",
+          "If you run into resource-related issues (e.g. 404 requests), consider ",
+          "using `addResourcePath()` and/or `removeResourcePath()` to manage resource mappings.",
+          call. = FALSE
+        )
+      }
+    })
+  }
+  checkResourceConflict(httpuvApp$staticPaths)
+
+  httpuvApp$staticPathOptions <- httpuv::staticPathOptions(
+    html_charset = "utf-8",
+    headers = list("X-UA-Compatible" = "IE=edge,chrome=1"),
+    validation =
+      if (!is.null(getOption("shiny.sharedSecret"))) {
+        sprintf('"Shiny-Shared-Secret" == "%s"', getOption("shiny.sharedSecret"))
+      } else {
+        character(0)
+      }
+  )
+
   if (is.numeric(port) || is.integer(port)) {
     if (!quiet) {
-      message('\n', 'Listening on http://', host, ':', port)
+      hostString <- host
+      if (httpuv::ipFamily(host) == 6L)
+        hostString <- paste0("[", hostString, "]")
+      message('\n', 'Listening on http://', hostString, ':', port)
     }
-    return(startServer(host, port, handlerManager$createHttpuvApp()))
+    return(startServer(host, port, httpuvApp))
   } else if (is.character(port)) {
     if (!quiet) {
       message('\n', 'Listening on domain socket ', port)
@@ -466,73 +601,89 @@ startApp <- function(appObj, port, host, quiet) {
            "configuration (and not domain sockets), then `port` must ",
            "be numeric, not a string.")
     }
-    return(startPipeServer(port, mask, handlerManager$createHttpuvApp()))
+    return(startPipeServer(port, mask, httpuvApp))
   }
 }
 
 # Run an application that was created by \code{\link{startApp}}. This
 # function should normally be called in a \code{while(TRUE)} loop.
 serviceApp <- function() {
-  if (timerCallbacks$executeElapsed()) {
-    for (shinysession in appsByToken$values()) {
-      shinysession$manageHiddenOutputs()
-    }
+  timerCallbacks$executeElapsed()
 
-    flushReact()
-    flushAllSessions()
-  }
+  flushReact()
+  flushPendingSessions()
 
   # If this R session is interactive, then call service() with a short timeout
   # to keep the session responsive to user input
   maxTimeout <- ifelse(interactive(), 100, 1000)
 
-  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent()))
+  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs()))
   service(timeout)
+
+  flushReact()
+  flushPendingSessions()
 }
 
 .shinyServerMinVersion <- '0.3.4'
 
+# Global flag that's TRUE whenever we're inside of the scope of a call to runApp
+.globals$running <- FALSE
+
+#' Check whether a Shiny application is running
+#'
+#' This function tests whether a Shiny application is currently running.
+#'
+#' @return `TRUE` if a Shiny application is currently running. Otherwise,
+#'   `FALSE`.
+#' @export
+isRunning <- function() {
+  .globals$running
+}
+
 #' Run Shiny Application
 #'
 #' Runs a Shiny application. This function normally does not return; interrupt R
 #' to stop the application (usually by pressing Ctrl+C or Esc).
 #'
 #' The host parameter was introduced in Shiny 0.9.0. Its default value of
-#' \code{"127.0.0.1"} means that, contrary to previous versions of Shiny, only
+#' `"127.0.0.1"` means that, contrary to previous versions of Shiny, only
 #' the current machine can access locally hosted Shiny apps. To allow other
-#' clients to connect, use the value \code{"0.0.0.0"} instead (which was the
+#' clients to connect, use the value `"0.0.0.0"` instead (which was the
 #' value that was hard-coded into Shiny in 0.8.0 and earlier).
 #'
 #' @param appDir The application to run. Should be one of the following:
 #'   \itemize{
-#'   \item A directory containing \code{server.R}, plus, either \code{ui.R} or
-#'    a \code{www} directory that contains the file \code{index.html}.
-#'   \item A directory containing \code{app.R}.
-#'   \item An \code{.R} file containing a Shiny application, ending with an
+#'   \item A directory containing `server.R`, plus, either `ui.R` or
+#'    a `www` directory that contains the file `index.html`.
+#'   \item A directory containing `app.R`.
+#'   \item An `.R` file containing a Shiny application, ending with an
 #'    expression that produces a Shiny app object.
-#'   \item A list with \code{ui} and \code{server} components.
-#'   \item A Shiny app object created by \code{\link{shinyApp}}.
+#'   \item A list with `ui` and `server` components.
+#'   \item A Shiny app object created by [shinyApp()].
 #'   }
 #' @param port The TCP port that the application should listen on. If the
-#'   \code{port} is not specified, and the \code{shiny.port} option is set (with
-#'   \code{options(shiny.port = XX)}), then that port will be used. Otherwise,
+#'   `port` is not specified, and the `shiny.port` option is set (with
+#'   `options(shiny.port = XX)`), then that port will be used. Otherwise,
 #'   use a random port.
 #' @param launch.browser If true, the system's default web browser will be
 #'   launched automatically after the app is started. Defaults to true in
 #'   interactive sessions only. This value of this parameter can also be a
 #'   function to call with the application's URL.
 #' @param host The IPv4 address that the application should listen on. Defaults
-#'   to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not. See
+#'   to the `shiny.host` option, if set, or `"127.0.0.1"` if not. See
 #'   Details.
 #' @param workerId Can generally be ignored. Exists to help some editions of
 #'   Shiny Server Pro route requests to the correct process.
 #' @param quiet Should Shiny status messages be shown? Defaults to FALSE.
 #' @param display.mode The mode in which to display the application. If set to
-#'   the value \code{"showcase"}, shows application code and metadata from a
-#'   \code{DESCRIPTION} file in the application directory alongside the
-#'   application. If set to \code{"normal"}, displays the application normally.
-#'   Defaults to \code{"auto"}, which displays the application in the mode given
-#'   in its \code{DESCRIPTION} file, if any.
+#'   the value `"showcase"`, shows application code and metadata from a
+#'   `DESCRIPTION` file in the application directory alongside the
+#'   application. If set to `"normal"`, displays the application normally.
+#'   Defaults to `"auto"`, which displays the application in the mode given
+#'   in its `DESCRIPTION` file, if any.
+#' @param test.mode Should the application be launched in test mode? This is
+#'   only used for recording or running automated tests. Defaults to the
+#'   `shiny.testmode` option, or FALSE if the option is not set.
 #'
 #' @examples
 #' \dontrun{
@@ -545,6 +696,8 @@ serviceApp <- function() {
 #'
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   # Apps can be run without a server.r and ui.r file
 #'   runApp(list(
 #'     ui = bootstrapPage(
@@ -576,25 +729,86 @@ runApp <- function(appDir=getwd(),
                                             interactive()),
                    host=getOption('shiny.host', '127.0.0.1'),
                    workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase")) {
+                   display.mode=c("auto", "normal", "showcase"),
+                   test.mode=getOption('shiny.testmode', FALSE)) {
   on.exit({
     handlerManager$clear()
   }, add = TRUE)
 
-  # Enable per-app Shiny options
+  if (.globals$running) {
+    stop("Can't call `runApp()` from within `runApp()`. If your ",
+         "application code contains `runApp()`, please remove it.")
+  }
+  .globals$running <- TRUE
+  on.exit({
+    .globals$running <- FALSE
+  }, add = TRUE)
+
+  # Enable per-app Shiny options, for shinyOptions() and getShinyOption().
   oldOptionSet <- .globals$options
   on.exit({
     .globals$options <- oldOptionSet
   },add = TRUE)
 
-  if (is.null(host) || is.na(host))
-    host <- '0.0.0.0'
+  # A unique identifier associated with this run of this application. It is
+  # shared across sessions.
+  shinyOptions(appToken = createUniqueId(8))
 
   # Make warnings print immediately
   # Set pool.scheduler to support pool package
-  ops <- options(warn = 1, pool.scheduler = scheduleTask)
+  ops <- options(
+    # Raise warn level to 1, but don't lower it
+    warn = max(1, getOption("warn", default = 1)),
+    pool.scheduler = scheduleTask
+  )
   on.exit(options(ops), add = TRUE)
 
+  # Set up default cache for app.
+  if (is.null(getShinyOption("cache"))) {
+    shinyOptions(cache = MemoryCache$new())
+  }
+
+  appParts <- as.shiny.appobj(appDir)
+
+  # The lines below set some of the app's running options, which
+  # can be:
+  #   - left unspeficied (in which case the arguments' default
+  #     values from `runApp` kick in);
+  #   - passed through `shinyApp`
+  #   - passed through `runApp` (this function)
+  #   - passed through both `shinyApp` and `runApp` (the latter
+  #     takes precedence)
+  #
+  # Matrix of possibilities:
+  # | IN shinyApp | IN runApp | result       | check                                                                                                                                  |
+  # |-------------|-----------|--------------|----------------------------------------------------------------------------------------------------------------------------------------|
+  # | no          | no        | use defaults | exhaust all possibilities: if it's missing (runApp does not specify); THEN if it's not in shinyApp appParts$options; THEN use defaults |
+  # | yes         | no        | use shinyApp | if it's missing (runApp does not specify); THEN if it's in shinyApp appParts$options; THEN use shinyApp                                |
+  # | no          | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
+  # | yes         | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
+  #
+  # I tried to make this as compact and intuitive as possible,
+  # given that there are four distinct possibilities to check
+  appOps <- appParts$options
+  findVal <- function(arg, default) {
+    if (arg %in% names(appOps)) appOps[[arg]] else default
+  }
+
+  if (missing(port))
+    port <- findVal("port", port)
+  if (missing(launch.browser))
+    launch.browser <- findVal("launch.browser", launch.browser)
+  if (missing(host))
+    host <- findVal("host", host)
+  if (missing(quiet))
+    quiet <- findVal("quiet", quiet)
+  if (missing(display.mode))
+    display.mode <- findVal("display.mode", display.mode)
+  if (missing(test.mode))
+    test.mode <- findVal("test.mode", test.mode)
+
+  if (is.null(host) || is.na(host)) host <- '0.0.0.0'
+
   workerId(workerId)
 
   if (inShinyServer()) {
@@ -614,6 +828,11 @@ runApp <- function(appDir=getwd(),
   # the display.mode parameter. The latter takes precedence.
   setShowcaseDefault(0)
 
+  .globals$testMode <- test.mode
+  if (test.mode) {
+    message("Running application in test mode.")
+  }
+
   # If appDir specifies a path, and display mode is specified in the
   # DESCRIPTION file at that path, apply it here.
   if (is.character(appDir)) {
@@ -685,7 +904,8 @@ runApp <- function(appDir=getwd(),
           port <- p_randomInt(3000, 8000)
           # Reject ports in this range that are considered unsafe by Chrome
           # http://superuser.com/questions/188058/which-ports-are-considered-unsafe-on-chrome
-          if (!port %in% c(3659, 4045, 6000, 6665:6669)) {
+          # https://github.com/rstudio/shiny/issues/1784
+          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
             break
           }
         }
@@ -701,29 +921,47 @@ runApp <- function(appDir=getwd(),
     }
   }
 
-  appParts <- as.shiny.appobj(appDir)
+  # Invoke user-defined onStop callbacks, before the application's internal
+  # onStop callbacks.
+  on.exit({
+    .globals$onStopCallbacks$invoke()
+    .globals$onStopCallbacks <- Callbacks$new()
+  }, add = TRUE)
 
   # Extract appOptions (which is a list) and store them as shinyOptions, for
   # this app. (This is the only place we have to store settings that are
   # accessible both the UI and server portion of the app.)
   unconsumeAppOptions(appParts$appOptions)
 
-  # Set up the onEnd before we call onStart, so that it gets called even if an
+  # Set up the onStop before we call onStart, so that it gets called even if an
   # error happens in onStart.
-  if (!is.null(appParts$onEnd))
-    on.exit(appParts$onEnd(), add = TRUE)
+  if (!is.null(appParts$onStop))
+    on.exit(appParts$onStop(), add = TRUE)
   if (!is.null(appParts$onStart))
     appParts$onStart()
 
   server <- startApp(appParts, port, host, quiet)
 
+  # Make the httpuv server object accessible. Needed for calling
+  # addResourcePath while app is running.
+  shinyOptions(server = server)
+
   on.exit({
     stopServer(server)
   }, add = TRUE)
 
   if (!is.character(port)) {
-    # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
-    browseHost <- if (identical(host, "0.0.0.0")) "127.0.0.1" else host
+    browseHost <- host
+    if (identical(host, "0.0.0.0")) {
+      # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
+      browseHost <- "127.0.0.1"
+    } else if (identical(host, "::")) {
+      browseHost <- "::1"
+    }
+
+    if (httpuv::ipFamily(browseHost) == 6L) {
+      browseHost <- paste0("[", browseHost, "]")
+    }
 
     appUrl <- paste("http://", browseHost, ":", port, sep="")
     if (is.function(launch.browser))
@@ -746,12 +984,11 @@ runApp <- function(appDir=getwd(),
   # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
   # reactive(), Callbacks$invoke(), and others
   ..stacktraceoff..(
-    captureStackTraces(
+    captureStackTraces({
       while (!.globals$stopped) {
-        serviceApp()
-        Sys.sleep(0.001)
+        ..stacktracefloor..(serviceApp())
       }
-    )
+    })
   )
 
   if (isTRUE(.globals$reterror)) {
@@ -766,10 +1003,10 @@ runApp <- function(appDir=getwd(),
 #' Stop the currently running Shiny app
 #'
 #' Stops the currently running Shiny app, returning control to the caller of
-#' \code{\link{runApp}}.
+#' [runApp()].
 #'
 #' @param returnValue The value that should be returned from
-#'   \code{\link{runApp}}.
+#'   [runApp()].
 #' @export
 stopApp <- function(returnValue = invisible()) {
   # reterror will indicate whether retval is an error (i.e. it should be passed
@@ -798,7 +1035,7 @@ stopApp <- function(returnValue = invisible()) {
 #'
 #' Launch Shiny example applications, and optionally, your system's web browser.
 #'
-#' @param example The name of the example to run, or \code{NA} (the default) to
+#' @param example The name of the example to run, or `NA` (the default) to
 #'   list the available examples.
 #' @param port The TCP port that the application should listen on. Defaults to
 #'   choosing a random port.
@@ -806,9 +1043,9 @@ stopApp <- function(returnValue = invisible()) {
 #'   launched automatically after the app is started. Defaults to true in
 #'   interactive sessions only.
 #' @param host The IPv4 address that the application should listen on. Defaults
-#'   to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not.
+#'   to the `shiny.host` option, if set, or `"127.0.0.1"` if not.
 #' @param display.mode The mode in which to display the example. Defaults to
-#'   \code{showcase}, but may be set to \code{normal} to see the example without
+#'   `showcase`, but may be set to `normal` to see the example without
 #'   code or commentary.
 #'
 #' @examples
@@ -855,21 +1092,21 @@ runExample <- function(example=NA,
 
 #' Run a gadget
 #'
-#' Similar to \code{runApp}, but handles \code{input$cancel} automatically, and
+#' Similar to `runApp`, but handles `input$cancel` automatically, and
 #' if running in RStudio, defaults to viewing the app in the Viewer pane.
 #'
 #' @param app Either a Shiny app object as created by
-#'   \code{\link[=shiny]{shinyApp}} et al, or, a UI object.
-#' @param server Ignored if \code{app} is a Shiny app object; otherwise, passed
-#'   along to \code{shinyApp} (i.e. \code{shinyApp(ui = app, server = server)}).
-#' @param port See \code{\link[=shiny]{runApp}}.
+#'   [`shinyApp()`][shiny] et al, or, a UI object.
+#' @param server Ignored if `app` is a Shiny app object; otherwise, passed
+#'   along to `shinyApp` (i.e. `shinyApp(ui = app, server = server)`).
+#' @param port See [`runApp()`][shiny].
 #' @param viewer Specify where the gadget should be displayed--viewer pane,
 #'   dialog window, or external browser--by passing in a call to one of the
-#'   \code{\link{viewer}} functions.
-#' @param stopOnCancel If \code{TRUE} (the default), then an \code{observeEvent}
-#'   is automatically created that handles \code{input$cancel} by calling
-#'   \code{stopApp()} with an error. Pass \code{FALSE} if you want to handle
-#'   \code{input$cancel} yourself.
+#'   [viewer()] functions.
+#' @param stopOnCancel If `TRUE` (the default), then an `observeEvent`
+#'   is automatically created that handles `input$cancel` by calling
+#'   `stopApp()` with an error. Pass `FALSE` if you want to handle
+#'   `input$cancel` yourself.
 #' @return The value returned by the gadget.
 #'
 #' @examples
@@ -934,10 +1171,10 @@ decorateServerFunc <- function(appobj, serverFunc) {
 #' other R environments that emulate RStudio's viewer pane/dialog APIs). If
 #' viewer APIs are not available in the current R environment, then the gadget
 #' will be displayed in the system's default web browser (see
-#' \code{\link[utils]{browseURL}}).
+#' [utils::browseURL()]).
 #'
-#' @return A function that takes a single \code{url} parameter, suitable for
-#'   passing as the \code{viewer} argument of \code{\link{runGadget}}.
+#' @return A function that takes a single `url` parameter, suitable for
+#'   passing as the `viewer` argument of [runGadget()].
 #'
 #' @rdname viewer
 #' @name viewer
@@ -945,8 +1182,8 @@ NULL
 
 #' @param minHeight The minimum height (in pixels) desired to show the gadget in
 #'   the viewer pane. If a positive number, resize the pane if necessary to show
-#'   at least that many pixels. If \code{NULL}, use the existing viewer pane
-#'   size. If \code{"maximize"}, use the maximum available vertical space.
+#'   at least that many pixels. If `NULL`, use the existing viewer pane
+#'   size. If `"maximize"`, use the maximum available vertical space.
 #' @rdname viewer
 #' @export
 paneViewer <- function(minHeight = NULL) {
@@ -975,7 +1212,7 @@ dialogViewer <- function(dialogName, width = 600, height = 600) {
   }
 }
 
-#' @param browser See \code{\link[utils]{browseURL}}.
+#' @param browser See [utils::browseURL()].
 #' @rdname viewer
 #' @export
 browserViewer <- function(browser = getOption("browser")) {
@@ -989,3 +1226,9 @@ browserViewer <- function(browser = getOption("browser")) {
 inShinyServer <- function() {
   nzchar(Sys.getenv('SHINY_PORT'))
 }
+
+# This check was moved out of the main function body because of an issue with
+# the RStudio debugger. (#1474)
+isEmptyMessage <- function(msg) {
+  identical(as.raw(c(0x03, 0xe9)), msg)
+}

R/shiny-options.R

@@ -16,20 +16,103 @@ getShinyOption <- function(name, default = NULL) {
 
 #' 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.
+#' `getShinyOption()` retrieves the value of a Shiny option. `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
+#' @section Scope:
+#' There is a global option set which is available by default. When a Shiny
+#' application is run with [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}.
+#' @section Options:
+#' There are a number of global options that affect Shiny's behavior. These can
+#' be set globally with `options()` or locally (for a single app) with
+#' `shinyOptions()`.
 #'
+#' \describe{
+#' \item{shiny.autoreload (defaults to `FALSE`)}{If `TRUE` when a Shiny app is launched, the
+#'   app directory will be continually monitored for changes to files that
+#'   have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. If any
+#'   changes are detected, all connected Shiny sessions are reloaded. This
+#'   allows for fast feedback loops when tweaking Shiny UI.
+#'
+#'   Since monitoring for changes is expensive (we simply poll for last
+#'   modified times), 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 default polling interval is 500 milliseconds. You can change this
+#'   by setting e.g. `options(shiny.autoreload.interval = 2000)` (every
+#'   two seconds).}
+#' \item{shiny.deprecation.messages (defaults to `TRUE`)}{This controls whether messages for
+#'   deprecated functions in Shiny will be printed. See
+#'   [shinyDeprecated()] for more information.}
+#' \item{shiny.error (defaults to `NULL`)}{This can be a function which is called when an error
+#'   occurs. For example, `options(shiny.error=recover)` will result a
+#'   the debugger prompt when an error occurs.}
+#' \item{shiny.fullstacktrace (defaults to `FALSE`)}{Controls whether "pretty" (`FALSE`) or full
+#'   stack traces (`TRUE`) are dumped to the console when errors occur during Shiny app execution.
+#'   Pretty stack traces attempt to only show user-supplied code, but this pruning can't always
+#'   be done 100% correctly.}
+#' \item{shiny.host (defaults to `"127.0.0.1"`)}{The IP address that Shiny should listen on. See
+#'   [runApp()] for more information.}
+#' \item{shiny.jquery.version (defaults to `3`)}{The major version of jQuery to use.
+#' Currently only values of `3` or `1` are supported. If `1`, then jQuery 1.12.4 is used. If `3`,
+#' then jQuery 3.4.1 is used.}
+#' \item{shiny.json.digits (defaults to `16`)}{The number of digits to use when converting
+#'   numbers to JSON format to send to the client web browser.}
+#' \item{shiny.launch.browser (defaults to `interactive()`)}{A boolean which controls the default behavior
+#'   when an app is run. See [runApp()] for more information.}
+#' \item{shiny.maxRequestSize (defaults to 5MB)}{This is a number which specifies the maximum
+#'   web request size, which serves as a size limit for file uploads.}
+#' \item{shiny.minified (defaults to `TRUE`)}{By default
+#'   Whether or not to include Shiny's JavaScript as a minified (`shiny.min.js`)
+#'   or un-minified (`shiny.js`) file. The un-minified version is larger,
+#'   but can be helpful for development and debugging.}
+#' \item{shiny.port (defaults to a random open port)}{A port number that Shiny will listen on. See
+#'   [runApp()] for more information.}
+#' \item{shiny.reactlog (defaults to `FALSE`)}{If `TRUE`, enable logging of reactive events,
+#'   which can be viewed later with the [reactlogShow()] function.
+#'   This incurs a substantial performance penalty and should not be used in
+#'   production.}
+#' \item{shiny.sanitize.errors (defaults to `FALSE`)}{If `TRUE`, then normal errors (i.e.
+#'   errors not wrapped in `safeError`) won't show up in the app; a simple
+#'   generic error message is printed instead (the error and strack trace printed
+#'   to the console remain unchanged). If you want to sanitize errors in general, but you DO want a
+#'   particular error `e` to get displayed to the user, then set this option
+#'   to `TRUE` and use `stop(safeError(e))` for errors you want the
+#'   user to see.}
+#' \item{shiny.stacktraceoffset (defaults to `TRUE`)}{If `TRUE`, then Shiny's printed stack
+#'   traces will display srcrefs one line above their usual location. This is
+#'   an arguably more intuitive arrangement for casual R users, as the name
+#'   of a function appears next to the srcref where it is defined, rather than
+#'   where it is currently being called from.}
+#' \item{shiny.suppressMissingContextError (defaults to `FALSE`)}{Normally, invoking a reactive
+#'   outside of a reactive context (or [isolate()]) results in
+#'   an error. If this is `TRUE`, don't error in these cases. This
+#'   should only be used for debugging or demonstrations of reactivity at the
+#'   console.}
+#' \item{shiny.testmode (defaults to `FALSE`)}{If `TRUE`, then various features for testing Shiny
+#'   applications are enabled.}
+#' \item{shiny.trace (defaults to `FALSE`)}{Print messages sent between the R server and the web
+#'   browser client to the R console. This is useful for debugging. Possible
+#'   values are `"send"` (only print messages sent to the client),
+#'   `"recv"` (only print messages received by the server), `TRUE`
+#'   (print all messages), or `FALSE` (default; don't print any of these
+#'   messages).}
+#' \item{shiny.usecairo (defaults to `TRUE`)}{This is used to disable graphical rendering by the
+#'   Cairo package, if it is installed. See [plotPNG()] for more
+#'   information.}
+#' }
+#' @param ... Options to set, with the form `name = value`.
+#' @aliases shiny-options
 #' @examples
 #' \dontrun{
 #' shinyOptions(myOption = 10)

R/shinyui.R

@@ -4,9 +4,9 @@ NULL
 #' Load the MathJax library and typeset math expressions
 #'
 #' This function adds MathJax to the page and typeset the math expressions (if
-#' found) in the content \code{...}. It only needs to be called once in an app
-#' unless the content is rendered \emph{after} the page is loaded, e.g. via
-#' \code{\link{renderUI}}, in which case we have to call it explicitly every
+#' found) in the content `...`. It only needs to be called once in an app
+#' unless the content is rendered *after* the page is loaded, e.g. via
+#' [renderUI()], in which case we have to call it explicitly every
 #' time we write math expressions to the output.
 #' @param ... any HTML elements to apply MathJax to
 #' @export
@@ -14,7 +14,7 @@ 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'))
@@ -24,7 +24,7 @@ withMathJax <- function(...) {
   )
 }
 
-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")) {
@@ -42,14 +42,40 @@ renderPage <- function(ui, connection, showcase=0) {
     )
   }
 
+  jquery <- function() {
+    version <- getOption("shiny.jquery.version", 3)
+    if (version == 3) {
+      return(htmlDependency(
+        "jquery", "3.4.1",
+        c(href = "shared"),
+        script = "jquery.min.js"
+      ))
+    }
+    if (version == 1) {
+      return(htmlDependency(
+        "jquery", "1.12.4",
+        c(href = "shared/legacy"),
+        script = "jquery.min.js"
+      ))
+    }
+    stop("Unsupported version of jQuery: ", version)
+  }
+
   shiny_deps <- list(
     htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
-    htmlDependency("jquery", "1.12.4", c(href="shared"), script = "jquery.min.js"),
-    htmlDependency("babel-polyfill", "6.7.2", c(href="shared"), script = "babel-polyfill.min.js"),
+    jquery(),
     htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
       script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
       stylesheet = "shiny.css")
   )
+
+  if (testMode) {
+    # Add code injection listener if in test mode
+    shiny_deps[[length(shiny_deps) + 1]] <-
+      htmlDependency("shiny-testmode", utils::packageVersion("shiny"),
+        c(href="shared"), script = "shiny-testmode.js")
+  }
+
   html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
   writeUTF8(html, con = connection)
 }
@@ -64,6 +90,7 @@ renderPage <- function(ui, connection, showcase=0) {
 #'
 #' @param ui A user interace definition
 #' @return The user interface definition, without modifications or side effects.
+#' @keywords internal
 #' @export
 shinyUI <- function(ui) {
   .globals$ui <- list(ui)
@@ -91,6 +118,8 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
         showcaseMode <- mode
     }
 
+    testMode <- .globals$testMode %OR% FALSE
+
     # Create a restore context using query string
     bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
     if (bookmarkStore == "disable") {
@@ -121,7 +150,7 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
     if (is.null(uiValue))
       return(NULL)
 
-    renderPage(uiValue, textConn, showcaseMode)
+    renderPage(uiValue, textConn, showcaseMode, testMode)
     html <- paste(readLines(textConn, encoding = 'UTF-8'), collapse='\n')
     return(httpResponse(200, content=enc2utf8(html)))
   }

R/shinywrappers.R

@@ -1,8 +1,8 @@
-globalVariables('func')
+utils::globalVariables('func')
 
 #' Mark a function as a render function
 #'
-#' Should be called by implementers of \code{renderXXX} functions in order to
+#' Should be called by implementers of `renderXXX` functions in order to
 #' mark their return values as Shiny render functions, and to provide a hint to
 #' Shiny regarding what UI function is most commonly used with this type of
 #' render function. This can be used in R Markdown documents to create complete
@@ -12,13 +12,13 @@ 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
+#' @param outputArgs A list of arguments to pass to the `uiFunc`. Render
+#'   functions should include `outputArgs = list()` in their own parameter
+#'   list, and pass through the value to `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.
+#' @return The `renderFunc` function, with annotations.
 #' @export
 markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
   # a mutable object that keeps track of whether `useRenderFunction` has been
@@ -52,6 +52,54 @@ markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
             hasExecuted = hasExecuted)
 }
 
+#' @export
+print.shiny.render.function <- function(x, ...) {
+  cat_line("<shiny.render.function>")
+}
+
+#' 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: `value`,
+#'   `session`, `name`, and `...` (for future-proofing). This
+#'   function will be invoked each time a value is returned from `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 `outputFunc`.
+#'   Render functions should include `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
+#'   `output` slot.
+#'
+#' @export
+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")
@@ -68,12 +116,16 @@ useRenderFunction <- function(renderFunc, inline = FALSE) {
   }
 
   id <- createUniqueId(8, "out")
-  # Make the id the first positional argument
-  outputArgs <- c(list(id), outputArgs)
 
   o <- getDefaultReactiveDomain()$output
-  if (!is.null(o))
+  if (!is.null(o)) {
     o[[id]] <- renderFunc
+    # 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
@@ -88,45 +140,74 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
   useRenderFunction(x, inline = inline)
 }
 
+
+#' Mark a render function with attributes that will be used by the output
+#'
+#' @inheritParams markRenderFunction
+#' @param snapshotExclude If TRUE, exclude the output from test snapshots.
+#' @param snapshotPreprocess A function for preprocessing the value before
+#'   taking a test snapshot.
+#'
+#' @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()
+  }
+
+  if (!is.null(snapshotExclude)) {
+    attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
+  }
+
+  if (!is.null(snapshotPreprocess)) {
+    attr(renderFunc, "outputAttrs")$snapshotPreprocess <- snapshotPreprocess
+  }
+
+  renderFunc
+}
+
 #' Image file output
 #'
-#' Renders a reactive image that is suitable for assigning to an \code{output}
+#' Renders a reactive image that is suitable for assigning to an `output`
 #' slot.
 #'
-#' The expression \code{expr} must return a list containing the attributes for
-#' the \code{img} object on the client web page. For the image to display,
-#' properly, the list must have at least one entry, \code{src}, which is the
-#' path to the image file. It may also useful to have a \code{contentType}
+#' The expression `expr` must return a list containing the attributes for
+#' the `img` object on the client web page. For the image to display,
+#' properly, the list must have at least one entry, `src`, which is the
+#' path to the image file. It may also useful to have a `contentType`
 #' entry specifying the MIME type of the image. If one is not provided,
-#' \code{renderImage} will try to autodetect the type, based on the file
+#' `renderImage` will try to autodetect the type, based on the file
 #' extension.
 #'
-#' Other elements such as \code{width}, \code{height}, \code{class}, and
-#' \code{alt}, can also be added to the list, and they will be used as
-#' attributes in the \code{img} object.
+#' Other elements such as `width`, `height`, `class`, and
+#' `alt`, can also be added to the list, and they will be used as
+#' attributes in the `img` object.
 #'
-#' The corresponding HTML output tag should be \code{div} or \code{img} and have
-#' the CSS class name \code{shiny-image-output}.
+#' The corresponding HTML output tag should be `div` or `img` and have
+#' the CSS class name `shiny-image-output`.
 #'
 #' @seealso For more details on how the images are generated, and how to control
-#'   the output, see \code{\link{plotPNG}}.
+#'   the output, see [plotPNG()].
 #'
 #' @param expr An expression that returns a list.
-#' @param env The environment in which to evaluate \code{expr}.
-#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#' @param env The environment in which to evaluate `expr`.
+#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
 #'   is useful if you want to save an expression in a variable.
-#' @param deleteFile Should the file in \code{func()$src} be deleted after
+#' @param deleteFile Should the file in `func()$src` be deleted after
 #'   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}.
+#'   temp file generated within `func`, then this should be `TRUE`;
+#'   if the image is not a temp file, this should be `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
+#'   call to [imageOutput()] when `renderImage` is used in an
 #'   interactive R Markdown document.
 #' @export
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   sliderInput("n", "Number of observations", 2, 1000, 500),
@@ -193,26 +274,25 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
                         deleteFile=TRUE, outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    imageinfo <- func()
-    # Should the file be deleted after being sent? If .deleteFile not set or if
-    # TRUE, then delete; otherwise don't delete.
-    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
-    contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
+      # 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)
-  }
-
-  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
+      # Return a list with src, and other img attributes
+      c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
+        extra_attr)
+    },
+    imageOutput, outputArgs)
 }
 
 
@@ -220,30 +300,30 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' Makes a reactive version of the given function that captures any printed
 #' output, and also captures its printable result (unless
-#' \code{\link{invisible}}), into a string. The resulting function is suitable
-#' for assigning to an  \code{output} slot.
+#' [base::invisible()]), into a string. The resulting function is suitable
+#' for assigning to an  `output` slot.
 #'
-#' The corresponding HTML output tag can be anything (though \code{pre} is
+#' The corresponding HTML output tag can be anything (though `pre` is
 #' recommended if you need a monospace font and whitespace preserved) and should
-#' have the CSS class name \code{shiny-text-output}.
+#' have the CSS class name `shiny-text-output`.
 #'
-#' The result of executing \code{func} will be printed inside a
-#' \code{\link[utils]{capture.output}} call.
+#' The result of executing `func` will be printed inside a
+#' [utils::capture.output()] call.
 #'
 #' 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}()}.
+#' returns `NULL` then `NULL` will actually be visible in the output.
+#' To display nothing, make your function return [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 env The environment in which to evaluate `expr`.
+#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
 #'   is useful if you want to save an expression in a variable.
-#' @param width The value for \code{\link{options}('width')}.
+#' @param width The value for `[options][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
+#'   call to [verbatimTextOutput()] when `renderPrint` is used
 #'   in an interactive R Markdown document.
-#' @seealso \code{\link{renderText}} for displaying the value returned from a
+#' @seealso [renderText()] for displaying the value returned from a
 #'   function, instead of the printed output.
 #'
 #' @example res/text-example.R
@@ -252,72 +332,133 @@ 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, ...) {
-    op <- options(width = width)
-    on.exit(options(op), add = TRUE)
-    paste(utils::capture.output(func()), collapse = "\n")
+    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, 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
 #'
 #' Makes a reactive version of the given function that also uses
-#' \code{\link[base]{cat}} to turn its result into a single-element character
+#' [base::cat()] to turn its result into a single-element character
 #' vector.
 #'
-#' The corresponding HTML output tag can be anything (though \code{pre} is
+#' The corresponding HTML output tag can be anything (though `pre` is
 #' recommended if you need a monospace font and whitespace preserved) and should
-#' have the CSS class name \code{shiny-text-output}.
+#' have the CSS class name `shiny-text-output`.
 #'
-#' The result of executing \code{func} will passed to \code{cat}, inside a
-#' \code{\link[utils]{capture.output}} call.
+#' The result of executing `func` will passed to `cat`, inside a
+#' [utils::capture.output()] call.
 #'
 #' @param expr An expression that returns an R object that can be used as an
-#'   argument to \code{cat}.
-#' @param env The environment in which to evaluate \code{expr}.
-#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#'   argument to `cat`.
+#' @param env The environment in which to evaluate `expr`.
+#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
 #'   is useful if you want to save an expression in a variable.
 #' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to \code{\link{textOutput}} when \code{renderText} is used in an
+#'   call to [textOutput()] when `renderText` is used in an
 #'   interactive R Markdown document.
+#' @param sep A separator passed to `cat` to be appended after each
+#'   element.
 #'
-#' @seealso \code{\link{renderPrint}} for capturing the print output of a
+#' @seealso [renderPrint()] for capturing the print output of a
 #'   function, rather than the returned text value.
 #'
 #' @example res/text-example.R
 #' @export
 renderText <- function(expr, env=parent.frame(), quoted=FALSE,
-                       outputArgs=list()) {
+                       outputArgs=list(), sep=" ") {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    value <- func()
-    return(paste(utils::capture.output(cat(value)), collapse="\n"))
-  }
-
-  markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
+  createRenderFunction(
+    func,
+    function(value, session, name, ...) {
+      paste(utils::capture.output(cat(value, sep=sep)), 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}}).
+#' The corresponding HTML output tag should be `div` and have the CSS class
+#' name `shiny-html-output` (or use [uiOutput()]).
 #'
-#' @param expr An expression that returns a Shiny tag object, \code{\link{HTML}},
+#' @param expr An expression that returns a Shiny tag object, [HTML()],
 #'   or a list of such objects.
-#' @param env The environment in which to evaluate \code{expr}.
-#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#' @param env The environment in which to evaluate `expr`.
+#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
 #'   is useful if you want to save an expression in a variable.
 #' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to \code{\link{uiOutput}} when \code{renderUI} is used in an
+#'   call to [uiOutput()] when `renderUI` is used in an
 #'   interactive R Markdown document.
 #'
-#' @seealso conditionalPanel
+#' @seealso [uiOutput()]
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -342,15 +483,16 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
                      outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- 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)
 
-    processDeps(result, shinysession)
-  }
-
-  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
+      processDeps(result, shinysession)
+    },
+    uiOutput, outputArgs
+  )
 }
 
 #' File Downloads
@@ -359,25 +501,25 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
 #' file downloads (for example, downloading the currently visible data as a CSV
 #' file). Both filename and contents can be calculated dynamically at the time
 #' the user initiates the download. Assign the return value to a slot on
-#' \code{output} in your server function, and in the UI use
-#' \code{\link{downloadButton}} or \code{\link{downloadLink}} to make the
+#' `output` in your server function, and in the UI use
+#' [downloadButton()] or [downloadLink()] to make the
 #' download available.
 #'
 #' @param filename A string of the filename, including extension, that the
 #'   user's web browser should default to when downloading the file; or a
 #'   function that returns such a string. (Reactive values and functions may be
 #'   used from this function.)
-#' @param content A function that takes a single argument \code{file} that is a
+#' @param content A function that takes a single argument `file` that is a
 #'   file path (string) of a nonexistent temp file, and writes the content to
 #'   that file path. (Reactive values and functions may be used from this
 #'   function.)
 #' @param contentType A string of the download's
-#'   \href{http://en.wikipedia.org/wiki/Internet_media_type}{content type}, for
-#'   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.
+#'   [content type](http://en.wikipedia.org/wiki/Internet_media_type), for
+#'   example `"text/csv"` or `"image/png"`. If `NULL` or
+#'   `NA`, the content type will be guessed based on the filename
+#'   extension, or `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
+#'   call to [downloadButton()] when `downloadHandler` is used
 #'   in an interactive R Markdown document.
 #'
 #' @examples
@@ -409,7 +551,9 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
   renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
   }
-  markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+  snapshotExclude(
+    markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+  )
 }
 
 #' Table output with the JavaScript library DataTables
@@ -419,12 +563,12 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #' searching, filtering, and sorting can be done on the R side using Shiny as
 #' 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
+#' For the `options` argument, the character elements that have the class
+#' `"AsIs"` (usually returned from [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
-#' options list, and the \code{I()} notation does not work for lower-level
+#' options list, and the `I()` notation does not work for lower-level
 #' elements in the list.
 #' @param expr An expression that returns a data frame or a matrix.
 #' @param options A list of initialization options to be passed to DataTables,
@@ -433,25 +577,25 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #'   frequent search requests).
 #' @param callback A JavaScript function to be applied to the DataTable object.
 #'   This is useful for DataTables plug-ins, which often require the DataTable
-#'   instance to be available (\url{http://datatables.net/extensions/}).
-#' @param escape Whether to escape HTML entities in the table: \code{TRUE} means
-#'   to escape the whole table, and \code{FALSE} means not to escape it.
+#'   instance to be available (<http://datatables.net/extensions/>).
+#' @param escape Whether to escape HTML entities in the table: `TRUE` means
+#'   to escape the whole table, and `FALSE` means not to escape it.
 #'   Alternatively, you can specify numeric column indices or column names to
-#'   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')}.
+#'   indicate which columns to escape, e.g. `1:5` (the first 5 columns),
+#'   `c(1, 3, 4)`, or `c(-1, -3)` (all columns except the first and
+#'   third), or `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
+#'   call to [dataTableOutput()] when `renderDataTable` is used
 #'   in an interactive R Markdown document.
 #'
-#' @references \url{http://datatables.net}
+#' @references <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
+#'   separate package \pkg{DT} (<https://github.com/rstudio/DT>) that allows
 #'   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).
+#'   additional DataTables features. Consider using `DT::renderDataTable()`
+#'   and `DT::dataTableOutput()` (see
+#'   <http://rstudio.github.io/DT/shiny.html> for more information).
 #' @export
 #' @inheritParams renderPlot
 #' @examples
@@ -486,31 +630,46 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     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 <- 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
+    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
+        )
+      }
     )
   }
 
-  markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+  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
@@ -555,13 +714,19 @@ checkDT9 <- function(options) {
 
 # Deprecated functions ------------------------------------------------------
 
+#' Deprecated reactive functions
+#' @name deprecatedReactives
+#' @keywords internal
+NULL
+
 #' Plot output (deprecated)
 #'
-#' See \code{\link{renderPlot}}.
+#' `reactivePlot` has been replaced by [renderPlot()].
 #' @param func A function.
 #' @param width Width.
 #' @param height Height.
 #' @param ... Other arguments to pass on.
+#' @rdname deprecatedReactives
 #' @export
 reactivePlot <- function(func, width='auto', height='auto', ...) {
   shinyDeprecated(new="renderPlot")
@@ -570,9 +735,8 @@ reactivePlot <- function(func, width='auto', height='auto', ...) {
 
 #' Table output (deprecated)
 #'
-#' See \code{\link{renderTable}}.
-#' @param func A function.
-#' @param ... Other arguments to pass on.
+#' `reactiveTable` has been replaced by [renderTable()].
+#' @rdname deprecatedReactives
 #' @export
 reactiveTable <- function(func, ...) {
   shinyDeprecated(new="renderTable")
@@ -581,8 +745,8 @@ reactiveTable <- function(func, ...) {
 
 #' Print output (deprecated)
 #'
-#' See \code{\link{renderPrint}}.
-#' @param func A function.
+#' `reactivePrint` has been replaced by [renderPrint()].
+#' @rdname deprecatedReactives
 #' @export
 reactivePrint <- function(func) {
   shinyDeprecated(new="renderPrint")
@@ -591,8 +755,8 @@ reactivePrint <- function(func) {
 
 #' UI output (deprecated)
 #'
-#' See \code{\link{renderUI}}.
-#' @param func A function.
+#' `reactiveUI` has been replaced by [renderUI()].
+#' @rdname deprecatedReactives
 #' @export
 reactiveUI <- function(func) {
   shinyDeprecated(new="renderUI")
@@ -601,8 +765,8 @@ reactiveUI <- function(func) {
 
 #' Text output (deprecated)
 #'
-#' See \code{\link{renderText}}.
-#' @param func A function.
+#' `reactiveText` has been replaced by [renderText()].
+#' @rdname deprecatedReactives
 #' @export
 reactiveText <- function(func) {
   shinyDeprecated(new="renderText")

R/showcase.R

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

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/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 `runApp()` with `test.mode=TRUE`, or by setting the
+#' global option `shiny.testmode` to `TRUE`.
+#'
+#' @param quoted_ Are the expression quoted? Default is `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/test-server.R

@@ -0,0 +1,137 @@
+# Constructs an rlang::eval_tidy() data mask with semantics appropriate for use
+# in testServer().
+#
+# env is assumed to be session$env, or the environment captured by invoking a
+# module under test.
+#
+# Consider the following module definition and its enclosing environment:
+#
+# x <- 1
+# m <- function(id) {
+#   y <- 2
+#   moduleServer(id, function(input, output, session){
+#     z <- 3
+#   })
+# }
+#
+# The data mask returned by this function should include z, session,
+# output, input, y, and id, but *not* x. Definitions not masked are
+# resolved in the environment in which testServer() is called.
+#
+# env is cloned because rlang::new_data_mask() mutates the parent of its `top`
+# argument.
+#' @importFrom rlang env_clone
+buildMask <- function(env) {
+  if (identical(parent.env(env), emptyenv()))
+    stop("env must have a non-empty parent")
+  clone <- env_clone(env, env_clone(parent.env(env), emptyenv()))
+  rlang::new_data_mask(clone, parent.env(clone))
+}
+
+#' @noRd
+isModuleServer <- function(x) {
+  is.function(x) && names(formals(x))[1] == "id"
+}
+
+#' Reactive testing for Shiny server functions and modules
+#'
+#' A way to test the reactive interactions in Shiny applications. Reactive
+#' interactions are defined in the server function of applications and in
+#' modules.
+#' @param app The path to an application or module to test. In addition to
+#'   paths, applications may be represented by any object suitable for coercion
+#'   to an `appObj` by `as.shiny.appobj`. Application server functions must
+#'   include a `session` argument in order to be tested.
+#' @param expr Test code containing expectations. The test expression will run
+#'   in the server function environment, meaning that the parameters of the
+#'   server function (e.g. `input`, `output`, and `session`) will be available
+#'   along with any other values created inside of the server function.
+#' @param ... Additional arguments to pass to the module function. These
+#'   arguments are processed with [rlang::list2()] and so are
+#'   _[dynamic][rlang::dyn-dots]_. If `app` is a module, and no `id` argument is
+#'   provided, one will be generated and supplied automatically.
+#' @return The result of evaluating `expr`.
+#' @include mock-session.R
+#' @rdname testServer
+#' @examples
+#' server <- function(id, multiplier = 2, prefix = "I am ") {
+#'   moduleServer(id, function(input, output, session) {
+#'     myreactive <- reactive({
+#'       input$x * multiplier
+#'     })
+#'     output$txt <- renderText({
+#'       paste0(prefix, myreactive())
+#'     })
+#'   })
+#' }
+#'
+#' testServer(server, {
+#'   session$setInputs(x = 1)
+#'   # You're also free to use third-party
+#'   # testing packages like testthat:
+#'   #   expect_equal(myreactive(), 2)
+#'   stopifnot(myreactive() == 2)
+#'   stopifnot(output$txt == "I am 2")
+#'
+#'   session$setInputs(x = 2)
+#'   stopifnot(myreactive() == 4)
+#'   stopifnot(output$txt == "I am 4")
+#'   # Any additional arguments, below, are passed along to the module.
+#' }, multiplier = 2)
+#' @export
+testServer <- function(app, expr, ...) {
+
+  args <- rlang::list2(...)
+
+  session <- getDefaultReactiveDomain()
+
+  if (inherits(session, "MockShinySession"))
+    stop("Test expressions may not call testServer()")
+  if (inherits(session, "session_proxy")
+      && inherits(get("parent", envir = session), "MockShinySession"))
+    stop("Modules may not call testServer()")
+
+  session <- MockShinySession$new()
+  on.exit(if (!session$isClosed()) session$close())
+
+  if (isModuleServer(app)) {
+    if (!("id" %in% names(args)))
+      args[["id"]] <- session$genId()
+  } else {
+    appobj <- as.shiny.appobj(app)
+    server <- appobj$serverFuncSource()
+    if (! "session" %in% names(formals(server)))
+      stop("Tested application server functions must declare input, output, and session arguments.")
+    body(server) <- rlang::expr({
+      session$setEnv(base::environment())
+      !!!body(server)
+    })
+    app <- function() {
+      session$setReturned(server(input = session$input, output = session$output, session = session))
+    }
+    if (length(args))
+      message("Discarding unused arguments to server function")
+  }
+
+  isolate(
+    withReactiveDomain(
+      session,
+      withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+        rlang::exec(app, !!!args)
+      })
+    )
+  )
+
+  stopifnot(all(c("input", "output", "session") %in% ls(session$env)))
+
+  quosure <- rlang::enquo(expr)
+
+  isolate(
+    withReactiveDomain(
+      session,
+      withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+        rlang::eval_tidy(quosure, buildMask(session$env), rlang::caller_env())
+      })
+    )
+  )
+}

R/test.R

@@ -0,0 +1,141 @@
+#' Creates and returns run result data frame.
+#'
+#' @param file Name of the test runner file, a character vector of length 1.
+#' @param pass Whether or not the test passed, a logical vector of length 1.
+#' @param result Value (wrapped in a list) obtained by evaluating `file` or `NA`
+#'   if no value was obtained, such as with `shinytest`.
+#' @param error Error, if any, (and wrapped in a list) that was signaled during
+#'   evaluation of `file`.
+#'
+#' @return A 1-row data frame representing a single test run. `result` and
+#'   `error` are "list columns", or columns that may contain list elements.
+#' @noRd
+result_row <- function(file, pass, result, error) {
+  stopifnot(is.list(result))
+  stopifnot(is.list(error))
+  df <- data.frame(
+    file = file,
+    pass = pass,
+    result = I(result),
+    error = I(error),
+    stringsAsFactors = FALSE
+  )
+  class(df) <- c("shinytestrun", class(df))
+  df
+}
+
+#' Check to see if the given text is a shinytest
+#' Scans for the magic string of `app <- ShinyDriver$new(` as an indicator that this is a shinytest.
+#' Brought in from shinytest to avoid having to export this function.
+#' @noRd
+isShinyTest <- function(text){
+  lines <- grepl("app\\s*<-\\s*ShinyDriver\\$new\\(", text, perl=TRUE)
+  any(lines)
+}
+
+#' Runs the tests associated with this Shiny app
+#'
+#' Sources the `.R` files in the top-level of `tests/` much like `R CMD check`.
+#' These files are typically simple runners for tests nested in other
+#' directories under `tests/`.
+#'
+#' @param appDir The base directory for the application.
+#' @param filter If not `NULL`, only tests with file names matching this regular
+#'   expression will be executed. Matching is performed on the file name
+#'   including the extension.
+#'
+#' @return A data frame classed with the supplemental class `"shinytestrun"`.
+#'   The data frame has the following columns:
+#'
+#' | **Name** | **Type** | **Meaning** |
+#' | :-- | :-- | :-- |
+#' | `file` | `character(1)` | File name of the runner script in `tests/` that was sourced. |
+#' | `pass` | `logical(1)` | Whether or not the runner script signaled an error when sourced. |
+#' | `result` | any or `NA` | The return value of the runner, or `NA` if `pass == FALSE`. |
+#' | `error` | any or `NA` | The error signaled by the runner, or `NA` if `pass == TRUE`. |
+#'
+#' @details Historically, [shinytest](https://rstudio.github.io/shinytest/)
+#'   recommended placing tests at the top-level of the `tests/` directory. In
+#'   order to support that model, `testApp` first checks to see if the `.R`
+#'   files in the `tests/` directory are all shinytests; if so, just calls out
+#'   to [shinytest::testApp()].
+#' @export
+runTests <- function(appDir=".", filter=NULL){
+  require(shiny)
+
+  testsDir <- file.path(appDir, "tests")
+  if (!dirExists(testsDir)){
+    stop("No tests directory found: ", testsDir)
+  }
+  runners <- list.files(testsDir, pattern="\\.r$", ignore.case = TRUE)
+
+  if (length(runners) == 0){
+    message("No test runners found in ", testsDir)
+    return(result_row(character(0), logical(0), list(), list()))
+  }
+
+  if (!is.null(filter)){
+    runners <- runners[grepl(filter, runners)]
+  }
+  if (length(runners) == 0){
+    stop("No test runners matched the given filter: '", filter, "'")
+  }
+
+  # Inspect each runner to see if it appears to be a shinytest
+  isST <- vapply(runners, function(r){
+    text <- readLines(file.path(testsDir, r), warn = FALSE)
+    isShinyTest(text)
+  }, logical(1))
+
+  # See the @details section of the runTests() docs above for why this branch exists.
+  if (all(isST)){
+    # just call out to shinytest
+    # We don't need to message/warn here since shinytest already does it.
+    if (!requireNamespace("shinytest", quietly=TRUE) ){
+      stop("It appears that the .R files in ", testsDir,
+           " are all shinytests, but shinytest is not installed.")
+    }
+
+    if (!getOption("shiny.autoload.r", TRUE)) {
+      warning("You've disabled `shiny.autoload.r` via an option but this is not passed through to shinytest. Consider using a _disable_autoload.R file as described at https://rstd.io/shiny-autoload")
+    }
+
+    return(do.call(rbind, lapply(shinytest::testApp(appDir)[["results"]], function(r) {
+      error <- if (r[["pass"]]) NA else simpleError("Unknown shinytest error")
+      result_row(r[["name"]], r[["pass"]], list(NA), list(error))
+    })))
+  }
+
+  testenv <- new.env(parent=globalenv())
+  renv <- new.env(parent=testenv)
+  if (getOption("shiny.autoload.r", TRUE)) {
+    loadSupport(appDir, renv=renv, globalrenv=testenv)
+  } else if (file.exists.ci(file.path(appDir, "server.R"))){
+    # then check for global.R to load
+    if (file.exists(file.path.ci(appDir, "global.R"))){
+      sourceUTF8(file.path.ci(appDir, "global.R"))
+    }
+  }
+
+  oldwd <- getwd()
+  on.exit({
+    setwd(oldwd)
+  }, add=TRUE)
+
+  setwd(testsDir)
+
+  # Otherwise source all the runners -- each in their own environment.
+  return(do.call(rbind, lapply(runners, function(r) {
+    result <- NA
+    error <- NA
+    pass <- FALSE
+    tryCatch({
+      env <- new.env(parent = renv)
+      result <- sourceUTF8(r, envir = env)
+      pass <- TRUE
+    }, error = function(e) {
+      error <<- e
+    })
+    result_row(r, pass, list(result), list(error))
+  })))
+}

R/timer.R

@@ -1,6 +1,5 @@
-# Return the current time, in milliseconds from epoch, with
-# unspecified time zone.
-now <- function() {
+# Return the current time, in milliseconds from epoch.
+getTimeMs <- function() {
   as.numeric(Sys.time()) * 1000
 }
 
@@ -12,9 +11,11 @@ TimerCallbacks <- R6Class(
     .nextId = 0L,
     .funcs = 'Map',
     .times = data.frame(),
+    .now = 'Function',
 
-    initialize = function() {
+    initialize = function(nowFn = getTimeMs) {
       .funcs <<- Map$new()
+      .now <<- nowFn
     },
     clear = function() {
       .nextId <<- 0L
@@ -30,7 +31,7 @@ TimerCallbacks <- R6Class(
       id <- .nextId
       .nextId <<- .nextId + 1L
 
-      t <- now()
+      t <- .now()
 
       # TODO: Horribly inefficient, use a heap instead
       .times <<- rbind(.times, data.frame(time=t+millis,
@@ -42,20 +43,31 @@ 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)
-      return(.times[1, 'time'] - now())
+      return(.times[1, 'time'] - .now())
     },
     takeElapsed = function() {
-      t <- now()
-      elapsed <- .times$time < now()
+      t <- .now()
+      elapsed <- .times$time <= .now()
       result <- .times[elapsed,]
       .times <<- .times[!elapsed,]
 
       # TODO: Examine scheduled column to check if any funny business
       #       has occurred with the system clock (e.g. if scheduled
-      #       is later than now())
+      #       is later than .now())
 
       return(result)
     },
@@ -75,17 +87,61 @@ TimerCallbacks <- R6Class(
   )
 )
 
+MockableTimerCallbacks <- R6Class(
+  'MockableTimerCallbacks',
+  inherit = TimerCallbacks,
+  portable = FALSE,
+  class = FALSE,
+  public = list(
+    # Empty constructor defaults to the getNow implementation
+    initialize = function() {
+      super$initialize(self$mockNow)
+    },
+    mockNow = function() {
+      return(private$time)
+    },
+    elapse = function(millis) {
+      private$time <- private$time + millis
+    },
+    getElapsed = function() {
+      private$time
+    }
+  ), private = list(
+    time = 0L
+  )
+)
+
 timerCallbacks <- TimerCallbacks$new()
 
 scheduleTask <- function(millis, callback) {
   cancelled <- FALSE
-  timerCallbacks$schedule(millis, function() {
-    if (!cancelled)
-      callback()
-  })
+  id <- timerCallbacks$schedule(millis, callback)
 
   function() {
-    cancelled <<- TRUE
-    callback <<- NULL # to allow for callback to be gc'ed
+    invisible(timerCallbacks$unschedule(id))
+  }
+}
+
+#' Get a scheduler function for scheduling tasks. Give priority to the
+#' session scheduler, but if it doesn't exist, use the global one.
+#' @noRd
+defineScheduler <- function(session){
+  if (!is.null(session) && !is.null(session$.scheduleTask)){
+    return(session$.scheduleTask)
+  }
+  scheduleTask
+}
+
+
+#' Get the current time using the current reactive domain. This will try to use
+#' the session's .now() method, but if that's not available, it will just return
+#' the real time (from getTimeMs()). The purpose of this function is to allow
+#' MockableTimerCallbacks to work.
+#' @noRd
+getDomainTimeMs <- function(session){
+  if (!is.null(session) && !is.null(session$.now)){
+    return(session$.now())
+  } else {
+    getTimeMs()
   }
 }

R/update-input.R

@@ -2,8 +2,9 @@
 #'
 #' @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}}
+#' @seealso [textInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -34,17 +35,17 @@
 #' 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
-#' @param value The value to set for the input object.
+#' @inheritParams updateTextInput
 #'
-#' @seealso \code{\link{textAreaInput}}
+#' @seealso [textAreaInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -83,7 +84,7 @@ updateTextAreaInput <- updateTextInput
 #' @template update-input
 #' @param value The value to set for the input object.
 #'
-#' @seealso \code{\link{checkboxInput}}
+#' @seealso [checkboxInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -106,16 +107,19 @@ updateTextAreaInput <- updateTextInput
 #' 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)}.
+#' current icon, use `icon=character(0)`.
 #'
-#' @seealso \code{\link{actionButton}}
+#' @seealso [actionButton()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -166,34 +170,31 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 #'
 #' @template update-input
 #' @param value The desired date value. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format. Supply \code{NA} to clear the date.
+#'   `yyyy-mm-dd` format. Supply `NA` to clear the date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   `yyyy-mm-dd` format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   `yyyy-mm-dd` format.
 #'
-#' @seealso \code{\link{dateInput}}
+#' @seealso [dateInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
 #'
 #' ui <- fluidPage(
-#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   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
 #'     )
 #'   })
 #' }
@@ -204,18 +205,9 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
                             min = NULL, max = NULL) {
 
-  # Make sure values are NULL or Date objects. This is so we can ensure that
-  # they will be formatted correctly. For example, the string "2016-08-9" is not
-  # correctly formatted, but the conversion to Date and back to string will fix
-  # it.
-  formatDate <- function(x) {
-    if (is.null(x))
-      return(NULL)
-    format(as.Date(x), "%Y-%m-%d")
-  }
-  value <- formatDate(value)
-  min   <- formatDate(min)
-  max   <- formatDate(max)
+  value <- dateYMD(value, "value")
+  min   <- dateYMD(min, "min")
+  max   <- dateYMD(max, "max")
 
   message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
@@ -226,35 +218,35 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #'
 #' @template update-input
 #' @param start The start date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the start date.
+#'   `yyyy-mm-dd` format. Supplying `NA` clears the start date.
 #' @param end The end date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the end date.
+#'   `yyyy-mm-dd` format. Supplying `NA` clears the end date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   `yyyy-mm-dd` format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   `yyyy-mm-dd` format.
 #'
-#' @seealso \code{\link{dateRangeInput}}
+#' @seealso [dateRangeInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
 #'
 #' ui <- fluidPage(
-#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   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
 #'     )
 #'   })
 #' }
@@ -265,12 +257,11 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 updateDateRangeInput <- function(session, inputId, label = NULL,
                                  start = NULL, end = NULL, min = NULL,
                                  max = NULL) {
-  # Make sure start and end are strings, not date objects. This is for
-  # consistency across different locales.
-  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')
+
+  start <- dateYMD(start, "start")
+  end <- dateYMD(end, "end")
+  min <- dateYMD(min, "min")
+  max <- dateYMD(max, "max")
 
   message <- dropNulls(list(
     label = label,
@@ -284,14 +275,14 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 
 #' Change the selected tab on the client
 #'
-#' @param session The \code{session} object passed to function given to
-#'   \code{shinyServer}.
-#' @param inputId The id of the \code{tabsetPanel}, \code{navlistPanel},
-#' or \code{navbarPage} object.
+#' @param session The `session` object passed to function given to
+#'   `shinyServer`.
+#' @param inputId The id of the `tabsetPanel`, `navlistPanel`,
+#' or `navbarPage` object.
 #' @param selected The name of the tab to make active.
 #'
-#' @seealso \code{\link{tabsetPanel}}, \code{\link{navlistPanel}},
-#' \code{\link{navbarPage}}
+#' @seealso [tabsetPanel()], [navlistPanel()],
+#' [navbarPage()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -342,7 +333,7 @@ updateNavlistPanel <- updateTabsetPanel
 #' @param max Maximum value.
 #' @param step Step size.
 #'
-#' @seealso \code{\link{numericInput}}
+#' @seealso [numericInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -382,15 +373,19 @@ 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}}
+#' @seealso [sliderInput()]
 #'
 #' @examples
 #' ## Only run this example in interactive R sessions
@@ -421,22 +416,17 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #' }
 #' @export
 updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
-  min = NULL, max = NULL, step = NULL)
+  min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
 {
-  # Make sure that value, min, max all have the same type, because we need
-  # special handling for dates and datetimes.
-  vals <- dropNulls(list(value, min, max))
+  # If no min/max/value is provided, we won't know the
+  # type, and this will return an empty string
+  dataType <- getSliderType(min, max, value)
 
-  type <- unique(lapply(vals, function(x) {
-    if      (inherits(x, "Date"))   "date"
-    else if (inherits(x, "POSIXt")) "datetime"
-    else                            "number"
-  }))
-  if (length(type) > 1) {
-    stop("Type mismatch for value, min, and max")
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if ((length(type) == 1) && (type == "date" || type == "datetime")) {
+  if (isTRUE(dataType %in% c("date", "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)
@@ -448,23 +438,28 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
     value = formatNoSci(value),
     min = formatNoSci(min),
     max = formatNoSci(max),
-    step = formatNoSci(step)
+    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') {
-  if (!is.null(choices))
-    choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, session$ns(inputId))
+                               selected = NULL, inline = FALSE, type = NULL,
+                               choiceNames = NULL, choiceValues = NULL) {
+  if (is.null(type)) stop("Please specify the type ('checkbox' or 'radio')")
 
-  options <- if (!is.null(choices)) {
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues, mustExist = FALSE)
+
+  if (!is.null(selected)) selected <- as.character(selected)
+
+  options <- if (!is.null(args$choiceValues)) {
     format(tagList(
-      generateOptions(session$ns(inputId), choices, selected, inline, type = type)
+      generateOptions(session$ns(inputId), selected, inline, type,
+        args$choiceNames, args$choiceValues)
     ))
   }
 
@@ -478,7 +473,7 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' @template update-input
 #' @inheritParams checkboxGroupInput
 #'
-#' @seealso \code{\link{checkboxGroupInput}}
+#' @seealso [checkboxGroupInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -513,9 +508,10 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' }
 #' @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)
 }
 
 
@@ -524,7 +520,7 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' @template update-input
 #' @inheritParams radioButtons
 #'
-#' @seealso \code{\link{radioButtons}}
+#' @seealso [radioButtons()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -555,13 +551,15 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' }
 #' @export
 updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
-                               selected = NULL, inline = FALSE) {
-  if (!is.null(choices)) choices <- as.character(choices)
-  if (!is.null(selected)) selected <- as.character(selected)
-
+                               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)
 }
 
 
@@ -570,7 +568,7 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @template update-input
 #' @inheritParams selectInput
 #'
-#' @seealso \code{\link{selectInput}}
+#' @seealso [selectInput()] [varSelectInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -607,8 +605,7 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
                               selected = NULL) {
   choices <- if (!is.null(choices)) choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+  if (!is.null(selected)) selected <- as.character(selected)
   options <- if (!is.null(choices)) selectOptions(choices, selected)
   message <- dropNulls(list(label = label, options = options, value = selected))
   session$sendInputMessage(inputId, message)
@@ -616,9 +613,9 @@ updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
 
 #' @rdname updateSelectInput
 #' @inheritParams selectizeInput
-#' @param server whether to store \code{choices} on the server side, and load
+#' @param server whether to store `choices` on the server side, and load
 #'   the select options dynamically on searching, instead of writing all
-#'   \code{choices} into the page at once (i.e., only use the client-side
+#'   `choices` into the page at once (i.e., only use the client-side
 #'   version of \pkg{selectize.js})
 #' @export
 updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
@@ -628,7 +625,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))
     )
@@ -637,8 +634,95 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   if (!server) {
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
+
+  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)
   attr(choices, 'selected_value') <- value
+
   message <- dropNulls(list(
     label = label,
     value = value,
@@ -646,38 +730,76 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   ))
   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 <- c(jsonlite::fromJSON(query$field))
-  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 <- as.numeric(query$maxop)
   vfd <- query$value  # the value field name
   sel <- attr(data, 'selected_value', exact = TRUE)
 
-  # convert a single vector to a data frame so it returns {label: , value: }
-  # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
-  data <- if (is.atomic(data)) {
-    data.frame(label = names(choicesWithNames(data)), value = data,
-               stringsAsFactors = FALSE)
-  } else as.data.frame(data, stringsAsFactors = FALSE)
-
   # 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 <- utils::head(if (length(key)) which(idx) else seq_along(idx), mop)

R/utils.R

@@ -14,7 +14,7 @@ NULL
 #'
 #' @note When called, the returned function attempts to preserve the R session's
 #'   current seed by snapshotting and restoring
-#'   \code{\link[base]{.Random.seed}}.
+#'   [base::.Random.seed()].
 #'
 #' @examples
 #' rnormA <- repeatable(rnorm)
@@ -43,53 +43,43 @@ repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max))
   }
 }
 
-# Temporarily set x in env to value, evaluate expr, and
-# then restore x to its original state
-withTemporary <- function(env, x, value, expr, unset = FALSE) {
-
-  if (exists(x, envir = env, inherits = FALSE)) {
-    oldValue <- get(x, envir = env, inherits = FALSE)
-    on.exit(
-      assign(x, oldValue, envir = env, inherits = FALSE),
-      add = TRUE)
-  } else {
-    on.exit(
-      rm(list = x, envir = env, inherits = FALSE),
-      add = TRUE
-    )
-  }
-
-  if (!missing(value) && !isTRUE(unset))
-    assign(x, value, envir = env, inherits = FALSE)
-  else {
-    if (exists(x, envir = env, inherits = FALSE))
-      rm(list = x, envir = env, inherits = FALSE)
-  }
-  force(expr)
-}
-
 .globals$ownSeed <- NULL
 # Evaluate an expression using Shiny's own private stream of
 # randomness (not affected by set.seed).
 withPrivateSeed <- function(expr) {
-  withTemporary(.GlobalEnv, ".Random.seed",
-    .globals$ownSeed, unset=is.null(.globals$ownSeed), {
-      tryCatch({
-        expr
-      }, finally = {
-        .globals$ownSeed <- getExists('.Random.seed', 'numeric', globalenv())
-      })
-    }
-  )
-}
+  # Save the old seed if present.
+  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
+    hasOrigSeed <- TRUE
+    origSeed <- .GlobalEnv$.Random.seed
+  } else {
+    hasOrigSeed <- FALSE
+  }
 
-# a homemade version of set.seed(NULL) for backward compatibility with R 2.15.x
-reinitializeSeed <- if (getRversion() >= '3.0.0') {
-  function() set.seed(NULL)
-} else function() {
-  if (exists('.Random.seed', globalenv()))
-    rm(list = '.Random.seed', pos = globalenv())
-  stats::runif(1)  # generate any random numbers so R can reinitialize the seed
+  # Swap in the private seed.
+  if (is.null(.globals$ownSeed)) {
+    if (hasOrigSeed) {
+      # Move old seed out of the way if present.
+      rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
+    }
+  } else {
+    .GlobalEnv$.Random.seed <- .globals$ownSeed
+  }
+
+  # On exit, save the modified private seed, and put the old seed back.
+  on.exit({
+    .globals$ownSeed <- .GlobalEnv$.Random.seed
+
+    if (hasOrigSeed) {
+      .GlobalEnv$.Random.seed <- origSeed
+    } else {
+      rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
+    }
+    # Need to call this to make sure that the value of .Random.seed gets put
+    # into R's internal RNG state. (Issue #1763)
+    httpuv::getRNGState()
+  })
+
+  expr
 }
 
 # Version of runif that runs with private seed
@@ -131,8 +121,8 @@ isWholeNum <- function(x, tol = .Machine$double.eps^0.5) {
 }
 
 `%AND%` <- function(x, y) {
-  if (!is.null(x) && !is.na(x))
-    if (!is.null(y) && !is.na(y))
+  if (!is.null(x) && !isTRUE(is.na(x)))
+    if (!is.null(y) && !isTRUE(is.na(y)))
       return(y)
   return(NULL)
 }
@@ -182,6 +172,16 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
+
+# Given a vector/list, returns a named vector/list (the labels will be blank).
+asNamed <- function(x) {
+  if (is.null(names(x))) {
+    names(x) <- character(length(x))
+  }
+
+  x
+}
+
 # Given two named vectors, join them together, and keep only the last element
 # with a given name in the resulting vector. If b has any elements with the same
 # name as elements in a, the element in a is dropped. Also, if there are any
@@ -196,6 +196,30 @@ mergeVectors <- function(a, b) {
   x[!drop_idx]
 }
 
+# Sort a vector by the names of items. If there are multiple items with the
+# same name, preserve the original order of those items. For empty
+# vectors/lists/NULL, return the original value.
+sortByName <- function(x) {
+  if (anyUnnamed(x))
+    stop("All items must be named")
+
+  # Special case for empty vectors/lists, and NULL
+  if (length(x) == 0)
+    return(x)
+
+  x[order(names(x))]
+}
+
+# Wrapper around list2env with a NULL check. In R <3.2.0, if an empty unnamed
+# list is passed to list2env(), it errors. But an empty named list is OK. For
+# R >=3.2.0, this wrapper is not necessary.
+list2env2 <- function(x, ...) {
+  # Ensure that zero-length lists have a name attribute
+  if (length(x) == 0)
+    attr(x, "names") <- character(0)
+
+  list2env(x, ...)
+}
 
 # Combine dir and (file)name into a file path. If a file already exists with a
 # name differing only by case, then use it instead.
@@ -245,6 +269,25 @@ dirExists <- function(paths) {
   file.exists(paths) & file.info(paths)$isdir
 }
 
+# Removes empty directory (vectorized). This is needed because file.remove()
+# on Unix will remove empty directories, but on Windows, it will not. On
+# Windows, you would need to use unlink(recursive=TRUE), which is not very
+# safe. This function does it safely on Unix and Windows.
+dirRemove <- function(path) {
+  for (p in path) {
+    if (!dirExists(p)) {
+      stop("Cannot remove non-existent directory ", p, ".")
+    }
+    if (length(dir(p, all.files = TRUE, no.. = TRUE)) != 0) {
+      stop("Cannot remove non-empty directory ", p, ".")
+    }
+    result <- unlink(p, recursive = TRUE)
+    if (result == 1) {
+      stop("Error removing directory ", p, ".")
+    }
+  }
+}
+
 # Attempt to join a path and relative path, and turn the result into a
 # (normalized) absolute path. The result will only be returned if it is an
 # existing file/directory and is a descendant of dir.
@@ -425,12 +468,12 @@ exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
 #' Installs an expression in the given environment as a function, and registers
 #' debug hooks so that breakpoints may be set in the function.
 #'
-#' This function can replace \code{exprToFunction} as follows: we may use
-#' \code{func <- exprToFunction(expr)} if we do not want the debug hooks, or
-#' \code{installExprFunction(expr, "func")} if we do. Both approaches create a
-#' function named \code{func} in the current environment.
+#' This function can replace `exprToFunction` as follows: we may use
+#' `func <- exprToFunction(expr)` if we do not want the debug hooks, or
+#' `installExprFunction(expr, "func")` if we do. Both approaches create a
+#' function named `func` in the current environment.
 #'
-#' @seealso Wraps \code{\link{exprToFunction}}; see that method's documentation
+#' @seealso Wraps [exprToFunction()]; see that method's documentation
 #'   for more documentation and examples.
 #'
 #' @param expr A quoted or unquoted expression
@@ -442,7 +485,7 @@ exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
 #' @param label A label for the object to be shown in the debugger. Defaults to
 #'   the name of the calling function.
 #' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
-#'   \code{\link{stacktrace}}.
+#'   [stacktrace()].
 #' @export
 installExprFunction <- function(expr, name, eval.env = parent.frame(2),
                                 quoted = FALSE,
@@ -473,6 +516,7 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
 #'
 #' Returns a named list of key-value pairs.
 #'
+#' @noMd
 #' @param str The query string. It can have a leading \code{"?"} or not.
 #' @param nested Whether to parse the query string of as a nested list when it
 #'   contains pairs of square brackets \code{[]}. For example, the query
@@ -570,7 +614,7 @@ shinyCallingHandlers <- function(expr) {
 
 #' Print message for deprecated functions in Shiny
 #'
-#' To disable these messages, use \code{options(shiny.deprecation.messages=FALSE)}.
+#' To disable these messages, use `options(shiny.deprecation.messages=FALSE)`.
 #'
 #' @param new Name of replacement function.
 #' @param msg Message to print. If used, this will override the default message.
@@ -638,6 +682,9 @@ Callbacks <- R6Class(
       .callbacks <<- Map$new()
     },
     register = function(callback) {
+      if (!is.function(callback)) {
+        stop("callback must be a function")
+      }
       id <- as.character(.nextId)
       .nextId <<- .nextId - 1L
       .callbacks$set(id, callback)
@@ -753,7 +800,14 @@ dataTablesJSON <- function(data, req) {
 
   fdata <- unname(as.matrix(fdata))
   if (is.character(fdata) && q$escape != 'false') {
-    if (q$escape == 'true') fdata <- htmlEscape(fdata) else {
+    if (q$escape == 'true') {
+      # fdata must be a matrix at this point, and we need to preserve
+      # dimensions. Note that it could be a 1xn matrix.
+      dims <- dim(fdata)
+      fdata <- htmlEscape(fdata)
+      dim(fdata) <- dims
+
+    } else {
       k <- as.integer(strsplit(q$escape, ',')[[1]])
       # use seq_len() in case escape = negative indices, e.g. c(-1, -5)
       for (j in seq_len(ncol(fdata))[k]) fdata[, j] <- htmlEscape(fdata[, j])
@@ -903,28 +957,28 @@ columnToRowData <- function(data) {
 #'
 #' This should be used when you want to let the user see an error
 #' message even if the default is to sanitize all errors. If you have an
-#' error \code{e} and call \code{stop(safeError(e))}, then Shiny will
-#' ignore the value of \code{getOption("shiny.sanitize.errors")} and always
+#' error `e` and call `stop(safeError(e))`, then Shiny will
+#' ignore the value of `getOption("shiny.sanitize.errors")` and always
 #' display the error in the app itself.
 #'
 #' @param error Either an "error" object or a "character" object (string).
 #' In the latter case, the string will become the message of the error
-#' returned by \code{safeError}.
+#' returned by `safeError`.
 #'
 #' @return An "error" object
 #'
-#' @details An error generated by \code{safeError} has priority over all
+#' @details An error generated by `safeError` has priority over all
 #' other Shiny errors. This can be dangerous. For example, if you have set
-#' \code{options(shiny.sanitize.errors = TRUE)}, then by default all error
+#' `options(shiny.sanitize.errors = TRUE)`, then by default all error
 #' messages are omitted in the app, and replaced by a generic error message.
-#' However, this does not apply to \code{safeError}: whatever you pass
-#' through \code{error} will be displayed to the user. So, this should only
+#' However, this does not apply to `safeError`: whatever you pass
+#' through `error` will be displayed to the user. So, this should only
 #' be used when you are sure that your error message does not contain any
-#' sensitive information. In those situations, \code{safeError} can make
+#' sensitive information. In those situations, `safeError` can make
 #' your users' lives much easier by giving them a hint as to where the
 #' error occurred.
 #'
-#' @seealso \code{\link{shiny-options}}
+#' @seealso [shiny-options()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -1004,7 +1058,7 @@ safeError <- function(error) {
 # #' @examples
 # #' ## Note: the breaking of the reactive chain that happens in the app
 # #' ## below (when input$txt = 'bad' and input$allowBad = 'FALSE') is
-# #' ## easily visualized with `showReactLog()`
+# #' ## easily visualized with `reactlogShow()`
 # #'
 # #' ## Only run examples in interactive R sessions
 # #' if (interactive()) {
@@ -1038,62 +1092,63 @@ reactiveStop <- function(message = "", class = NULL) {
 
 #' Validate input values and other conditions
 #'
-#' For an output rendering function (e.g. \code{\link{renderPlot}()}), you may
+#' For an output rendering function (e.g. [renderPlot()]), you may
 #' need to check that certain input values are available and valid before you
-#' can render the output. \code{validate} gives you a convenient mechanism for
+#' can render the output. `validate` gives you a convenient mechanism for
 #' doing so.
 #'
-#' The \code{validate} function takes any number of (unnamed) arguments, each of
+#' The `validate` function takes any number of (unnamed) arguments, each of
 #' which represents a condition to test. If any of the conditions represent
 #' failure, then a special type of error is signaled which stops execution. If
 #' this error is not handled by application-specific code, it is displayed to
 #' the user by Shiny.
 #'
-#' An easy way to provide arguments to \code{validate} is to use the \code{need}
+#' An easy way to provide arguments to `validate` is to use the `need`
 #' function, which takes an expression and a string; if the expression is
 #' considered a failure, then the string will be used as the error message. The
-#' \code{need} function considers its expression to be a failure if it is any of
+#' `need` function considers its expression to be a failure if it is any of
 #' the following:
 #'
 #' \itemize{
-#'   \item{\code{FALSE}}
-#'   \item{\code{NULL}}
-#'   \item{\code{""}}
+#'   \item{`FALSE`}
+#'   \item{`NULL`}
+#'   \item{`""`}
 #'   \item{An empty atomic vector}
 #'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all \code{FALSE} or missing values}
-#'   \item{An object of class \code{"try-error"}}
-#'   \item{A value that represents an unclicked \code{\link{actionButton}}}
+#'   \item{A logical vector that contains all `FALSE` or missing values}
+#'   \item{An object of class `"try-error"`}
+#'   \item{A value that represents an unclicked [actionButton()]}
 #' }
 #'
 #' If any of these values happen to be valid, you can explicitly turn them to
-#' logical values. For example, if you allow \code{NA} but not \code{NULL}, you
-#' can use the condition \code{!is.null(input$foo)}, because \code{!is.null(NA)
-#' == TRUE}.
+#' logical values. For example, if you allow `NA` but not `NULL`, you
+#' can use the condition `!is.null(input$foo)`, because `!is.null(NA)
+#' == TRUE`.
 #'
-#' If you need validation logic that differs significantly from \code{need}, you
+#' If you need validation logic that differs significantly from `need`, you
 #' can create other validation test functions. A passing test should return
-#' \code{NULL}. A failing test should return an error message as a
+#' `NULL`. A failing test should return an error message as a
 #' single-element character vector, or if the failure should happen silently,
-#' \code{FALSE}.
+#' `FALSE`.
 #'
 #' Because validation failure is signaled as an error, you can use
-#' \code{validate} in reactive expressions, and validation failures will
+#' `validate` in reactive expressions, and validation failures will
 #' automatically propagate to outputs that use the reactive expression. In
-#' other words, if reactive expression \code{a} needs \code{input$x}, and two
-#' outputs use \code{a} (and thus depend indirectly on \code{input$x}), it's
-#' not necessary for the outputs to validate \code{input$x} explicitly, as long
-#' as \code{a} does validate it.
+#' other words, if reactive expression `a` needs `input$x`, and two
+#' outputs use `a` (and thus depend indirectly on `input$x`), it's
+#' not necessary for the outputs to validate `input$x` explicitly, as long
+#' as `a` does validate it.
 #'
-#' @param ... A list of tests. Each test should equal \code{NULL} for success,
-#'   \code{FALSE} for silent failure, or a string for failure with an error
+#' @param ... A list of tests. Each test should equal `NULL` for success,
+#'   `FALSE` for silent failure, or a string for failure with an error
 #'   message.
 #' @param errorClass A CSS class to apply. The actual CSS string will have
-#'   \code{shiny-output-error-} prepended to this value.
+#'   `shiny-output-error-` prepended to this value.
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
@@ -1140,10 +1195,10 @@ validate <- function(..., errorClass = character(0)) {
 #' @param expr An expression to test. The condition will pass if the expression
 #'   meets the conditions spelled out in Details.
 #' @param message A message to convey to the user if the validation condition is
-#'   not met. If no message is provided, one will be created using \code{label}.
-#'   To fail with no message, use \code{FALSE} for the message.
+#'   not met. If no message is provided, one will be created using `label`.
+#'   To fail with no message, use `FALSE` for the message.
 #' @param label A human-readable name for the field that may be missing. This
-#'   parameter is not needed if \code{message} is provided, but must be provided
+#'   parameter is not needed if `message` is provided, but must be provided
 #'   otherwise.
 #' @export
 #' @rdname validate
@@ -1164,7 +1219,7 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' operation is stopped by raising a "silent" exception (not logged by Shiny,
 #' nor displayed in the Shiny app's UI).
 #'
-#' The \code{req} function was designed to be used in one of two ways. The first
+#' The `req` function was designed to be used in one of two ways. The first
 #' is to call it like a statement (ignoring its return value) before attempting
 #' operations using the required values:
 #'
@@ -1174,9 +1229,9 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #'   # Code that uses input$a, input$b, and/or rv$state...
 #' })}
 #'
-#' In this example, if \code{r()} is called and any of \code{input$a},
-#' \code{input$b}, and \code{rv$state} are \code{NULL}, \code{FALSE}, \code{""},
-#' etc., then the \code{req} call will trigger an error that propagates all the
+#' In this example, if `r()` is called and any of `input$a`,
+#' `input$b`, and `rv$state` are `NULL`, `FALSE`, `""`,
+#' etc., then the `req` call will trigger an error that propagates all the
 #' way up to whatever render block or observer is executing.
 #'
 #' The second is to use it to wrap an expression that must be truthy:
@@ -1189,70 +1244,70 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #'   }
 #' })}
 #'
-#' In this example, \code{req(input$plotType)} first checks that
-#' \code{input$plotType} is truthy, and if so, returns it. This is a convenient
+#' In this example, `req(input$plotType)` first checks that
+#' `input$plotType` is truthy, and if so, returns it. This is a convenient
 #' way to check for a value "inline" with its first use.
 #'
-#' \strong{Truthy and falsy values}
+#' **Truthy and falsy values**
 #'
 #' The terms "truthy" and "falsy" generally indicate whether a value, when
-#' coerced to a \code{\link{logical}}, is \code{TRUE} or \code{FALSE}. We use
+#' coerced to a [base::logical()], is `TRUE` or `FALSE`. We use
 #' the term a little loosely here; our usage tries to match the intuitive
 #' notions of "Is this value missing or available?", or "Has the user provided
 #' an answer?", or in the case of action buttons, "Has the button been
 #' clicked?".
 #'
-#' For example, a \code{textInput} that has not been filled out by the user has
-#' a value of \code{""}, so that is considered a falsy value.
+#' For example, a `textInput` that has not been filled out by the user has
+#' a value of `""`, so that is considered a falsy value.
 #'
-#' To be precise, \code{req} considers a value truthy \emph{unless} it is one
+#' To be precise, `req` considers a value truthy *unless* it is one
 #' of:
 #'
 #' \itemize{
-#'   \item{\code{FALSE}}
-#'   \item{\code{NULL}}
-#'   \item{\code{""}}
+#'   \item{`FALSE`}
+#'   \item{`NULL`}
+#'   \item{`""`}
 #'   \item{An empty atomic vector}
 #'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all \code{FALSE} or missing values}
-#'   \item{An object of class \code{"try-error"}}
-#'   \item{A value that represents an unclicked \code{\link{actionButton}}}
+#'   \item{A logical vector that contains all `FALSE` or missing values}
+#'   \item{An object of class `"try-error"`}
+#'   \item{A value that represents an unclicked [actionButton()]}
 #' }
 #'
-#' Note in particular that the value \code{0} is considered truthy, even though
-#' \code{as.logical(0)} is \code{FALSE}.
+#' Note in particular that the value `0` is considered truthy, even though
+#' `as.logical(0)` is `FALSE`.
 #'
 #' If the built-in rules for truthiness do not match your requirements, you can
-#' always work around them. Since \code{FALSE} is falsy, you can simply provide
-#' the results of your own checks to \code{req}:
+#' always work around them. Since `FALSE` is falsy, you can simply provide
+#' the results of your own checks to `req`:
 #'
-#' \code{req(input$a != 0)}
+#' `req(input$a != 0)`
 #'
-#' \strong{Using \code{req(FALSE)}}
+#' **Using `req(FALSE)`**
 #'
-#' You can use \code{req(FALSE)} (i.e. no condition) if you've already performed
+#' You can use `req(FALSE)` (i.e. no condition) if you've already performed
 #' all the checks you needed to by that point and just want to stop the reactive
 #' chain now. There is no advantange to this, except perhaps ease of readibility
 #' if you have a complicated condition to check for (or perhaps if you'd like to
-#' divide your condition into nested \code{if} statements).
+#' divide your condition into nested `if` statements).
 #'
-#' \strong{Using \code{cancelOutput = TRUE}}
+#' **Using `cancelOutput = TRUE`**
 #'
-#' When \code{req(..., cancelOutput = TRUE)} is used, the "silent" exception is
+#' When `req(..., cancelOutput = TRUE)` is used, the "silent" exception is
 #' also raised, but it is treated slightly differently if one or more outputs are
 #' currently being evaluated. In those cases, the reactive chain does not proceed
 #' or update, but the output(s) are left is whatever state they happen to be in
 #' (whatever was their last valid state).
 #'
 #' Note that this is always going to be the case if
-#' this is used inside an output context (e.g. \code{output$txt <- ...}). It may
+#' this is used inside an output context (e.g. `output$txt <- ...`). It may
 #' or may not be the case if it is used inside a non-output context (e.g.
-#' \code{\link{reactive}}, \code{\link{observe}} or \code{\link{observeEvent}})
-#' -- depending on whether or not there is an \code{output$...} that is triggered
+#' [reactive()], [observe()] or [observeEvent()])
+#' --- depending on whether or not there is an `output$...` that is triggered
 #' as a result of those calls. See the examples below for concrete scenarios.
 #'
 #' @param ... Values to check for truthiness.
-#' @param cancelOutput If \code{TRUE} and an output is being evaluated, stop
+#' @param cancelOutput If `TRUE` and an output is being evaluated, stop
 #'   processing as usual but instead of clearing the output, leave it in
 #'   whatever state it happens to be in.
 #' @param x An expression whose truthiness value we want to determine
@@ -1391,7 +1446,7 @@ stopWithCondition <- function(class, message) {
 #' This function returns the information about the current Shiny Server, such as
 #' its version, and whether it is the open source edition or professional
 #' edition. If the app is not served through the Shiny Server, this function
-#' just returns \code{list(shinyServer = FALSE)}.
+#' just returns `list(shinyServer = FALSE)`.
 #'
 #' This function will only return meaningful data when using Shiny Server
 #' version 1.2.2 or later.
@@ -1504,12 +1559,34 @@ writeUTF8 <- function(text, ...) {
   writeLines(text, ..., useBytes = TRUE)
 }
 
-URLdecode <- decodeURIComponent
+URLdecode <- function(value) {
+  decodeURIComponent(value)
+}
+
 URLencode <- function(value, reserved = FALSE) {
   value <- enc2utf8(value)
   if (reserved) encodeURIComponent(value) else encodeURI(value)
 }
 
+# Make user-supplied dates are either NULL or can be coerced
+# to a yyyy-mm-dd formatted string. If a date is specified, this
+# function returns a string for consistency across locales.
+# Also, `as.Date()` is used to coerce strings to date objects
+# so that strings like "2016-08-9" are expanded to "2016-08-09"
+dateYMD <- function(date = NULL, argName = "value") {
+  if (!length(date)) return(NULL)
+  if (length(date) > 1) warning("Expected `", argName, "` to be of length 1.")
+  tryCatch(date <- format(as.Date(date), "%Y-%m-%d"),
+    error = function(e) {
+      warning(
+        "Couldn't coerce the `", argName,
+        "` argument to a date string with format yyyy-mm-dd",
+        call. = FALSE
+      )
+    }
+  )
+  date
+}
 
 # This function takes a name and function, and it wraps that function in a new
 # function which calls the original function using the specified name. This can
@@ -1550,3 +1627,188 @@ Mutable <- R6Class("Mutable",
     get = function() { private$value }
   )
 )
+
+# More convenient way of chaining together promises than then/catch/finally,
+# without the performance impact of %...>%.
+promise_chain <- function(promise, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    p <- Reduce(function(memo, func) {
+      promises::then(memo, func)
+    }, list(...), promise)
+
+    if (!is.null(catch)) {
+      p <- promises::catch(p, catch)
+    }
+
+    if (!is.null(finally)) {
+      p <- promises::finally(p, finally)
+    }
+
+    p
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Like promise_chain, but if `expr` returns a non-promise, then `...`, `catch`,
+# and `finally` are all executed synchronously
+hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    runFinally <- TRUE
+    tryCatch(
+      {
+        captureStackTraces({
+          result <- withVisible(force(expr))
+          if (promises::is.promising(result$value)) {
+            # Purposefully NOT including domain (nor replace), as we're already in
+            # the domain at this point
+            p <- promise_chain(setVisible(result), ..., catch = catch, finally = finally)
+            runFinally <- FALSE
+            p
+          } else {
+            result <- Reduce(function(v, func) {
+              if (".visible" %in% names(formals(func))) {
+                withVisible(func(v$value, .visible = v$visible))
+              } else {
+                withVisible(func(v$value))
+              }
+            }, list(...), result)
+
+            setVisible(result)
+          }
+        })
+      },
+      error = function(e) {
+        if (!is.null(catch))
+          catch(e)
+        else
+          stop(e)
+      },
+      finally = if (runFinally && !is.null(finally)) finally()
+    )
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Returns `value` with either `invisible()` applied or not, depending on the
+# value of `visible`.
+#
+# If the `visible` is missing, then `value` should be a list as returned from
+# `withVisible()`, and that visibility will be applied.
+setVisible <- function(value, visible) {
+  if (missing(visible)) {
+    visible <- value$visible
+    value <- value$value
+  }
+
+  if (!visible) {
+    invisible(value)
+  } else {
+    (value)
+  }
+}
+
+createVarPromiseDomain <- function(env, name, value) {
+  force(env)
+  force(name)
+  force(value)
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      orig <- env[[name]]
+      env[[name]] <- value
+      on.exit(env[[name]] <- orig)
+
+      force(expr)
+    }
+  )
+}
+
+getSliderType <- function(min, max, value) {
+  vals <- dropNulls(list(value, min, max))
+  if (length(vals) == 0) return("")
+  type <- unique(lapply(vals, function(x) {
+    if      (inherits(x, "Date"))   "date"
+    else if (inherits(x, "POSIXt")) "datetime"
+    else                            "number"
+  }))
+  if (length(type) > 1) {
+    stop("Type mismatch for `min`, `max`, and `value`. Each must be Date, POSIXt, or number.")
+  }
+  type[[1]]
+}
+
+# Reads the `shiny.sharedSecret` global option, and returns a function that can
+# be used to test header values for a match.
+loadSharedSecret <- function() {
+  normalizeToRaw <- function(value, label = "value") {
+    if (is.null(value)) {
+      raw()
+    } else if (is.character(value)) {
+      charToRaw(paste(value, collapse = "\n"))
+    } else if (is.raw(value)) {
+      value
+    } else {
+      stop("Wrong type for ", label, "; character or raw expected")
+    }
+  }
+
+  sharedSecret <- normalizeToRaw(getOption("shiny.sharedSecret"))
+  if (is.null(sharedSecret)) {
+    function(x) TRUE
+  } else {
+    # We compare the digest of the two values so that their lengths are equalized
+    function(x) {
+      x <- normalizeToRaw(x)
+      # Constant time comparison to avoid timing attacks
+      constantTimeEquals(sharedSecret, x)
+    }
+  }
+}
+
+# Compares two raw vectors of equal length for equality, in constant time
+constantTimeEquals <- function(raw1, raw2) {
+  stopifnot(is.raw(raw1))
+  stopifnot(is.raw(raw2))
+  if (length(raw1) != length(raw2)) {
+    return(FALSE)
+  }
+
+  sum(as.integer(xor(raw1, raw2))) == 0
+}
+
+cat_line <- function(...) {
+  cat(paste(..., "\n", collapse = ""))
+}
+

README.md

@@ -8,15 +8,17 @@ Shiny is a new package from RStudio that makes it incredibly easy to build inter
 
 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/).
+* 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!).
@@ -41,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.
@@ -59,9 +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](https://github.com/rstudio/shiny/blob/master/.github/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:
-
-- COPYING - shiny package license (GPLv3)
-- NOTICE  - Copyright notices for additional included software
+The shiny package as a whole is licensed under the GPLv3. See the [LICENSE](LICENSE) file for more 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

@@ -10,6 +10,14 @@ init:
 install:
   ps: Bootstrap
 
+cache:
+  # Bust library cache every time the description file changes
+  #   as appveyor cache can not be busted manually
+  # This helps get around errors such as "can't update curl because it's already loaded"
+  #  when trying to update the existing cache
+  # PR: https://github.com/rstudio/shiny/pull/2722
+  - C:\RLibrary -> DESCRIPTION
+
 # Adapt as necessary starting from here
 
 build_script:
@@ -40,3 +48,7 @@ artifacts:
 
   - path: '\*_*.zip'
     name: Bits
+
+environment:
+  global:
+    USE_RTOOLS: true

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/rsconnect/localhost/admin/01_hello.dcf

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

inst/examples/01_hello/server.R

@@ -1,21 +0,0 @@
-library(shiny)
-
-# Define server logic required to draw a histogram
-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
-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
-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
-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
-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
-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
-function(input, output) {
-
-  # Compute the formula 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)
-  })
-}