Update tests and language

Conflicts:
	R/input-slider.R

.Rbuildignore

@@ -12,7 +12,7 @@
 ^\.travis\.yml$
 ^staticdocs$
 ^tools$
-^srcjs$
+^srcts$
 ^CONTRIBUTING.md$
 ^cran-comments.md$
 ^.*\.o$
@@ -20,3 +20,4 @@
 ^revdep$
 ^TODO-promises.md$
 ^manualtests$
+^\.github$

.github/CONTRIBUTING.md

@@ -2,13 +2,15 @@ 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](https://rstudioblog.files.wordpress.com/2017/05/rstudio_individual_contributor_agreement.pdf) or [corporate](https://rstudioblog.files.wordpress.com/2017/05/rstudio_corporate_contributor_agreement.pdf) contributor agreement as appropriate. You can send the signed copy to jj@rstudio.com.
+2. Submit a [pull request](https://help.github.com/articles/using-pull-requests).
 
-3. 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:

.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.
+

.github/workflows/R-CMD-check.yaml

@@ -0,0 +1,142 @@
+name: R-CMD-check
+on:
+  push:
+    branches:
+      - master
+  pull_request:
+    branches:
+      - master
+
+
+jobs:
+
+  R-CMD-check:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: macOS-latest,   r: 'devel'}
+          - {os: macOS-latest,   r: '4.0'}
+          - {os: windows-latest, r: '4.0'}
+          - {os: ubuntu-16.04,   r: '4.0', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
+          - {os: ubuntu-16.04,   r: '3.6', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
+          - {os: ubuntu-16.04,   r: '3.5', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
+          - {os: ubuntu-16.04,   r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
+          - {os: ubuntu-16.04,   r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
+
+    env:
+      _R_CHECK_FORCE_SUGGESTS_: false
+      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
+      RSPM: ${{ matrix.config.rspm }}
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
+    steps:
+      # https://github.com/actions/checkout/issues/135
+      - name: Set git to use LF
+        if: runner.os == 'Windows'
+        run: |
+          git config --system core.autocrlf false
+          git config --system core.eol lf
+
+      - uses: actions/checkout@v2
+
+      - uses: r-lib/actions/setup-r@master
+        id: install-r
+        with:
+          r-version: ${{ matrix.config.r }}
+
+      - uses: r-lib/actions/setup-pandoc@master
+
+      - name: Install pak and query dependencies
+        shell: Rscript {0}
+        run: |
+          install.packages("pak", repos = "https://r-lib.github.io/p/pak/dev/")
+          saveRDS(pak::pkg_deps_tree("local::.", dependencies = TRUE), ".github/r-depends.rds")
+
+      - name: Cache R packages
+        uses: actions/cache@v2
+        with:
+          path: ${{ env.R_LIBS_USER }}
+          key: ${{ matrix.config.os }}-${{ steps.install-r.outputs.installed-r-version }}-1-${{ hashFiles('.github/r-depends.rds') }}
+          restore-keys: ${{ matrix.config.os }}-${{ steps.install-r.outputs.installed-r-version }}-1-
+
+      - name: Install system dependencies
+        if: runner.os == 'Linux'
+        shell: Rscript {0}
+        run: |
+          pak::local_system_requirements(execute = TRUE)
+
+      # xquartz and cairo are needed for Cairo package.
+      # harfbuzz and fribidi are needed for textshaping package.
+      - name: Mac systemdeps
+        if: runner.os == 'macOS'
+        run: |
+          brew install --cask xquartz
+          brew install cairo
+          brew install harfbuzz fribidi
+
+      # Use a shorter temp directory for pak installations, due to filename
+      # length issues on Windows. https://github.com/r-lib/pak/issues/252
+      - name: Windows temp dir
+        if: runner.os == 'Windows'
+        run: |
+          New-Item -Path "C:\" -Name "tmp" -ItemType Directory
+          echo "TMPDIR=c:\tmp" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append
+
+      - name: Install dependencies
+        run: |
+          pak::local_install_dev_deps(upgrade = TRUE)
+          pak::pkg_install("rcmdcheck")
+        shell: Rscript {0}
+
+      - name: Find PhantomJS path
+        id: phantomjs
+        run: |
+          echo "::set-output name=path::$(Rscript -e 'cat(shinytest:::phantom_paths()[[1]])')"
+      - name: Cache PhantomJS
+        uses: actions/cache@v2
+        with:
+          path: ${{ steps.phantomjs.outputs.path }}
+          key: ${{ matrix.config.os }}-phantomjs
+          restore-keys: ${{ matrix.config.os }}-phantomjs
+      - name: Install PhantomJS
+        run: >
+          Rscript
+          -e "if (!shinytest::dependenciesInstalled()) shinytest::installDependencies()"
+
+      - name: Session info
+        run: |
+          options(width = 100)
+          pkgs <- installed.packages()[, "Package"]
+          sessioninfo::session_info(pkgs, include_base = TRUE)
+        shell: Rscript {0}
+
+      - name: Check
+        env:
+          _R_CHECK_CRAN_INCOMING_: false
+        run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check")
+        shell: Rscript {0}
+
+      - name: Show testthat output
+        if: always()
+        run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash
+
+      - name: Upload check results
+        if: failure()
+        uses: actions/upload-artifact@v2
+        with:
+          name: ${{ matrix.config.os }}-r${{ matrix.config.r }}-results
+          path: check
+
+      - name: Fix path for Windows caching
+        if: runner.os == 'Windows'
+        # This is needed because if you use the default tar at this stage,
+        # C:/Rtools/bin/tar.exe, it will say that it can't find gzip.exe. So
+        # we'll just set the path so that the original tar that would be
+        # found, will be found.
+        run: echo "C:/Program Files/Git/usr/bin" >> $GITHUB_PATH

.github/workflows/rituals.yaml

@@ -0,0 +1,153 @@
+on:
+  push:
+    branches:
+      - master
+      - ghactions
+  pull_request:
+    branches:
+      - master
+
+name: Rituals
+
+jobs:
+  rituals:
+    name: Rituals
+    # if: false
+    runs-on: ${{ matrix.config.os }}
+
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+        - { os: ubuntu-16.04, r: '4.0', node: "14.x", rspm: "https://packagemanager.rstudio.com/all/__linux__/xenial/latest"}
+
+    env:
+      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
+      RSPM: ${{ matrix.config.rspm }}
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
+    steps:
+      - uses: actions/checkout@v1
+
+      - uses: r-lib/actions/pr-fetch@master
+        name: Git Pull (PR)
+        if: github.event_name == 'pull_request'
+        with:
+          repo-token: ${{ secrets.GITHUB_TOKEN }}
+
+      - uses: r-lib/actions/setup-r@master
+        id: install-r
+        with:
+          r-version: ${{ matrix.config.r }}
+
+      - uses: r-lib/actions/setup-pandoc@master
+
+      - name: Git Config
+        run: |
+          git config user.name "${GITHUB_ACTOR}"
+          git config user.email "${GITHUB_ACTOR}@users.noreply.github.com"
+
+      - name: Install pak and query dependencies
+        shell: Rscript {0}
+        run: |
+          install.packages("pak", repos = "https://r-lib.github.io/p/pak/dev/")
+          saveRDS(pak::pkg_deps_tree("local::.", dependencies = TRUE), ".github/r-depends.rds")
+
+      - name: Cache R packages
+        uses: actions/cache@v2
+        with:
+          path: ${{ env.R_LIBS_USER }}
+          key: ${{ matrix.config.os }}-${{ steps.install-r.outputs.installed-r-version }}-1-${{ hashFiles('.github/r-depends.rds') }}
+          restore-keys: ${{ matrix.config.os }}-${{ steps.install-r.outputs.installed-r-version }}-1-
+
+      - name: Install system dependencies
+        # if: runner.os == 'Linux'
+        shell: Rscript {0}
+        run: |
+          pak::local_system_requirements(execute = TRUE)
+
+      - name: Install dependencies
+        shell: Rscript {0}
+        run: |
+          pak::local_install_dev_deps(upgrade = TRUE)
+          pak::pkg_install("sessioninfo")
+          pak::pkg_install("devtools")
+
+      - name: Session info
+        shell: Rscript {0}
+        run: |
+          options(width = 100)
+          pkgs <- installed.packages()[, "Package"]
+          sessioninfo::session_info(pkgs, include_base = TRUE)
+
+      - name: Url redirects
+        # only perform if in an RC branch (`rc-vX.Y.Z`)
+        if: ${{ github.event_name == 'push' && contains(github.ref, '/rc-v') }}
+        run: |
+          Rscript -e 'pak::pkg_install("r-lib/urlchecker"); urlchecker::url_update()'
+          # throw an error if man files were updated
+          if [ -n "$(git status --porcelain man)" ]
+          then
+            git status --porcelain
+            >&2 echo "Updated links found in files above"
+            >&2 echo 'Run `urlchecker::url_update()` to fix links locally'
+            exit 1
+          fi
+          # Add locally changed urls
+          git add .
+          git commit -m 'Update links (GitHub Actions)' || echo "No link changes to commit"
+
+      - name: Document
+        run: |
+          Rscript -e 'devtools::document()'
+          git add man/\* NAMESPACE
+          git commit -m 'Document (GitHub Actions)' || echo "No documentation changes to commit"
+
+      - name: Check documentation
+        run: |
+          ./tools/documentation/checkDocsCurrent.sh
+
+      - uses: actions/setup-node@v1
+        with:
+          node-version: ${{ matrix.config.node }}
+      # https://github.com/actions/cache/blame/ccf96194800dbb7b7094edcd5a7cf3ec3c270f10/examples.md#L185-L200
+      - name: Get yarn cache directory path
+        id: yarn-cache-dir-path
+        run: echo "::set-output name=dir::$(yarn cache dir)"
+      - name: yarn cache
+        uses: actions/cache@v2
+        id: yarn-cache # use this to check for `cache-hit` (`steps.yarn-cache.outputs.cache-hit != 'true'`)
+        with:
+          path: ${{ steps.yarn-cache-dir-path.outputs.dir }}
+          key: ${{ matrix.config.os }}-${{ matrix.config.node }}-yarn-${{ hashFiles('**/yarn.lock') }}
+          restore-keys: |
+            ${{ matrix.config.os }}-${{ matrix.config.node }}-yarn-
+      - name: Build JS
+        run: |
+          cd srcts
+          tree src
+          yarn install --immutable && yarn build
+          git add ./src && git commit -m 'yarn lint (GitHub Actions)' || echo "No yarn lint changes to commit"
+          git add ../inst && git commit -m 'yarn build (GitHub Actions)' || echo "No yarn build changes to commit"
+
+      - name: Check JS build is latest
+        run: |
+          ./tools/checkJSCurrent.sh
+
+
+      - name: Git Push (PR)
+        uses: r-lib/actions/pr-push@master
+        if: github.event_name == 'pull_request'
+        with:
+          repo-token: ${{ secrets.GITHUB_TOKEN }}
+      - name: Git Push (MASTER)
+        if: github.event_name == 'push'
+        run: |
+          git push https://${{github.actor}}:${{secrets.GITHUB_TOKEN}}@github.com/${{github.repository}}.git HEAD:${{ github.ref }} || echo "No changes to push"
+
+      # Execute after pushing, as no updated files will be produced
+      - name: Test TypeScript code
+        run: |
+          cd srcts
+          yarn test

.gitignore

@@ -10,3 +10,6 @@ shinyapps/
 README.html
 .*.Rnb.cached
 tools/yarn-error.log
+
+# GHA remotes installation
+.github/r-depends.rds

.travis.yml

@@ -1,12 +0,0 @@
-language: r
-r:
-  - oldrel
-  - release
-  - devel
-sudo: false
-cache: packages
-
-notifications:
-  email:
-    on_success: change
-    on_failure: change

DESCRIPTION

@@ -1,13 +1,18 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.3.2
+Version: 1.6.0.9000
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
     person("JJ", "Allaire", role = "aut", email = "jj@rstudio.com"),
+    person("Carson", "Sievert", role = "aut", email = "carson@rstudio.com"),
+    person("Barret", "Schloerke", role = "aut", email = "barret@rstudio.com"),
     person("Yihui", "Xie", role = "aut", email = "yihui@rstudio.com"),
+    person("Jeff", "Allen", role = "aut", email = "jeff@rstudio.com"),
     person("Jonathan", "McPherson", role = "aut", email = "jonathan@rstudio.com"),
+    person("Alan", "Dipert", role = "aut"),
+    person("Barbara", "Borges", role = "aut"),
     person(family = "RStudio", role = "cph"),
     person(family = "jQuery Foundation", role = "cph",
     comment = "jQuery library and jQuery UI library"),
@@ -23,10 +28,18 @@ Authors@R: c(
     comment = "Bootstrap library"),
     person(family = "Twitter, Inc", role = "cph",
     comment = "Bootstrap library"),
-    person("Alexander", "Farkas", role = c("ctb", "cph"),
-    comment = "html5shiv library"),
-    person("Scott", "Jehl", role = c("ctb", "cph"),
-    comment = "Respond.js library"),
+    person("Prem Nawaz", "Khan", role = "ctb",
+    comment = "Bootstrap accessibility plugin"),
+    person("Victor", "Tsaran", role = "ctb",
+    comment = "Bootstrap accessibility plugin"),
+    person("Dennis", "Lembree", role = "ctb",
+    comment = "Bootstrap accessibility plugin"),
+    person("Srinivasu", "Chakravarthula", role = "ctb",
+    comment = "Bootstrap accessibility plugin"),
+    person("Cathy", "O'Connor", role = "ctb",
+    comment = "Bootstrap accessibility plugin"),
+    person(family = "PayPal, Inc", role = "cph",
+    comment = "Bootstrap accessibility plugin"),
     person("Stefan", "Petre", role = c("ctb", "cph"),
     comment = "Bootstrap-datepicker library"),
     person("Andrew", "Rowls", role = c("ctb", "cph"),
@@ -35,10 +48,8 @@ Authors@R: c(
     comment = "Font-Awesome font"),
     person("Brian", "Reavis", role = c("ctb", "cph"),
     comment = "selectize.js library"),
-    person("Kristopher Michael", "Kowal", role = c("ctb", "cph"),
-    comment = "es5-shim library"),
-    person(family = "es5-shim contributors", role = c("ctb", "cph"),
-    comment = "es5-shim library"),
+    person("Salmen", "Bejaoui", role = c("ctb", "cph"),
+    comment = "selectize-plugin-a11y library"),
     person("Denis", "Ineshin", role = c("ctb", "cph"),
     comment = "ion.rangeSlider library"),
     person("Sami", "Samhuri", role = c("ctb", "cph"),
@@ -65,46 +76,62 @@ Depends:
 Imports:
     utils,
     grDevices,
-    httpuv (>= 1.5.0),
+    httpuv (>= 1.5.2),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
-    digest,
-    htmltools (>= 0.3.6),
+    htmltools (>= 0.5.0.9001),
     R6 (>= 2.0),
     sourcetools,
-    later (>= 0.7.2),
-    promises (>= 1.0.1),
+    later (>= 1.0.0),
+    promises (>= 1.1.0),
     tools,
     crayon,
-    rlang
+    rlang (>= 0.4.10),
+    fastmap (>= 1.1.0),
+    withr,
+    commonmark (>= 1.7),
+    glue (>= 1.3.2),
+    bslib (>= 0.2.2.9002),
+    cachem,
+    ellipsis,
+    lifecycle (>= 0.2.0)
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
-    testthat,
+    testthat (>= 3.0.0),
     knitr (>= 1.6),
     markdown,
     rmarkdown,
     ggplot2,
     reactlog (>= 1.0.0),
-    magrittr
-URL: http://shiny.rstudio.com
+    magrittr,
+    shinytest (>= 1.4.0.9003),
+    yaml,
+    future,
+    dygraphs,
+    ragg,
+    showtext,
+    sass
+URL: https://shiny.rstudio.com/
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
-    'app.R'
-    'bookmark-state-local.R'
-    'stack.R'
-    'bookmark-state.R'
-    'bootstrap-layout.R'
     'globals.R'
+    'app-state.R'
+    'app_template.R'
+    'bind-cache.R'
+    'bind-event.R'
+    'bookmark-state-local.R'
+    'bookmark-state.R'
+    'bootstrap-deprecated.R'
+    'bootstrap-layout.R'
     'conditions.R'
     'map.R'
     'utils.R'
     'bootstrap.R'
-    'cache-context.R'
-    'cache-disk.R'
-    'cache-memory.R'
     'cache-utils.R'
+    'deprecated.R'
+    'devmode.R'
     'diagnose.R'
     'fileupload.R'
     'font-awesome.R'
@@ -114,7 +141,6 @@ Collate:
     'history.R'
     'hooks.R'
     'html-deps.R'
-    'htmltools.R'
     'image-interact-opts.R'
     'image-interact.R'
     'imageutils.R'
@@ -136,30 +162,45 @@ Collate:
     'insert-tab.R'
     'insert-ui.R'
     'jqueryui.R'
+    'knitr.R'
     'middleware-shiny.R'
     'middleware.R'
+    'timer.R'
+    'shiny.R'
+    'mock-session.R'
     'modal.R'
     'modules.R'
     'notifications.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
+    'reexports.R'
     'render-cached-plot.R'
     'render-plot.R'
     'render-table.R'
     'run-url.R'
+    'runapp.R'
     'serializers.R'
     'server-input-handlers.R'
+    'server-resource-paths.R'
     'server.R'
     'shiny-options.R'
-    'shiny.R'
+    'shiny-package.R'
+    'shinyapp.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
     'snapshot.R'
     'tar.R'
     'test-export.R'
-    'timer.R'
+    'test-server.R'
+    'test.R'
     'update-input.R'
-RoxygenNote: 6.1.1
+    'utils-lang.R'
+    'version_jquery.R'
+    'viewer.R'
+RoxygenNote: 7.1.1
 Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RdMacros: lifecycle
+Config/testthat/edition: 3

LICENSE

@@ -8,12 +8,11 @@ these components are included below):
 - jQuery, https://github.com/jquery/jquery
 - jQuery UI (some components), https://github.com/jquery/jquery-ui
 - Bootstrap, https://github.com/twbs/bootstrap
-- html5shiv, https://github.com/aFarkas/html5shiv
-- Respond.js, https://github.com/scottjehl/Respond
+- bootstrap-accessibility-plugin, https://github.com/paypal/bootstrap-accessibility-plugin
 - bootstrap-datepicker, https://github.com/eternicode/bootstrap-datepicker
 - Font Awesome, https://github.com/FortAwesome/Font-Awesome
 - selectize.js, https://github.com/selectize/selectize.js
-- es5-shim, https://github.com/es-shims/es5-shim
+- selectize-plugin-a11y, https://github.com/SLMNBJ/selectize-plugin-a11y
 - ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
 - strftime for Javascript, https://github.com/samsonjs/strftime
 - DataTables, https://github.com/DataTables/DataTables
@@ -25,7 +24,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 +50,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
@@ -72,399 +71,35 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
 THE SOFTWARE.
 
 
-html5shiv License (MIT and GPL-2)
+bootstrap-accessibility-plugin (BSD-3-Clause License)
 ----------------------------------------------------------------------
-Copyright (c) 2014 Alexander Farkas (aFarkas).
-
- Licensed under MIT
-
- Permission is hereby granted, free of charge, to any person obtaining a
- copy of this software and associated documentation files (the "Software"),
- to deal in the Software without restriction, including without limitation
- the rights to use, copy, modify, merge, publish, distribute, sublicense,
- and/or sell copies of the Software, and to permit persons to whom the
- Software is furnished to do so, subject to the following conditions:
-
- The above copyright notice and this permission notice shall be included in
- all copies or substantial portions of the Software.
-
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
- DEALINGS IN THE SOFTWARE.
-
-
-        GNU GENERAL PUBLIC LICENSE
-           Version 2, June 1991
-
- Copyright (C) 1989, 1991 Free Software Foundation, Inc.
-                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-          Preamble
-
-  The licenses for most software are designed to take away your
-freedom to share and change it.  By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users.  This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it.  (Some other Free Software Foundation software is covered by
-the GNU Library General Public License instead.)  You can apply it to
-your programs, too.
-
-  When we speak of free software, we are referring to freedom, not
-price.  Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
-  To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
-  For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have.  You must make sure that they, too, receive or can get the
-source code.  And you must show them these terms so they know their
-rights.
-
-  We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
-  Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software.  If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
-  Finally, any free program is threatened constantly by software
-patents.  We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary.  To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
-  The precise terms and conditions for copying, distribution and
-modification follow.
-
-        GNU GENERAL PUBLIC LICENSE
-   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
-  0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License.  The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language.  (Hereinafter, translation is included without limitation in
-the term "modification".)  Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope.  The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
-  1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
-  2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
-    a) You must cause the modified files to carry prominent notices
-    stating that you changed the files and the date of any change.
-
-    b) You must cause any work that you distribute or publish, that in
-    whole or in part contains or is derived from the Program or any
-    part thereof, to be licensed as a whole at no charge to all third
-    parties under the terms of this License.
-
-    c) If the modified program normally reads commands interactively
-    when run, you must cause it, when started running for such
-    interactive use in the most ordinary way, to print or display an
-    announcement including an appropriate copyright notice and a
-    notice that there is no warranty (or else, saying that you provide
-    a warranty) and that users may redistribute the program under
-    these conditions, and telling the user how to view a copy of this
-    License.  (Exception: if the Program itself is interactive but
-    does not normally print such an announcement, your work based on
-    the Program is not required to print an announcement.)
-
-These requirements apply to the modified work as a whole.  If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works.  But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
-  3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
-    a) Accompany it with the complete corresponding machine-readable
-    source code, which must be distributed under the terms of Sections
-    1 and 2 above on a medium customarily used for software interchange; or,
-
-    b) Accompany it with a written offer, valid for at least three
-    years, to give any third party, for a charge no more than your
-    cost of physically performing source distribution, a complete
-    machine-readable copy of the corresponding source code, to be
-    distributed under the terms of Sections 1 and 2 above on a medium
-    customarily used for software interchange; or,
-
-    c) Accompany it with the information you received as to the offer
-    to distribute corresponding source code.  (This alternative is
-    allowed only for noncommercial distribution and only if you
-    received the program in object code or executable form with such
-    an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it.  For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable.  However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
-  4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License.  Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
-  5. You are not required to accept this License, since you have not
-signed it.  However, nothing else grants you permission to modify or
-distribute the Program or its derivative works.  These actions are
-prohibited by law if you do not accept this License.  Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
-  6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions.  You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
-  7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License.  If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all.  For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices.  Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
-  8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded.  In such case, this License incorporates
-the limitation as if written in the body of this License.
-
-  9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time.  Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number.  If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation.  If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
-  10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission.  For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this.  Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
-          NO WARRANTY
-
-  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
-  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
-         END OF TERMS AND CONDITIONS
-
-      How to Apply These Terms to Your New Programs
-
-  If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
-  To do so, attach the following notices to the program.  It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
-    <Html5shiv, The HTML5 Shiv enables use of HTML5 sectioning elements in
-    legacy Internet Explorer and provides basic HTML5 styling for Internet Explorer 6-9,
-    Safari 4.x (and iPhone 3.x), and Firefox 3.x.>
-    Copyright (C) 2014  Alexander Farkas (aFarkas)
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
-    Gnomovision version 69, Copyright (C) 2014  Alexander Farkas (aFarkas)
-    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
-    This is free software, and you are welcome to redistribute it
-    under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License.  Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary.  Here is a sample; alter the names:
-
-  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
-  `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
-  <signature of Ty Coon>, 1 April 1989
-  Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs.  If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library.  If this is what you want to do, use the GNU Library General
-Public License instead of this License.
-
-
-Respond.js License
-----------------------------------------------------------------------
-Copyright (c) 2012 Scott Jehl
-
-Permission is hereby granted, free of charge, to any person
-obtaining a copy of this software and associated documentation
-files (the "Software"), to deal in the Software without
-restriction, including without limitation the rights to use,
-copy, modify, merge, publish, distribute, sublicense, and/or sell
-copies of the Software, and to permit persons to whom the
-Software is furnished to do so, subject to the following
-conditions:
-
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-OTHER DEALINGS IN THE SOFTWARE.
+Copyright (c) 2014, PayPal
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice, this
+  list of conditions and the following disclaimer in the documentation and/or
+  other materials provided with the distribution.
+
+* Neither the name of the PayPal nor the names of its
+  contributors may be used to endorse or promote products derived from
+  this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 
 bootstrap-datepicker
@@ -700,7 +335,7 @@ THE SOFTWARE.
 
 ----
 
-Copyright (c) 2014, Dave Gandy http://fontawesome.io/,
+Copyright (c) 2014, Dave Gandy http://fontawesome.com/,
 with Reserved Font Name Font Awesome.
 
 This Font Software is licensed under the SIL Open Font License, Version 1.1.
@@ -1322,30 +957,18 @@ selectize.js
    limitations under the License.
 
 
-es5-shim License
+selectize-plugin-a11y License
 ----------------------------------------------------------------------
 
 The MIT License (MIT)
 
-Copyright (C) 2009-2014 Kristopher Michael Kowal and contributors
+Copyright 2018-present Salmen Bejaoui
 
-Permission is hereby granted, free of charge, to any person obtaining a copy
-of this software and associated documentation files (the "Software"), to deal
-in the Software without restriction, including without limitation the rights
-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-copies of the Software, and to permit persons to whom the Software is
-furnished to do so, subject to the following conditions:
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
 
-The above copyright notice and this permission notice shall be included in
-all copies or substantial portions of the Software.
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
 
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-THE SOFTWARE.
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 
 ion.rangeSlider License

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,17 +25,36 @@ S3method(as.shiny.appobj,list)
 S3method(as.shiny.appobj,shiny.appobj)
 S3method(as.tags,shiny.appobj)
 S3method(as.tags,shiny.render.function)
+S3method(bindCache,"function")
+S3method(bindCache,Observer)
+S3method(bindCache,default)
+S3method(bindCache,reactive.cache)
+S3method(bindCache,reactive.event)
+S3method(bindCache,reactiveExpr)
+S3method(bindCache,shiny.render.function)
+S3method(bindCache,shiny.render.function.cache)
+S3method(bindCache,shiny.render.function.event)
+S3method(bindCache,shiny.renderPlot)
+S3method(bindEvent,Observer)
+S3method(bindEvent,Observer.event)
+S3method(bindEvent,default)
+S3method(bindEvent,reactive.event)
+S3method(bindEvent,reactiveExpr)
+S3method(bindEvent,shiny.render.function)
 S3method(format,reactiveExpr)
 S3method(format,reactiveVal)
 S3method(names,reactivevalues)
-S3method(print,key_missing)
 S3method(print,reactive)
+S3method(print,reactivevalues)
 S3method(print,shiny.appobj)
+S3method(print,shiny.render.function)
+S3method(print,shiny_runtests)
 S3method(str,reactivevalues)
 export("conditionStackTrace<-")
 export(..stacktraceoff..)
 export(..stacktraceon..)
 export(HTML)
+export(MockShinySession)
 export(NS)
 export(Progress)
 export(a)
@@ -44,6 +66,8 @@ export(animationOptions)
 export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
+export(bindCache)
+export(bindEvent)
 export(bookmarkButton)
 export(bootstrapLib)
 export(bootstrapPage)
@@ -67,6 +91,7 @@ export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
 export(debounce)
+export(devmode)
 export(dialogViewer)
 export(diskCache)
 export(div)
@@ -93,10 +118,12 @@ export(formatStackTrace)
 export(freezeReactiveVal)
 export(freezeReactiveValue)
 export(getCurrentOutputInfo)
+export(getCurrentTheme)
 export(getDefaultReactiveDomain)
 export(getQueryString)
 export(getShinyOption)
 export(getUrlHash)
+export(get_devmode_option)
 export(h1)
 export(h2)
 export(h3)
@@ -110,9 +137,11 @@ export(hoverOpts)
 export(hr)
 export(htmlOutput)
 export(htmlTemplate)
+export(httpResponse)
 export(icon)
 export(imageOutput)
 export(img)
+export(in_devmode)
 export(incProgress)
 export(includeCSS)
 export(includeHTML)
@@ -133,19 +162,16 @@ export(isRunning)
 export(isTruthy)
 export(isolate)
 export(key_missing)
-export(knit_print.html)
-export(knit_print.reactive)
-export(knit_print.shiny.appobj)
-export(knit_print.shiny.render.function)
-export(knit_print.shiny.tag)
-export(knit_print.shiny.tag.list)
+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)
@@ -176,8 +202,10 @@ export(pre)
 export(prependTab)
 export(printError)
 export(printStackTrace)
+export(quoToFunction)
 export(radioButtons)
 export(reactive)
+export(reactiveConsole)
 export(reactiveFileReader)
 export(reactivePlot)
 export(reactivePoll)
@@ -193,9 +221,11 @@ export(reactlog)
 export(reactlogReset)
 export(reactlogShow)
 export(registerInputHandler)
+export(registerThemeDependency)
 export(removeInputHandler)
 export(removeModal)
 export(removeNotification)
+export(removeResourcePath)
 export(removeTab)
 export(removeUI)
 export(renderCachedPlot)
@@ -208,12 +238,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)
@@ -225,6 +257,7 @@ export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
+export(shinyAppTemplate)
 export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
@@ -248,15 +281,19 @@ export(strong)
 export(submitButton)
 export(suppressDependencies)
 export(tabPanel)
+export(tabPanelBody)
 export(tableOutput)
 export(tabsetPanel)
 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)
@@ -264,6 +301,7 @@ export(throttle)
 export(titlePanel)
 export(uiOutput)
 export(updateActionButton)
+export(updateActionLink)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
@@ -294,12 +332,86 @@ export(withMathJax)
 export(withProgress)
 export(withReactiveDomain)
 export(withTags)
+export(with_devmode)
 import(R6)
-import(digest)
 import(htmltools)
 import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
+importFrom(ellipsis,check_dots_empty)
+importFrom(ellipsis,check_dots_unnamed)
+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(lifecycle,deprecated)
+importFrom(promises,"%...!%")
+importFrom(promises,"%...>%")
+importFrom(promises,as.promise)
+importFrom(promises,is.promising)
+importFrom(promises,promise)
+importFrom(promises,promise_reject)
+importFrom(promises,promise_resolve)
+importFrom(rlang,"%||%")
+importFrom(rlang,as_function)
+importFrom(rlang,as_quosure)
+importFrom(rlang,enexpr)
+importFrom(rlang,enquo)
+importFrom(rlang,enquos)
+importFrom(rlang,enquos0)
+importFrom(rlang,eval_tidy)
+importFrom(rlang,expr)
+importFrom(rlang,get_env)
+importFrom(rlang,get_expr)
+importFrom(rlang,inject)
+importFrom(rlang,is_false)
+importFrom(rlang,is_missing)
+importFrom(rlang,is_na)
+importFrom(rlang,is_quosure)
+importFrom(rlang,maybe_missing)
+importFrom(rlang,missing_arg)
+importFrom(rlang,new_function)
+importFrom(rlang,new_quosure)
+importFrom(rlang,pairlist2)
+importFrom(rlang,quo)
+importFrom(rlang,zap_srcref)

R/app-state.R

@@ -0,0 +1,26 @@
+#' @include globals.R
+NULL
+
+# The current app state is a place to read and hang state for the
+# currently-running application. This is useful for setting options that will
+# last as long as the application is running.
+
+.globals$appState <- NULL
+
+initCurrentAppState <- function(appobj) {
+  if (!is.null(.globals$appState)) {
+    stop("Can't initialize current app state when another is currently active.")
+  }
+  .globals$appState <- new.env(parent = emptyenv())
+  .globals$appState$app <- appobj
+  # Copy over global options
+  .globals$appState$options <- .globals$options
+}
+
+getCurrentAppState <- function() {
+  .globals$appState
+}
+
+clearCurrentAppState <- function() {
+  .globals$appState <- NULL
+}

R/app_template.R

@@ -0,0 +1,293 @@
+#' Generate a Shiny application from a template
+#'
+#' This function populates a directory with files for a Shiny application.
+#'
+#' In an interactive R session, this function will, by default, prompt the user
+#' to select which components to add to the application. Choices are
+#'
+#' ```
+#' 1: All
+#' 2: app.R              : Main application file
+#' 3: R/example.R        : Helper file with R code
+#' 4: R/example-module.R : Example module
+#' 5: tests/shinytest/   : Tests using the shinytest package
+#' 6: tests/testthat/    : Tests using the testthat package
+#' ```
+#'
+#' If option 1 is selected, the full example application including the
+#' following files and directories is created:
+#'
+#' ```
+#' appdir/
+#' |- app.R
+#' |- R
+#' |   |- example-module.R
+#' |   `- example.R
+#' `- tests
+#'     |- shinytest.R
+#'     |- shinytest
+#'     |   `- mytest.R
+#'     |- testthat.R
+#'     `- testthat
+#'         |- test-examplemodule.R
+#'         |- test-server.R
+#'         `- test-sort.R
+#' ```
+#'
+#' Some notes about these files:
+#' * `app.R` is the main application file.
+#' * All files in the `R/` subdirectory are automatically sourced when the
+#'   application is run.
+#' * `R/example.R` and `R/example-module.R` are automatically sourced when
+#'   the application is run. The first contains a function `lexical_sort()`,
+#'   and the second contains code for module created by the
+#'   [moduleServer()] function, which is used in the application.
+#' * `tests/` contains various tests for the application. You may
+#'   choose to use or remove any of them. They can be executed by the
+#'   [runTests()] function.
+#' * `tests/shinytest.R` is a test runner for test files in the
+#'   `tests/shinytest/` directory.
+#' * `tests/shinytest/mytest.R` is a test that uses the
+#'   [shinytest](https://rstudio.github.io/shinytest/) package to do
+#'   snapshot-based testing.
+#' * `tests/testthat.R` is a test runner for test files in the
+#'   `tests/testthat/` directory using the [testthat](https://testthat.r-lib.org/) package.
+#' * `tests/testthat/test-examplemodule.R` is a test for an application's module server function.
+#' * `tests/testthat/test-server.R` is a test for the application's server code
+#' * `tests/testthat/test-sort.R` is a test for a supporting function in the `R/` directory.
+#'
+#' @param path Path to create new shiny application template.
+#' @param examples Either one of "default", "ask", "all", or any combination of
+#'   "app", "rdir", "module", "shinytest", and "testthat". In an
+#'   interactive session, "default" falls back to "ask"; in a non-interactive
+#'   session, "default" falls back to "all". With "ask", this function will
+#'   prompt the user to select which template items will be added to the new app
+#'   directory. With "all", all template items will be added to the app
+#'   directory.
+#' @param dryrun If `TRUE`, don't actually write any files; just print out which
+#'   files would be written.
+#'
+#' @export
+shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
+{
+  if (is.null(path)) {
+    stop("Please provide a `path`.")
+  }
+
+  # =======================================================
+  # Option handling
+  # =======================================================
+
+  choices <- c(
+    app       = "app.R              : Main application file",
+    rdir      = "R/example.R        : Helper file with R code",
+    module    = "R/example-module.R : Example module",
+    shinytest = "tests/shinytest/   : Tests using the shinytest package",
+    testthat  = "tests/testthat/    : Tests using the testthat package"
+  )
+
+  if (identical(examples, "default")) {
+    if (interactive()) {
+      examples <- "ask"
+    } else {
+      examples <- "all"
+    }
+  }
+
+  if (!identical(examples, "ask") &&
+      !identical(examples, "all") &&
+      any(! examples %in% names(choices)))
+  {
+    stop('`examples` must be one of "default", "ask", "all", or any combination of "',
+      paste(names(choices), collapse = '", "'), '".')
+  }
+
+  if (identical(examples, "ask")) {
+    response <- select_menu(
+      c(all = "All", choices),
+      title = paste0(
+        "Select which of the following to add at ", path, "/ :"
+      ),
+      msg = "Enter one or more numbers (with spaces), or an empty line to exit: \n"
+    )
+
+    examples <- names(response)
+  }
+
+  examples <- unique(examples)
+
+  if ("all" %in% examples) {
+    examples <- names(choices)
+  }
+
+  if (length(examples) == 0) {
+    return(invisible())
+  }
+
+  if ("shinytest" %in% examples) {
+    if (!is_available("shinytest", "1.4.0"))
+    {
+      message(
+        "The tests/shinytest directory needs shinytest 1.4.0 or later to work properly."
+      )
+      if (is_available("shinytest")) {
+        message("You currently have shinytest ",
+                utils::packageVersion("shinytest"), " installed.")
+      }
+
+    }
+  }
+
+  # =======================================================
+  # Utility functions
+  # =======================================================
+
+  # Check if a directory is empty, ignoring certain files
+  dir_is_empty <- function(path) {
+    files <- list.files(path, all.files = TRUE, no.. = TRUE)
+    # Ignore .DS_Store files, which are sometimes automatically created on macOS
+    files <- setdiff(files, ".DS_Store")
+    return(length(files) != 0)
+  }
+
+  # Helper to resolve paths relative to our template
+  template_path <- function(...) {
+    system.file("app_template", ..., package = "shiny")
+  }
+
+  # Resolve path relative to destination
+  dest_path <- function(...) {
+    file.path(path, ...)
+  }
+
+  mkdir <- function(path) {
+    if (!dirExists(path)) {
+      message("Creating ", ensure_trailing_slash(path))
+      if (!dryrun) {
+        dir.create(path, recursive = TRUE)
+      }
+    }
+  }
+
+  # Copy a file from the template directory to the destination directory. If the
+  # file has templating code (it contains `{{` in the text), then run it through
+  # the htmlTemplate().
+  copy_file_one <- function(name) {
+    from <- template_path(name)
+    to <- dest_path(name)
+
+    message("Creating ", to)
+    if (file.exists(to)) {
+      stop(to, " already exists. Please remove it and try again.", call. = FALSE)
+    }
+
+    if (!dryrun) {
+      is_template <- any(grepl("{{", readLines(from), fixed = TRUE))
+
+      if (is_template) {
+        writeChar(
+          as.character(htmlTemplate(
+            from,
+            rdir = "rdir" %in% examples,
+            module = "module" %in% examples
+          )),
+          con = to,
+          eos = NULL
+        )
+      } else {
+        file.copy(from, to)
+      }
+    }
+  }
+
+  # Copy multiple files from template to destination.
+  copy_file <- function(names) {
+    for (name in names) {
+      copy_file_one(name)
+    }
+  }
+
+  # Copy the files for a tests/ subdirectory
+  copy_test_dir <- function(name) {
+    files <- dir(template_path("tests"), recursive = TRUE)
+    # Note: This is not the same as using dir(pattern = "^shinytest"), since
+    # that will not match files inside of shinytest/.
+    files <- files[grepl(paste0("^", name), files)]
+
+    # Filter out files that are not module files in the R directory.
+    if (! "rdir" %in% examples) {
+      # find all files in the testthat folder that are not module or server files
+      is_r_folder_file <- (!grepl("module|server", basename(files))) & (dirname(files) == "testthat")
+      files <- files[!is_r_folder_file]
+    }
+
+    # Filter out module files, if applicable.
+    if (! "module" %in% examples) {
+      files <- files[!grepl("module", files)]
+    }
+
+    mkdir(dest_path("tests"))
+
+    # Create any subdirectories if needed
+    dirs <- setdiff(unique(dirname(files)), ".")
+    for (dir in dirs) {
+      mkdir(dest_path("tests", dir))
+    }
+
+    copy_file(file.path("tests", files))
+  }
+
+  # =======================================================
+  # Main function
+  # =======================================================
+
+  if (is.null(path)) {
+    stop("`path` is missing.")
+  }
+  if (file.exists(path) && !dirExists(path)) {
+    stop(path, " exists but is not a directory.")
+  }
+
+  if (dirExists(path) && dir_is_empty(path)) {
+    if (interactive()) {
+      response <- readline(paste0(
+        ensure_trailing_slash(path),
+        " is not empty. Do you want to use this directory anyway? [y/n] "
+      ))
+      if (tolower(response) != "y") {
+        return(invisible())
+      }
+    }
+  } else {
+    mkdir(path)
+  }
+
+  if ("app" %in% examples) {
+    copy_file("app.R")
+  }
+
+  # R/ dir with non-module files
+  if ("rdir" %in% examples) {
+    files <- dir(template_path("R"))
+    non_module_files <- files[!grepl("module.R$", files)]
+    mkdir(dest_path("R"))
+    copy_file(file.path("R", non_module_files))
+  }
+
+  # R/ dir with module files
+  if ("module" %in% examples) {
+    files <- dir(template_path("R"))
+    module_files <- files[grepl("module.R$", files)]
+    mkdir(dest_path("R"))
+    copy_file(file.path("R", module_files))
+  }
+
+  # tests/ dir
+  if ("shinytest" %in% examples) {
+    copy_test_dir("shinytest")
+  }
+  if ("testthat" %in% examples) {
+    copy_test_dir("testthat")
+  }
+  invisible()
+}

R/bind-cache.R

@@ -0,0 +1,774 @@
+utils::globalVariables(".GenericCallEnv", add = TRUE)
+
+#' Add caching with reactivity to an object
+#'
+#' @description
+#'
+#' `bindCache()` adds caching [reactive()] expressions and `render*` functions
+#' (like [renderText()], [renderTable()], ...).
+#'
+#' Ordinary [reactive()] expressions automatically cache their _most recent_
+#' value, which helps to  avoid redundant computation in downstream reactives.
+#' `bindCache()` will cache all previous values (as long as they fit in the
+#' cache) and they can be shared across user sessions. This allows
+#' `bindCache()` to dramatically improve performance when used correctly.
+
+#' @details
+#'
+#' `bindCache()` requires one or more expressions that are used to generate a
+#' **cache key**, which is used to determine if a computation has occurred
+#' before and hence can be retrieved from the cache. If you're familiar with the
+#' concept of memoizing pure functions (e.g., the \pkg{memoise} package), you
+#' can think of the cache key as the input(s) to a pure function. As such, one
+#' should take care to make sure the use of `bindCache()` is _pure_ in the same
+#' sense, namely:
+#'
+#' 1. For a given key, the return value is always the same.
+#' 2. Evaluation has no side-effects.
+#'
+#' In the example here, the `bindCache()` key consists of `input$x` and
+#' `input$y` combined, and the value is `input$x * input$y`. In this simple
+#' example, for any given key, there is only one possible returned value.
+#'
+#' ```
+#' r <- reactive({ input$x * input$y }) %>%
+#'   bindCache(input$x, input$y)
+#' ```
+#'
+
+#' The largest performance improvements occur when the cache key is fast to
+#' compute and the reactive expression is slow to compute. To see if the value
+#' should be computed, a cached reactive evaluates the key, and then serializes
+#' and hashes the result. If the resulting hashed key is in the cache, then the
+#' cached reactive simply retrieves the previously calculated value and returns
+#' it; if not, then the value is computed and the result is stored in the cache
+#' before being returned.
+#'
+#' To compute the cache key, `bindCache()` hashes the contents of `...`, so it's
+#' best to avoid including large objects in a cache key since that can result in
+#' slow hashing. It's also best to avoid reference objects like environments and
+#' R6 objects, since the serialization of these objects may not capture relevant
+#' changes.
+#'
+#' If you want to use a large object as part of a cache key, it may make sense
+#' to do some sort of reduction on the data that still captures information
+#' about whether a value can be retrieved from the cache. For example, if you
+#' have a large data set with timestamps, it might make sense to extract the
+#' most recent timestamp and return that. Then, instead of hashing the entire
+#' data object, the cached reactive only needs to hash the timestamp.
+#'
+#' ```
+#' r <- reactive({ compute(bigdata()) } %>%
+#'   bindCache({ extract_most_recent_time(bigdata()) })
+#' ```
+#'
+#' For computations that are very slow, it often makes sense to pair
+#' [bindCache()] with [bindEvent()] so that no computation is performed until
+#' the user explicitly requests it (for more, see the Details section of
+#' [bindEvent()]).
+
+#' @section Cache keys and reactivity:
+#'
+#'   Because the **value** expression (from the original [reactive()]) is
+#'   cached, it is not necessarily re-executed when someone retrieves a value,
+#'   and therefore it can't be used to decide what objects to take reactive
+#'   dependencies on. Instead, the **key** is used to figure out which objects
+#'   to take reactive dependencies on. In short, the key expression is reactive,
+#'   and value expression is no longer reactive.
+#'
+#'   Here's an example of what not to do: if the key is `input$x` and the value
+#'   expression is from `reactive({input$x + input$y})`, then the resulting
+#'   cached reactive  will only take a reactive dependency on `input$x` -- it
+#'   won't recompute `{input$x + input$y}` when just `input$y` changes.
+#'   Moreover, the cache won't use `input$y` as part of the key, and so it could
+#'   return incorrect values in the future when it retrieves values from the
+#'   cache. (See the examples below for an example of this.)
+#'
+#'   A better cache key would be something like `input$x, input$y`. This does
+#'   two things: it ensures that a reactive dependency is taken on both
+#'   `input$x` and `input$y`, and it also makes sure that both values are
+#'   represented in the cache key.
+#'
+#'   In general, `key` should use the same reactive inputs as `value`, but the
+#'   computation should be simpler. If there are other (non-reactive) values
+#'   that are consumed, such as external data sources, they should be used in
+#'   the `key` as well. Note that if the `key` is large, it can make sense to do
+#'   some sort of reduction on it so that the serialization and hashing of the
+#'   cache key is not too expensive.
+#'
+#'   Remember that the key is _reactive_, so it is not re-executed every single
+#'   time that someone accesses the cached reactive. It is only re-executed if
+#'   it has been invalidated by one of the reactives it depends on. For
+#'   example, suppose we have this cached reactive:
+#'
+#'   ```
+#'   r <- reactive({ input$x * input$y }) %>%
+#'     bindCache(input$x, input$y)
+#'   ```
+#'
+#' In this case, the key expression is essentially `reactive(list(input$x,
+#' input$y))` (there's a bit more to it, but that's a good enough
+#' approximation). The first time `r()` is called, it executes the key, then
+#' fails to find it in the cache, so it executes the value expression, `{
+#' input$x + input$y }`. If `r()` is called again, then it does not need to
+#' re-execute the key expression, because it has not been invalidated via a
+#' change to `input$x` or `input$y`; it simply returns the previous value.
+#' However, if `input$x` or `input$y` changes, then the reactive expression will
+#' be invalidated, and the next time that someone calls `r()`, the key
+#' expression will need to be re-executed.
+#'
+#' Note that if the cached reactive is passed to [bindEvent()], then the key
+#' expression will no longer be reactive; instead, the event expression will be
+#' reactive.
+#'
+#'
+#' @section Cache scope:
+#'
+#'   By default, when `bindCache()` is used, it is scoped to the running
+#'   application. That means that it shares a cache with all user sessions
+#'   connected to the application (within the R process). This is done with the
+#'   `cache` parameter's default value, `"app"`.
+#'
+#'   With an app-level cache scope, one user can benefit from the work done for
+#'   another user's session. In most cases, this is the best way to get
+#'   performance improvements from caching. However, in some cases, this could
+#'   leak information between sessions. For example, if the cache key does not
+#'   fully encompass the inputs used by the value, then data could leak between
+#'   the sessions. Or if a user sees that a cached reactive returns its value
+#'   very quickly, they may be able to infer that someone else has already used
+#'   it with the same values.
+#'
+#'   It is also possible to scope the cache to the session, with
+#'   `cache="session"`. This removes the risk of information leaking between
+#'   sessions, but then one session cannot benefit from computations performed in
+#'   another session.
+#'
+#'   It is possible to pass in caching objects directly to
+#'   `bindCache()`. This can be useful if, for example, you want to use a
+#'   particular type of cache with specific cached reactives, or if you want to
+#'   use a [cachem::cache_disk()] that is shared across multiple processes and
+#'   persists beyond the current R session.
+#'
+#'   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 500 MB of space
+#'   instead of the default 200 MB:
+#'
+#'   ```
+#'   shinyOptions(cache = cachem::cache_mem(max_size = 500e6))
+#'   ```
+#'
+#'   To use different settings for a session-scoped cache, you can set
+#'   `self$cache` at the top of your server function. By default, it will create
+#'   a 200 MB memory cache for each session, but you can replace it with
+#'   something different. To use the session-scoped cache, you must also call
+#'   `bindCache()` with `cache="session"`. This will create a 100 MB cache for
+#'   the session:
+#'
+#'   ```
+#'   function(input, output, session) {
+#'     session$cache <- cachem::cache_mem(max_size = 100e6)
+#'     ...
+#'   }
+#'   ```
+#'
+#'   If you want to use a cache that is shared across multiple R processes, you
+#'   can use a [cachem::cache_disk()]. You can create a application-level shared
+#'   cache by putting this at the top of your app.R, server.R, or global.R:
+#'
+#'   ```
+#'   shinyOptions(cache = cachem::cache_disk(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:
+#'
+#'   ```
+#'   shinyOptions(cache = cachem::cache_disk("./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 item, or selected items. To do that,
+#'   create a [cachem::cache_mem()] or [cachem::cache_disk()], and pass it
+#'   as the `cache` argument of `bindCache()`.
+#'
+
+#'
+#' @section Computing cache keys:
+#'
+#'   The actual cache key that is used internally takes value from evaluating
+#'   the key expression(s) (from the `...` arguments) and combines it with the
+#'   (unevaluated) value expression.
+#'
+#'   This means that if there are two cached reactives which have the same
+#'   result from evaluating the key, but different value expressions, then they
+#'   will not need to worry about collisions.
+#'
+#'   However, if two cached reactives have identical key and value expressions
+#'   expressions, they will share the cached values. This is useful when using
+#'   `cache="app"`: there may be multiple user sessions which create separate
+#'   cached reactive objects (because they are created from the same code in the
+#'   server function, but the server function is executed once for each user
+#'   session), and those cached reactive objects across sessions can share
+#'   values in the cache.
+
+
+
+#'
+#' @section Async with cached reactives:
+#'
+#'   With a cached reactive expression, the key and/or value expression can be
+#'   _asynchronous_. In other words, they can be promises --- not regular R
+#'   promises, but rather objects provided by the
+#'   \href{https://rstudio.github.io/promises/}{\pkg{promises}}  package, which
+#'   are similar to promises in JavaScript. (See [promises::promise()] for more
+#'   information.) You can also use [future::future()] objects to run code in a
+#'   separate process or even on a remote machine.
+#'
+#'   If the value returns a promise, then anything that consumes the cached
+#'   reactive must expect it to return a promise.
+#'
+#'   Similarly, if the key is a promise (in other words, if it is asynchronous),
+#'   then the entire cached reactive must be asynchronous, since the key must be
+#'   computed asynchronously before it knows whether to compute the value or the
+#'   value is retrieved from the cache. Anything that consumes the cached
+#'   reactive must therefore expect it to return a promise.
+#'
+
+#'
+#' @section Developing render functions for caching:
+#'
+#'   If you've implemented your own `render*()` function, it may just work with
+#'   `bindCache()`, but it is possible that you will need to make some
+#'   modifications. These modifications involve helping `bindCache()` avoid
+#'   cache collisions, dealing with internal state that may be set by the,
+#'   `render` function, and modifying the data as it goes in and comes out of
+#'   the cache.
+#'
+#'   You may need to provide a `cacheHint` to [createRenderFunction()] (or
+#'   [htmlwidgets::shinyRenderWidget()], if you've authored an htmlwidget) in
+#'   order for `bindCache()` to correctly compute a cache key.
+#'
+#'   The potential problem is a cache collision. Consider the following:
+#'
+#'   ```
+#'   output$x1 <- renderText({ input$x }) %>% bindCache(input$x)
+#'   output$x2 <- renderText({ input$x * 2 }) %>% bindCache(input$x)
+#'   ```
+#'
+#'   Both `output$x1` and `output$x2` use `input$x` as part of their cache key,
+#'   but if it were the only thing used in the cache key, then the two outputs
+#'   would have a cache collision, and they would have the same output. To avoid
+#'   this, a _cache hint_ is automatically added when [renderText()] calls
+#'   [createRenderFunction()]. The cache hint is used as part of the actual
+#'   cache key, in addition to the one passed to `bindCache()` by the user. The
+#'   cache hint can be viewed by calling the internal Shiny function
+#'   `extractCacheHint()`:
+#'
+#'   ```
+#'   r <- renderText({ input$x })
+#'   shiny:::extractCacheHint(r)
+#'   ```
+#'
+#'   This returns a nested list containing an item, `$origUserFunc$body`, which
+#'   in this case is the expression which was passed to `renderText()`:
+#'   `{ input$x }`. This (quoted)  expression is mixed into the actual cache
+#'   key, and it is how `output$x1` does not have collisions with `output$x2`.
+#'
+#'   For most developers of render functions, nothing extra needs to be done;
+#'   the automatic inference of the cache hint is sufficient. Again, you can
+#'   check it by calling `shiny:::extractCacheHint()`, and by testing the
+#'   render function for cache collisions in a real application.
+#'
+#'   In some cases, however, the automatic cache hint inference is not
+#'   sufficient, and it is necessary to provide a cache hint. This is true
+#'   for `renderPrint()`. Unlike `renderText()`, it wraps the user-provided
+#'   expression in another function, before passing it to [markRenderFunction()]
+#'   (instead of [createRenderFunction()]). Because the user code is wrapped in
+#'   another function, `markRenderFunction()` is not able to automatically
+#'   extract the user-provided code and use it in the cache key. Instead,
+#'   `renderPrint` calls `markRenderFunction()`, it explicitly passes along a
+#'   `cacheHint`, which includes a label and the original user expression.
+#'
+#'   In general, if you need to provide a `cacheHint`, it is best practice to
+#'   provide a `label` id, the user's `expr`, as well as any other arguments
+#'   that may influence the final value.
+#'
+#'   For \pkg{htmlwidgets}, it will try to automatically infer a cache hint;
+#'   again, you can inspect the cache hint with `shiny:::extractCacheHint()` and
+#'   also test it in an application. If you do need to explicitly provide a
+#'   cache hint, pass it to `shinyRenderWidget`. For example:
+#'
+#'   ```
+#'   renderMyWidget <- function(expr) {
+#'     expr <- substitute(expr)
+#'
+#'     htmlwidgets::shinyRenderWidget(expr,
+#'       myWidgetOutput,
+#'       quoted = TRUE,
+#'       env = parent.frame(),
+#'       cacheHint = list(label = "myWidget", userExpr = expr)
+#'     )
+#'   }
+#'   ```
+#'
+#'   If your `render` function sets any internal state, you may find it useful
+#'   in your call to [createRenderFunction()] or [markRenderFunction()] to use
+#'   the `cacheWriteHook` and/or `cacheReadHook` parameters. These hooks are
+#'   functions that run just before the object is stored in the cache, and just
+#'   after the object is retrieved from the cache. They can modify the data
+#'   that is stored and retrieved; this can be useful if extra information needs
+#'   to be stored in the cache. They can also be used to modify the state of the
+#'   application; for example, it can call [createWebDependency()] to make
+#'   JS/CSS resources available if the cached object is loaded in a different R
+#'   process. (See the source of `htmlwidgets::shinyRenderWidget` for an example
+#'   of this.)
+#'
+#' @section Uncacheable objects:
+#'
+#'   Some render functions cannot be cached, typically because they have side
+#'   effects or modify some external state, and they must re-execute each time
+#'   in order to work properly.
+#'
+#'   For developers of such code, they should call [createRenderFunction()] or
+#'   [markRenderFunction()] with `cacheHint = FALSE`.
+#'
+#'
+#' @section Caching with `renderPlot()`:
+#'
+#'   When `bindCache()` is used with `renderPlot()`, the `height` and `width`
+#'   passed to the original `renderPlot()` are ignored. They are superseded by
+#'   `sizePolicy` argument passed to `bindCache. The default is:
+#'
+#'   ```
+#'   sizePolicy = sizeGrowthRatio(width = 400, height = 400, growthRate = 1.2)
+#'   ```
+#'
+#' `sizePolicy` must be a function that takes a two-element numeric vector as
+#' input, representing the width and height of the `<img>` element in the
+#' browser window, and it must return a two-element numeric vector, representing
+#' the pixel dimensions of the plot to generate. 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 x The object to add caching to.
+#' @param ... One or more expressions to use in the caching key.
+#' @param cache The scope of the cache, or a cache object. This can be `"app"`
+#'   (the default), `"session"`, or a cache object like a
+#'   [cachem::cache_disk()]. See the Cache Scoping section for more information.
+#'
+#' @seealso [bindEvent()], [renderCachedPlot()] for caching plots.
+#'
+#' @examples
+#' \dontrun{
+#' rc <- bindCache(
+#'   x = reactive({
+#'     Sys.sleep(2)   # Pretend this is expensive
+#'     input$x * 100
+#'   }),
+#'   input$x
+#' )
+#'
+#' # Can make it prettier with the %>% operator
+#' library(magrittr)
+#'
+#' rc <- reactive({
+#'   Sys.sleep(2)
+#'   input$x * 100
+#' }) %>%
+#'   bindCache(input$x)
+#'
+#' }
+#'
+#' ## Only run app examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # Basic example
+#' shinyApp(
+#'   ui = fluidPage(
+#'     sliderInput("x", "x", 1, 10, 5),
+#'     sliderInput("y", "y", 1, 10, 5),
+#'     div("x * y: "),
+#'     verbatimTextOutput("txt")
+#'   ),
+#'   server = function(input, output) {
+#'     r <- reactive({
+#'       # The value expression is an _expensive_ computation
+#'       message("Doing expensive computation...")
+#'       Sys.sleep(2)
+#'       input$x * input$y
+#'     }) %>%
+#'       bindCache(input$x, input$y)
+#'
+#'     output$txt <- renderText(r())
+#'   }
+#' )
+#'
+#'
+#' # Caching renderText
+#' shinyApp(
+#'   ui = fluidPage(
+#'     sliderInput("x", "x", 1, 10, 5),
+#'     sliderInput("y", "y", 1, 10, 5),
+#'     div("x * y: "),
+#'     verbatimTextOutput("txt")
+#'   ),
+#'   server = function(input, output) {
+#'     output$txt <- renderText({
+#'       message("Doing expensive computation...")
+#'       Sys.sleep(2)
+#'       input$x * input$y
+#'     }) %>%
+#'       bindCache(input$x, input$y)
+#'   }
+#' )
+#'
+#'
+#' # Demo of using events and caching with an actionButton
+#' shinyApp(
+#'   ui = fluidPage(
+#'     sliderInput("x", "x", 1, 10, 5),
+#'     sliderInput("y", "y", 1, 10, 5),
+#'     actionButton("go", "Go"),
+#'     div("x * y: "),
+#'     verbatimTextOutput("txt")
+#'   ),
+#'   server = function(input, output) {
+#'     r <- reactive({
+#'       message("Doing expensive computation...")
+#'       Sys.sleep(2)
+#'       input$x * input$y
+#'     }) %>%
+#'       bindCache(input$x, input$y) %>%
+#'       bindEvent(input$go)
+#'       # The cached, eventified reactive takes a reactive dependency on
+#'       # input$go, but doesn't use it for the cache key. It uses input$x and
+#'       # input$y for the cache key, but doesn't take a reactive depdency on
+#'       # them, because the reactive dependency is superseded by addEvent().
+#'
+#'     output$txt <- renderText(r())
+#'   }
+#' )
+#'
+#' }
+#'
+#' @export
+bindCache <- function(x, ..., cache = "app") {
+  force(cache)
+
+  UseMethod("bindCache")
+}
+
+#' @export
+bindCache.default <- function(x, ...) {
+  stop("Don't know how to handle object with class ", paste(class(x), collapse = ", "))
+}
+
+#' @export
+bindCache.reactiveExpr <- function(x, ..., cache = "app") {
+  check_dots_unnamed()
+
+  label <- exprToLabel(substitute(key), "cachedReactive")
+  domain <- reactive_get_domain(x)
+
+  # Convert the ... to a function that returns their evaluated values.
+  keyFunc <- quos_to_func(enquos0(...))
+
+  valueFunc <- reactive_get_value_func(x)
+  # Hash cache hint now -- this will be added to the key later on, to reduce the
+  # chance of key collisions with other cachedReactives.
+  cacheHint <- rlang::hash(extractCacheHint(x))
+  valueFunc <- wrapFunctionLabel(valueFunc, "cachedReactiveValueFunc", ..stacktraceon = TRUE)
+
+  # Don't hold on to the reference for x, so that it can be GC'd
+  rm(x)
+  # Hacky workaround for issue with `%>%` preventing GC:
+  # https://github.com/tidyverse/magrittr/issues/229
+  if (exists(".GenericCallEnv") && exists(".", envir = .GenericCallEnv)) {
+    rm(list = ".", envir = .GenericCallEnv)
+  }
+
+
+  res <- reactive(label = label, domain = domain, {
+    cache <- resolve_cache_object(cache, domain)
+    hybrid_chain(
+      keyFunc(),
+      generateCacheFun(valueFunc, cache, cacheHint, cacheReadHook = identity, cacheWriteHook = identity)
+    )
+  })
+
+  class(res) <- c("reactive.cache", class(res))
+  res
+}
+
+#' @export
+bindCache.shiny.render.function <- function(x, ..., cache = "app") {
+  check_dots_unnamed()
+
+  keyFunc <- quos_to_func(enquos0(...))
+
+  cacheHint <- rlang::hash(extractCacheHint(x))
+
+  cacheWriteHook <- attr(x, "cacheWriteHook", exact = TRUE) %||% identity
+  cacheReadHook  <- attr(x, "cacheReadHook",  exact = TRUE) %||% identity
+
+  valueFunc <- x
+
+  renderFunc <- function(...) {
+    domain <- getDefaultReactiveDomain()
+    cache <- resolve_cache_object(cache, domain)
+
+    hybrid_chain(
+      keyFunc(),
+      generateCacheFun(valueFunc, cache, cacheHint, cacheReadHook, cacheWriteHook, ...)
+    )
+  }
+
+  renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
+  class(renderFunc) <- c("shiny.render.function.cache", class(valueFunc))
+  renderFunc
+}
+
+#' @export
+bindCache.shiny.renderPlot <- function(x, ...,
+  cache = "app",
+  sizePolicy = sizeGrowthRatio(width = 400, height = 400, growthRate = 1.2))
+{
+  check_dots_unnamed()
+
+  valueFunc <- x
+
+  # Given the actual width/height of the image element in the browser, the
+  # resize observer computes the width/height using sizePolicy() and pushes
+  # those values into `fitWidth` and `fitHeight`. It's done this way so that the
+  # `fitWidth` and `fitHeight` only change (and cause invalidations of the key
+  # expression) when the rendered image size changes, and not every time the
+  # browser's <img> tag changes size.
+  #
+  # If the key expression were invalidated every time the image element changed
+  # size, even if the resulting key was the same (because `sizePolicy()` gave
+  # the same output for a slightly different img element size), it would result
+  # in getting the (same) image from the cache and sending it to the client
+  # again. This resize observer prevents that.
+  fitDims <- reactiveVal(NULL)
+  resizeObserverCreated <- FALSE
+  outputName <- NULL
+  ensureResizeObserver <- function() {
+    if (resizeObserverCreated)
+      return()
+
+    doResizeCheck <- function() {
+      if (is.null(outputName)) {
+        outputName <<- getCurrentOutputInfo()$name
+      }
+      session <- getDefaultReactiveDomain()
+
+      width  <- session$clientData[[paste0('output_', outputName, '_width')]]  %||% 0
+      height <- session$clientData[[paste0('output_', outputName, '_height')]] %||% 0
+
+      rect <- sizePolicy(c(width, height))
+      fitDims(list(width = rect[1], height = rect[2]))
+    }
+
+    # Run it once immediately, then set up the observer
+    isolate(doResizeCheck())
+
+    observe({
+      doResizeCheck()
+    })
+    # TODO: Make sure this observer gets GC'd if output$foo is replaced.
+    # Currently, if you reassign output$foo, the observer persists until the
+    # session ends. This is generally bad programming practice and should be
+    # rare, but still, we should try to clean up properly.
+
+    resizeObserverCreated <<- TRUE
+  }
+
+  renderFunc <- function(...) {
+    hybrid_chain(
+      # Pass in fitDims so that so that the generated plot will be the
+      # dimensions specified by the sizePolicy; otherwise the plot would be the
+      # exact dimensions of the img element, which isn't what we want for cached
+      # plots.
+      valueFunc(..., get_dims = fitDims),
+      function(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
+      }
+    )
+  }
+
+  renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
+  class(renderFunc) <- class(valueFunc)
+
+  bindCache.shiny.render.function(
+    renderFunc,
+    ...,
+    {
+      ensureResizeObserver()
+      session <- getDefaultReactiveDomain()
+      if (is.null(session) || is.null(fitDims())) {
+        req(FALSE)
+      }
+      pixelratio <- session$clientData$pixelratio %||% 1
+
+      list(fitDims(), pixelratio)
+    },
+    cache = cache
+  )
+}
+
+#' @export
+bindCache.reactive.cache <- function(x, ...) {
+  stop("bindCache() has already been called on the object.")
+}
+
+#' @export
+bindCache.shiny.render.function.cache <- bindCache.reactive.cache
+
+#' @export
+bindCache.reactive.event <- function(x, ...) {
+  stop("Can't call bindCache() after calling bindEvent() on an object. Maybe you wanted to call bindEvent() after bindCache()?")
+}
+
+#' @export
+bindCache.shiny.render.function.event <- bindCache.reactive.event
+
+#' @export
+bindCache.Observer <- function(x, ...) {
+  stop("Can't bindCache an observer, because observers exist for the side efects, not for their return values.")
+}
+
+#' @export
+bindCache.function <- function(x, ...) {
+  stop(
+    "Don't know how to add caching to a plain function. ",
+    "If this is a render* function for Shiny, it may need to be updated. ",
+    "Please see ?shiny::bindCache for more information."
+  )
+}
+
+# Returns a function which should be passed as a step in to hybrid_chain(). The
+# returned function takes a cache key as input and manages storing and retrieving
+# values from the cache, as well as executing the valueFunc if needed.
+generateCacheFun <- function(
+  valueFunc,
+  cache,
+  cacheHint,
+  cacheReadHook,
+  cacheWriteHook,
+  ...
+) {
+  function(cacheKeyResult) {
+    key_str <- rlang::hash(list(cacheKeyResult, cacheHint))
+    res <- cache$get(key_str)
+
+    # Case 1: cache hit
+    if (!is.key_missing(res)) {
+      return(hybrid_chain(
+        {
+          # The first step is just to convert `res` to a promise or not, so
+          # that hybrid_chain() knows to propagate the promise-ness.
+          if (res$is_promise) promise_resolve(res)
+          else                res
+        },
+        function(res) {
+          if (res$error) {
+            stop(res$value)
+          }
+
+          cacheReadHook(valueWithVisible(res))
+        }
+      ))
+    }
+
+    # Case 2: cache miss
+    #
+    # valueFunc() might return a promise, or an actual value. Normally we'd
+    # use a hybrid_chain() for this, but in this case, we need to have
+    # different behavior if it's a promise or not a promise -- the
+    # information about whether or not it's a promise needs to be stored in
+    # the cache. We need to handle both cases and record in the cache
+    # whether it's a promise or not, so that any consumer of the
+    # cachedReactive() will be given the correct kind of object (a promise
+    # vs. an actual value) in the case of a future cache hit.
+    p <- withCallingHandlers(
+      withVisible(isolate(valueFunc(...))),
+      error = function(e) {
+        cache$set(key_str, list(
+          is_promise = FALSE,
+          value      = e,
+          visible    = TRUE,
+          error      = TRUE
+        ))
+      }
+    )
+
+    if (is.promising(p$value)) {
+      p$value <- as.promise(p$value)
+      p$value <- p$value$
+        then(function(value) {
+          res <- withVisible(value)
+          cache$set(key_str, list(
+            is_promise = TRUE,
+            value      = cacheWriteHook(res$value),
+            visible    = res$visible,
+            error      = FALSE
+          ))
+          valueWithVisible(res)
+        })$
+        catch(function(e) {
+          cache$set(key_str, list(
+            is_promise = TRUE,
+            value      = e,
+            visible    = TRUE,
+            error      = TRUE
+          ))
+          stop(e)
+        })
+      valueWithVisible(p)
+    } else {
+      # result is an ordinary value, not a promise.
+      cache$set(key_str, list(
+        is_promise = FALSE,
+        value      = cacheWriteHook(p$value),
+        visible    = p$visible,
+        error      = FALSE
+      ))
+      return(valueWithVisible(p))
+    }
+  }
+}
+
+extractCacheHint <- function(func) {
+  cacheHint <- attr(func, "cacheHint", exact = TRUE)
+
+  if (is_false(cacheHint)) {
+    stop(
+      "Cannot call `bindCache()` on this object because it is marked as not cacheable.",
+      call. = FALSE
+    )
+  }
+
+  if (is.null(cacheHint)) {
+    warning("No cacheHint found for this object. ",
+            "Caching may not work properly.")
+  }
+
+  cacheHint
+}

R/bind-event.R

@@ -0,0 +1,315 @@
+#' Make an object respond only to specified reactive events
+#'
+#' @description
+#'
+#' Modify an object to respond to "event-like" reactive inputs, values, and
+#' expressions. `bindEvent()` can be used with reactive expressions, render
+#' functions, and observers. The resulting object takes a reactive dependency on
+#' the `...` arguments, and not on the original object's code. This can, for
+#' example, be used to make an observer execute only when a button is pressed.
+#'
+#' `bindEvent()` was added in Shiny 1.6.0. When it is used with [reactive()] and
+#' [observe()], it does the same thing as [eventReactive()] and
+#' [observeEvent()]. However, `bindEvent()` is more flexible: it can be combined
+#' with [bindCache()], and it can also be used with `render` functions (like
+#' [renderText()] and [renderPlot()]).
+#'
+#' @section Details:
+#'
+#'   Shiny's reactive programming framework is primarily designed for calculated
+#'   values (reactive expressions) and side-effect-causing actions (observers)
+#'   that respond to *any* of their inputs changing. That's often what is
+#'   desired in Shiny apps, but not always: sometimes you want to wait for a
+#'   specific action to be taken from the user, like clicking an
+#'   [actionButton()], before calculating an expression or taking an action. A
+#'   reactive value or expression that is used to trigger other calculations in
+#'   this way is called an *event*.
+#'
+#'   These situations demand a more imperative, "event handling" style of
+#'   programming that is possible--but not particularly intuitive--using the
+#'   reactive programming primitives [observe()] and [isolate()]. `bindEvent()`
+#'   provides a straightforward API for event handling that wraps `observe` and
+#'   `isolate`.
+#'
+#'   The `...` arguments are captured as expressions and combined into an
+#'   **event expression**. When this event expression is invalidated (when its
+#'   upstream reactive inputs change), that is an **event**, and it will cause
+#'   the original object's code to execute.
+#'
+#'   Use `bindEvent()` with `observe()` whenever you want to *perform an action*
+#'   in response to an event. (This does the same thing as [observeEvent()],
+#'   which was available in Shiny prior to version 1.6.0.) Note that
+#'   "recalculate a value" does not generally count as performing an action --
+#'   use [reactive()] for that.
+#'
+#'   Use `bindEvent()` with `reactive()` to create a *calculated value* that
+#'   only updates in response to an event. This is just like a normal [reactive
+#'   expression][reactive] except it ignores all the usual invalidations that
+#'   come from its reactive dependencies; it only invalidates in response to the
+#'   given event. (This does the same thing as [eventReactive()], which was
+#'   available in Shiny prior to version 1.6.0.)
+#'
+#'   `bindEvent()` is often used with [bindCache()].
+#'
+#' @section ignoreNULL and ignoreInit:
+#'
+#'   `bindEvent()` takes an `ignoreNULL` parameter that affects behavior when
+#'   the event expression evaluates to `NULL` (or in the special case of an
+#'   [actionButton()], `0`). In these cases, if `ignoreNULL` is `TRUE`, then it
+#'   will raise a silent [validation][validate] error. This is useful behavior
+#'   if you don't want to do the action or calculation when your app first
+#'   starts, but wait for the user to initiate the action first (like a "Submit"
+#'   button); whereas `ignoreNULL=FALSE` is desirable if you want to initially
+#'   perform the action/calculation and just let the user re-initiate it (like a
+#'   "Recalculate" button).
+#'
+#'   `bindEvent()` also takes an `ignoreInit` argument. By default, reactive
+#'   expressions and observers will run on the first reactive flush after they
+#'   are created (except if, at that moment, the event expression evaluates to
+#'   `NULL` and `ignoreNULL` is `TRUE`). But when responding to a click of an
+#'   action button, it may often be useful to set `ignoreInit` to `TRUE`. For
+#'   example, if you're setting up an observer to respond to a dynamically
+#'   created button, then `ignoreInit = TRUE` will guarantee that the action
+#'   will only be triggered when the button is actually clicked, instead of also
+#'   being triggered when it is created/initialized. Similarly, if you're
+#'   setting up a reactive that responds to a dynamically created button used to
+#'   refresh some data (which is then returned by that `reactive`), then you
+#'   should use `reactive(...) %>% bindEvent(..., ignoreInit = TRUE)` if you
+#'   want to let the user decide if/when they want to refresh the data (since,
+#'   depending on the app, this may be a computationally expensive operation).
+#'
+#'   Even though `ignoreNULL` and `ignoreInit` can be used for similar purposes
+#'   they are independent from one another. Here's the result of combining
+#'   these:
+
+#'
+#' \describe{
+#'   \item{`ignoreNULL = TRUE` and `ignoreInit = FALSE`}{
+#'      This is the default. This combination means that reactive/observer code
+#'       will run every time that event expression is not
+#'      `NULL`. If, at the time of creation, the event expression happens
+#'      to *not* be `NULL`, then the code runs.
+#'   }
+#'   \item{`ignoreNULL = FALSE` and `ignoreInit = FALSE`}{
+#'      This combination means that reactive/observer code will
+#'      run every time no matter what.
+#'   }
+#'   \item{`ignoreNULL = FALSE` and `ignoreInit = TRUE`}{
+#'      This combination means that reactive/observer code will
+#'      *not* run at the time of creation (because `ignoreInit = TRUE`),
+#'      but it will run every other time.
+#'   }
+#'   \item{`ignoreNULL = TRUE` and `ignoreInit = TRUE`}{
+#'      This combination means that reactive/observer code will
+#'      *not* at the time of creation (because  `ignoreInit = TRUE`).
+#'      After that, the reactive/observer code will run every time that
+#'      the event expression is not `NULL`.
+#'   }
+#' }
+#'
+
+#' @section Types of objects:
+#'
+#'   `bindEvent()` can be used with reactive expressions, observers, and shiny
+#'   render functions.
+#'
+#'   When `bindEvent()` is used with `reactive()`, it creates a new reactive
+#'   expression object.
+#'
+#'   When `bindEvent()` is used with `observe()`, it alters the observer in
+#'   place. It can only be used with observers which have not yet executed.
+#'
+#' @section Combining events and caching:
+#'
+#'   In many cases, it makes sense to use `bindEvent()` along with
+#'   `bindCache()`, because they each can reduce the amount of work done on the
+#'   server. For example, you could have [sliderInput]s `x` and `y` and a
+#'   `reactive()` that performs a time-consuming operation with those values.
+#'   Using `bindCache()` can speed things up, especially if there are multiple
+#'   users. But it might make sense to also not do the computation until the
+#'   user sets both `x` and `y`, and then clicks on an [actionButton] named
+#'   `go`.
+#'
+#'   To use both caching and events, the object should first be passed to
+#'   `bindCache()`, then `bindEvent()`. For example:
+
+#'
+#'   ```
+#'   r <- reactive({
+#'       Sys.sleep(2)  # Pretend this is an expensive computation
+#'       input$x * input$y
+#'     }) %>%
+#'     bindCache(input$x, input$y) %>%
+#'     bindEvent(input$go)
+#'  ```
+
+#'
+#' Anything that consumes `r()` will take a reactive dependency on the event
+#' expression given to `bindEvent()`, and not the cache key expression given to
+#' `bindCache()`. In this case, it is just `input$go`.
+#'
+#' @param x An object to wrap so that is triggered only when a the specified
+#'   event occurs.
+#' @param ignoreNULL Whether the action should be triggered (or value
+#'   calculated) when the input is `NULL`. See Details.
+#' @param ignoreInit If `TRUE`, then, when the eventified object is first
+#'   created/initialized, don't trigger the action or (compute the value). The
+#'   default is `FALSE`. See Details.
+#' @param once Used only for observers. Whether this `observer` should be
+#'   immediately destroyed after the first time that the code in the observer is
+#'   run. This pattern is useful when you want to subscribe to a event that
+#'   should only happen once.
+#' @param label A label for the observer or reactive, useful for debugging.
+#' @param ... One or more expressions that represents the event; this can be a
+#'   simple reactive value like `input$click`, a call to a reactive expression
+#'   like `dataset()`, or even a complex expression inside curly braces. If
+#'   there are multiple expressions in the `...`, then it will take a dependency
+#'   on all of them.
+#' @export
+bindEvent <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
+                      once = FALSE, label = NULL)
+{
+  check_dots_unnamed()
+  force(ignoreNULL)
+  force(ignoreInit)
+  force(once)
+
+  UseMethod("bindEvent")
+}
+
+
+#' @export
+bindEvent.default <- function(x, ...) {
+  stop("Don't know how to handle object with class ", paste(class(x), collapse = ", "))
+}
+
+
+#' @export
+bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
+  label = NULL)
+{
+  domain <- reactive_get_domain(x)
+
+  qs <- enquos0(...)
+  eventFunc <- quos_to_func(qs)
+
+  valueFunc <- reactive_get_value_func(x)
+  valueFunc <- wrapFunctionLabel(valueFunc, "eventReactiveValueFunc", ..stacktraceon = TRUE)
+
+  label <- label %||%
+    sprintf('bindEvent(%s, %s)', attr(x, "observable", exact = TRUE)$.label, quos_to_label(qs))
+
+  # Don't hold on to the reference for x, so that it can be GC'd
+  rm(x)
+
+  initialized <- FALSE
+
+  res <- reactive(label = label, domain = domain, ..stacktraceon = FALSE, {
+    hybrid_chain(
+      eventFunc(),
+      function(value) {
+        if (ignoreInit && !initialized) {
+          initialized <<- TRUE
+          req(FALSE)
+        }
+
+        req(!ignoreNULL || !isNullEvent(value))
+
+        isolate(valueFunc())
+      }
+    )
+  })
+
+  class(res) <- c("reactive.event", class(res))
+  res
+}
+
+
+#' @export
+bindEvent.shiny.render.function <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE) {
+  eventFunc <- quos_to_func(enquos0(...))
+
+  valueFunc <- x
+
+  initialized <- FALSE
+
+  renderFunc <- function(...) {
+    hybrid_chain(
+      eventFunc(),
+      function(value) {
+        if (ignoreInit && !initialized) {
+          initialized <<- TRUE
+          req(FALSE)
+        }
+
+        req(!ignoreNULL || !isNullEvent(value))
+
+        isolate(valueFunc(...))
+      }
+    )
+  }
+
+  renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
+  class(renderFunc) <- c("shiny.render.function.event", class(valueFunc))
+  renderFunc
+}
+
+
+#' @export
+bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
+  once = FALSE, label = NULL)
+{
+  if (x$.execCount > 0) {
+    stop("Cannot call bindEvent() on an Observer that has already been executed.")
+  }
+
+  qs <- enquos0(...)
+  eventFunc <- quos_to_func(qs)
+  valueFunc <- x$.func
+
+  # Note that because the observer will already have been logged by this point,
+  # this updated label won't show up in the reactlog.
+  x$.label <- label %||% sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs))
+
+  initialized <- FALSE
+
+  x$.func <- wrapFunctionLabel(
+    name = x$.label,
+    ..stacktraceon = FALSE,
+    func = function() {
+      hybrid_chain(
+        eventFunc(),
+        function(value) {
+          if (ignoreInit && !initialized) {
+            initialized <<- TRUE
+            return()
+          }
+
+          if (ignoreNULL && isNullEvent(value)) {
+            return()
+          }
+
+          if (once) {
+            on.exit(x$destroy())
+          }
+
+          req(!ignoreNULL || !isNullEvent(value))
+
+          isolate(valueFunc())
+        }
+      )
+    }
+  )
+
+  class(x) <- c("Observer.event", class(x))
+  invisible(x)
+}
+
+
+#' @export
+bindEvent.reactive.event <-  function(x, ...) {
+  stop("bindEvent() has already been called on the object.")
+}
+
+#' @export
+bindEvent.Observer.event <- bindEvent.reactive.event

R/bookmark-state.R

@@ -1,6 +1,3 @@
-#' @include stack.R
-NULL
-
 ShinySaveState <- R6Class("ShinySaveState",
   public = list(
     input = NULL,
@@ -79,7 +76,7 @@ saveShinySaveState <- function(state) {
 
   # Look for a save.interface function. This will be defined by the hosting
   # environment if it supports bookmarking.
-  saveInterface <- getShinyOption("save.interface")
+  saveInterface <- getShinyOption("save.interface", default = NULL)
 
   if (is.null(saveInterface)) {
     if (inShinyServer()) {
@@ -217,6 +214,22 @@ RestoreContext <- R6Class("RestoreContext",
       self$dir <- NULL
     },
 
+    # Completely replace the state
+    set = function(active = FALSE, initErrorMessage = NULL, input = list(), values = list(), dir = NULL) {
+      # Validate all inputs
+      stopifnot(is.logical(active))
+      stopifnot(is.null(initErrorMessage) || is.character(initErrorMessage))
+      stopifnot(is.list(input))
+      stopifnot(is.list(values))
+      stopifnot(is.null(dir) || is.character(dir))
+
+      self$active <- active
+      self$initErrorMessage <- initErrorMessage
+      self$input <- RestoreInputSet$new(input)
+      self$values <- list2env2(values, parent = emptyenv())
+      self$dir <- dir
+    },
+
     # This should be called before a restore context is popped off the stack.
     flushPending = function() {
       self$input$flushPending()
@@ -280,7 +293,7 @@ RestoreContext <- R6Class("RestoreContext",
 
       # Look for a load.interface function. This will be defined by the hosting
       # environment if it supports bookmarking.
-      loadInterface <- getShinyOption("load.interface")
+      loadInterface <- getShinyOption("load.interface", default = NULL)
 
       if (is.null(loadInterface)) {
         if (inShinyServer()) {
@@ -431,8 +444,8 @@ RestoreInputSet <- R6Class("RestoreInputSet",
   )
 )
 
-
-restoreCtxStack <- Stack$new()
+# This is a fastmap::faststack(); value is assigned in .onLoad().
+restoreCtxStack <- NULL
 
 withRestoreContext <- function(ctx, expr) {
   restoreCtxStack$push(ctx)
@@ -453,7 +466,7 @@ hasCurrentRestoreContext <- function() {
   domain <- getDefaultReactiveDomain()
   if (!is.null(domain) && !is.null(domain$restoreContext))
     return(TRUE)
-  
+
   return(FALSE)
 }
 
@@ -479,7 +492,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.
@@ -509,23 +522,23 @@ restoreInput <- function(id, default) {
 #' It typically is called from an observer. Note that this will not work in
 #' Internet Explorer 9 and below.
 #'
-#' For \code{mode = "push"}, only three updates are currently allowed:
+#' For `mode = "push"`, only three updates are currently allowed:
 #' \enumerate{
-#'   \item the query string (format: \code{?param1=val1&param2=val2})
-#'   \item the hash (format: \code{#hash})
+#'   \item the query string (format: `?param1=val1&param2=val2`)
+#'   \item the hash (format: `#hash`)
 #'   \item both the query string and the hash
-#'     (format: \code{?param1=val1&param2=val2#hash})
+#'     (format: `?param1=val1&param2=val2#hash`)
 #' }
 #'
-#' In other words, if \code{mode = "push"}, the \code{queryString} must start
-#' with either \code{?} or with \code{#}.
+#' 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 \code{mode} argument come from).
-#' When \code{mode = "replace"}, the function called is
-#' \code{window.history.replaceState(null, null, queryString)}.
-#' When \code{mode = "push"}, the function called is
-#' \code{window.history.pushState(null, null, queryString)}.
+#' 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
@@ -534,7 +547,7 @@ restoreInput <- function(id, default) {
 #'   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}}, \code{\link{getQueryString}}
+#' @seealso [enableBookmarking()], [getQueryString()]
 #' @examples
 #' ## Only run these examples in interactive sessions
 #' if (interactive()) {
@@ -597,7 +610,7 @@ updateQueryString <- function(queryString, mode = c("replace", "push"),
 
 #' 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.
 #'
@@ -607,10 +620,10 @@ updateQueryString <- function(queryString, mode = c("replace", "push"),
 #' @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
@@ -660,10 +673,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.
@@ -719,8 +732,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").
@@ -761,8 +774,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(....) \}}.
 #'
@@ -771,17 +784,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
@@ -789,22 +802,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
@@ -983,7 +996,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)
@@ -998,17 +1011,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.
 #' }
@@ -1019,25 +1032,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.
@@ -1144,10 +1157,10 @@ setBookmarkExclude <- function(names = character(0), session = getDefaultReactiv
 #'     toupper(input$text)
 #'   })
 #'   onBookmark(function(state) {
-#'     state$values$hash <- digest::digest(input$text, "md5")
+#'     state$values$hash <- rlang::hash(input$text)
 #'   })
 #'   onRestore(function(state) {
-#'     if (identical(digest::digest(input$text, "md5"), state$values$hash)) {
+#'     if (identical(rlang::hash(input$text), state$values$hash)) {
 #'       message("Module's input text matches hash ", state$values$hash)
 #'     } else {
 #'       message("Module's input text does not match hash ", state$values$hash)
@@ -1170,10 +1183,10 @@ setBookmarkExclude <- function(names = character(0), session = getDefaultReactiv
 #' server <- function(input, output, session) {
 #'   callModule(capitalizerServer, "tc")
 #'   onBookmark(function(state) {
-#'     state$values$hash <- digest::digest(input$text, "md5")
+#'     state$values$hash <- rlang::hash(input$text)
 #'   })
 #'   onRestore(function(state) {
-#'     if (identical(digest::digest(input$text, "md5"), state$values$hash)) {
+#'     if (identical(rlang::hash(input$text), state$values$hash)) {
 #'       message("App's input text matches hash ", state$values$hash)
 #'     } else {
 #'       message("App's input text does not match hash ", state$values$hash)

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,24 @@
 #'
 #' @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"}.
+#' @inheritParams bootstrapPage
 #'
-#' @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](https://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
@@ -86,11 +85,12 @@
 #' }
 #' @rdname fluidPage
 #' @export
-fluidPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
+fluidPage <- function(..., title = NULL, responsive = deprecated(), theme = NULL, lang = NULL) {
   bootstrapPage(div(class = "container-fluid", ...),
                 title = title,
                 responsive = responsive,
-                theme = theme)
+                theme = theme,
+                lang = lang)
 }
 
 
@@ -114,23 +114,23 @@ fluidRow <- function(...) {
 #' @param title The browser window title (defaults to the host URL of the page)
 #' @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"}.
+#' @inheritParams bootstrapPage
 #'
-#' @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](https://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
@@ -153,11 +153,12 @@ fluidRow <- function(...) {
 #'
 #' @rdname fixedPage
 #' @export
-fixedPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
+fixedPage <- function(..., title = NULL, responsive = deprecated(), theme = NULL, lang = NULL) {
   bootstrapPage(div(class = "container", ...),
                 title = title,
                 responsive = responsive,
-                theme = theme)
+                theme = theme,
+                lang = lang)
 }
 
 #' @rdname fixedPage
@@ -169,8 +170,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 +179,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 +229,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 +245,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,16 +267,23 @@ 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
@@ -337,16 +348,38 @@ sidebarLayout <- function(sidebarPanel,
     fixedRow(firstPanel, secondPanel)
 }
 
+#' @export
+#' @rdname sidebarLayout
+sidebarPanel <- function(..., width = 4) {
+  div(class=paste0("col-sm-", width),
+    tags$form(class="well",
+      # A11y semantic landmark for sidebar
+      role="complementary",
+      ...
+    )
+  )
+}
+
+#' @export
+#' @rdname sidebarLayout
+mainPanel <- function(..., width = 8) {
+  div(class=paste0("col-sm-", width),
+    # A11y semantic landmark for main region
+    role="main",
+    ...
+  )
+}
+
 #' 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
@@ -377,14 +410,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
@@ -401,7 +434,7 @@ verticalLayout <- function(..., fluid = TRUE) {
 flowLayout <- function(..., cellArgs = list()) {
 
   children <- list(...)
-  childIdx <- !nzchar(names(children) %OR% character(length(children)))
+  childIdx <- !nzchar(names(children) %||% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
 
@@ -415,7 +448,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.
@@ -435,11 +468,13 @@ 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()) {
@@ -482,7 +517,7 @@ inputPanel <- function(...) {
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
   children <- list(...)
-  childIdx <- !nzchar(names(children) %OR% character(length(children)))
+  childIdx <- !nzchar(names(children) %||% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
   count <- length(children)
@@ -509,41 +544,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
@@ -660,37 +695,3 @@ flexfill <- function(..., direction, flex, width = width, height = height) {
   )
   do.call(tags$div, c(attrs, divArgs))
 }
-
-css <- function(..., collapse_ = "") {
-  props <- list(...)
-  if (length(props) == 0) {
-    return("")
-  }
-
-  if (is.null(names(props)) || any(names(props) == "")) {
-    stop("cssList expects all arguments to be named")
-  }
-
-  # Necessary to make factors show up as level names, not numbers
-  props[] <- lapply(props, paste, collapse = " ")
-
-  # Drop null args
-  props <- props[!sapply(props, empty)]
-  if (length(props) == 0) {
-    return("")
-  }
-
-  # Replace all '.' and '_' in property names to '-'
-  names(props) <- gsub("[._]", "-", tolower(gsub("([A-Z])", "-\\1", names(props))))
-
-  # Create "!important" suffix for each property whose name ends with !, then
-  # remove the ! from the property name
-  important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "")
-  names(props) <- sub("!$", "", names(props), perl = TRUE)
-
-  paste0(names(props), ":", props, important, ";", collapse = collapse_)
-}
-
-empty <- function(x) {
-  length(x) == 0 || (is.character(x) && !any(nzchar(x)))
-}

R/cache-context.R

@@ -1,77 +0,0 @@
-# A context object for tracking a cache that needs to be dirtied when a set of
-# files changes on disk. Each time the cache is dirtied, the set of files is
-# cleared. Therefore, the set of files needs to be re-built each time the cached
-# code executes. This approach allows for dynamic dependency graphs.
-CacheContext <- R6Class(
-  'CacheContext',
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    .dirty = TRUE,
-    # List of functions that return TRUE if dirty
-    .tests = list(),
-
-    addDependencyFile = function(file) {
-      if (.dirty)
-        return()
-
-      file <- normalizePath(file)
-
-      mtime <- file.info(file)$mtime
-      .tests <<- c(.tests, function() {
-        newMtime <- try(file.info(file)$mtime, silent=TRUE)
-        if (inherits(newMtime, 'try-error'))
-          return(TRUE)
-        return(!identical(mtime, newMtime))
-      })
-      invisible()
-    },
-    forceDirty = function() {
-      .dirty <<- TRUE
-      .tests <<- list()
-      invisible()
-    },
-    isDirty = function() {
-      if (.dirty)
-        return(TRUE)
-
-      for (test in .tests) {
-        if (test()) {
-          forceDirty()
-          return(TRUE)
-        }
-      }
-
-      return(FALSE)
-    },
-    reset = function() {
-      .dirty <<- FALSE
-      .tests <<- list()
-    },
-    with = function(func) {
-      oldCC <- .currentCacheContext$cc
-      .currentCacheContext$cc <- self
-      on.exit(.currentCacheContext$cc <- oldCC)
-
-      return(func())
-    }
-  )
-)
-
-.currentCacheContext <- new.env()
-
-# Indicates to Shiny that the given file path is part of the dependency graph
-# for whatever is currently executing (so far, only ui.R). By default, ui.R only
-# gets re-executed when it is detected to have changed; this function allows the
-# caller to indicate that it should also re-execute if the given file changes.
-#
-# If NULL or NA is given as the argument, then ui.R will re-execute next time.
-dependsOnFile <- function(filepath) {
-  if (is.null(.currentCacheContext$cc))
-    return()
-
-  if (is.null(filepath) || is.na(filepath))
-    .currentCacheContext$cc$forceDirty()
-  else
-    .currentCacheContext$cc$addDependencyFile(filepath)
-}

R/cache-disk.R

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

R/cache-memory.R

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

R/cache-utils.R

@@ -1,33 +1,25 @@
-#' A Key Missing object
-#'
-#' A \code{key_missing} object represents a cache miss.
-#'
-#' @param x An object to test.
-#'
-#' @seealso \code{\link{diskCache}}, \code{\link{memoryCache}}.
-#'
-#' @export
-key_missing <- function() {
-  structure(list(), class = "key_missing")
+# For our purposes, cache objects must support these methods.
+is_cache_object <- function(x) {
+  # Use tryCatch in case the object does not support `$`.
+  tryCatch(
+    is.function(x$get) && is.function(x$set),
+    error = function(e) FALSE
+  )
 }
 
-#' @rdname key_missing
-#' @export
-is.key_missing <- function(x) {
-  inherits(x, "key_missing")
-}
+# Given a cache object, or string "app" or "session", return appropriate cache
+# object.
+resolve_cache_object <- function(cache, session) {
+  if (identical(cache, "app")) {
+    cache <- getShinyOption("cache", default = NULL)
 
-#' @export
-print.key_missing <- function(x, ...) {
-  cat("<Key Missing>\n")
-}
-
-
-validate_key <- function(key) {
-  if (!is.character(key) || length(key) != 1 || nchar(key) == 0) {
-    stop("Invalid key: key must be single non-empty string.")
+  } else if (identical(cache, "session")) {
+    cache <- session$cache
   }
-  if (grepl("[^a-z0-9]", key)) {
-    stop("Invalid key: ", key, ". Only lowercase letters and numbers are allowed.")
+
+  if (is_cache_object(cache)) {
+    return(cache)
   }
+
+  stop('`cache` must either be "app", "session", or a cache object with methods, `$get`, and `$set`.')
 }

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
@@ -106,17 +106,17 @@ getCallCategories <- function(calls) {
   }, 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
+#' @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
@@ -133,7 +133,7 @@ captureStackTraces <- function(expr) {
 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)
@@ -209,15 +209,15 @@ doCaptureStack <- function(e) {
   stop(e)
 }
 
-#' @details \code{withLogErrors} captures stack traces and logs errors that
-#'   occur in \code{expr}, but does allow errors to propagate beyond this point
+#' @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,
-  full = getOption("shiny.fullstacktrace", FALSE),
+  full = get_devmode_option("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   withCallingHandlers(
@@ -247,51 +247,51 @@ 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),
+  full = get_devmode_option("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)
 }
 
 #' @rdname stacktrace
 #' @export
 printStackTrace <- function(cond,
-  full = getOption("shiny.fullstacktrace", FALSE),
+  full = get_devmode_option("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   should_drop <- !full
   should_strip <- !full
   should_prune <- !full
-  
+
   stackTraceCalls <- c(
     attr(cond, "deep.stack.trace", exact = TRUE),
     list(attr(cond, "stack.trace", exact = TRUE))
   )
-  
+
   stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
   stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
   stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
-  
+
   # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
   if (should_drop) {
     # toKeep is a list of logical vectors, of which elements (stack frames) to keep
@@ -301,7 +301,7 @@ printStackTrace <- function(cond,
     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
@@ -310,7 +310,7 @@ printStackTrace <- function(cond,
       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.
@@ -320,7 +320,7 @@ printStackTrace <- function(cond,
     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)),
@@ -329,7 +329,7 @@ printStackTrace <- function(cond,
       category = rev(getCallCategories(calls[index])),
       stringsAsFactors = FALSE
     )
-    
+
     if (i != 1) {
       message("From earlier call:")
     }
@@ -357,25 +357,26 @@ printStackTrace <- function(cond,
 
     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
+#' @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),
+  full = get_devmode_option("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")
+
+  shinyDeprecated(
+    "1.0.5", "extractStackTrace()",
+    details = "Please contact the Shiny team if you were using this functionality."
+  )
 
   srcrefs <- getSrcRefs(calls)
   if (offset) {
@@ -459,19 +460,19 @@ stripOneStackTrace <- function(stackTrace, truncateFloor, startingScore) {
       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))
 }
 
@@ -486,11 +487,11 @@ pruneStackTrace <- function(parents) {
   # 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.
@@ -502,7 +503,7 @@ pruneStackTrace <- function(parents) {
       FALSE
     }
   }, FUN.VALUE = logical(1))
-  
+
   include
 }
 
@@ -515,7 +516,7 @@ dropTrivialFrames <- function(callnames) {
   # 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)
@@ -530,27 +531,28 @@ offsetSrcrefs <- function(calls, offset = TRUE) {
     # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
     # the definition of foo().
     srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
-    
+
     calls <- setSrcRefs(calls, srcrefs)
   }
-  
+
   calls
 }
 
-#' @details \code{formatStackTrace} is similar to \code{extractStackTrace}, but
+#' @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
 formatStackTrace <- function(calls, indent = "    ",
-  full = getOption("shiny.fullstacktrace", FALSE),
+  full = get_devmode_option("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")
-  
+  shinyDeprecated(
+    "1.0.5", "formatStackTrace()",
+    details = "Please contact the Shiny team if you were using this functionality."
+  )
+
   st <- extractStackTrace(calls, full = full, offset = offset)
   if (nrow(st) == 0) {
     return(character(0))
@@ -588,11 +590,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) {
@@ -607,8 +609,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
@@ -624,4 +626,4 @@ conditionStackTrace <- function(cond) {
 #' @export
 ..stacktraceoff.. <- function(expr) expr
 
-..stacktracefloor.. <- function(expr) expr
+..stacktracefloor.. <- function(expr) expr

R/deprecated.R

@@ -0,0 +1,108 @@
+
+#' Print message for deprecated functions in Shiny
+#'
+#' To disable these messages, use `options(shiny.deprecation.messages=FALSE)`.
+#'
+#' @param version Shiny version when the function was deprecated
+#' @param what Function with possible arguments
+#' @param with Possible function with arguments that should be used instead
+#' @param details Additional information to be added after a new line to the displayed message
+#' @keywords internal
+shinyDeprecated <- function(
+  version, what, with = NULL, details = NULL
+) {
+  if (is_false(getOption("shiny.deprecation.messages"))) {
+    return(invisible())
+  }
+
+  msg <- paste0("`", what, "` is deprecated as of shiny ", version, ".")
+  if (!is.null(with)) {
+    msg <- paste0(msg, "\n", "Please use `", with, "` instead.")
+  }
+  if (!is.null(details)) {
+    msg <- paste0(msg, "\n", details)
+  }
+
+  # lifecycle::deprecate_soft(when, what, with = with, details = details, id = id, env = env)
+  rlang::inform(message = msg, .frequency = "always", .frequency_id = msg, .file = stderr())
+}
+
+
+deprecatedEnvQuotedMessage <- function() {
+  if (!in_devmode()) return(invisible())
+  if (is_false(getOption("shiny.deprecation.messages"))) return(invisible())
+
+  # manually
+  msg <- paste0(
+    "The `env` and `quoted` arguments are deprecated as of shiny 1.6.0.",
+    " Please use quosures from `rlang` instead.\n",
+    "See <https://github.com/rstudio/shiny/issues/3108> for more information."
+  )
+  rlang::inform(message = msg, .frequency = "always", .frequency_id = msg, .file = stderr())
+}
+
+
+#' Create disk cache (deprecated)
+#'
+#' @param exec_missing Deprecated.
+#' @inheritParams cachem::cache_disk
+#' @keywords internal
+#' @export
+diskCache <- function(
+  dir = NULL,
+  max_size = 500 * 1024 ^ 2,
+  max_age = Inf,
+  max_n = Inf,
+  evict = c("lru", "fifo"),
+  destroy_on_finalize = FALSE,
+  missing = key_missing(),
+  exec_missing = deprecated(),
+  logfile = NULL
+) {
+  shinyDeprecated("1.6.0", "diskCache()", "cachem::cache_disk()")
+  if (lifecycle::is_present(exec_missing)) {
+    shinyDeprecated("1.6.0", "diskCache(exec_missing =)")
+  }
+
+  cachem::cache_disk(
+    dir = dir,
+    max_size = max_size,
+    max_age = max_age,
+    max_n = max_n,
+    evict = evict,
+    destroy_on_finalize = destroy_on_finalize,
+    missing = missing,
+    logfile = logfile
+  )
+}
+
+
+#' Create memory cache (deprecated)
+#'
+#' @param exec_missing Deprecated.
+#' @inheritParams cachem::cache_mem
+#' @keywords internal
+#' @export
+memoryCache <- function(
+  max_size = 200 * 1024 ^ 2,
+  max_age = Inf,
+  max_n = Inf,
+  evict = c("lru", "fifo"),
+  missing = key_missing(),
+  exec_missing = deprecated(),
+  logfile = NULL)
+{
+  shinyDeprecated("1.6.0", "diskCache()", "cachem::cache_mem()")
+  if (lifecycle::is_present(exec_missing)) {
+    shinyDeprecated("1.6.0", "diskCache(exec_missing =)")
+  }
+
+  cachem::cache_mem(
+    max_size = max_size,
+    max_age = max_age,
+    max_n = max_n,
+    evict = evict,
+    missing = missing,
+    logfile = logfile
+  )
+}

R/devmode.R

@@ -0,0 +1,358 @@
+#' Shiny Developer Mode
+#'
+#' @description \lifecycle{experimental}
+#'
+#'   Developer Mode enables a number of [options()] to make a developer's life
+#'   easier, like enabling non-minified JS and printing messages about
+#'   deprecated functions and options.
+#'
+#'   Shiny Developer Mode can be enabled by calling `devmode(TRUE)` and disabled
+#'   by calling `devmode(FALSE)`.
+#'
+#'   Please see the function descriptions for more details.
+#'
+#' @describeIn devmode Function to set two options to enable/disable Shiny
+#'   Developer Mode and Developer messages
+#' @param devmode Logical value which should be set to `TRUE` to enable Shiny
+#'   Developer Mode
+#' @param verbose Logical value which should be set to `TRUE` display Shiny
+#'   Developer messages
+#' @export
+#' @examples
+#' # Enable Shiny Developer mode
+#' devmode()
+#'
+devmode <- function(
+  devmode = getOption("shiny.devmode", TRUE),
+  verbose = getOption("shiny.devmode.verbose", TRUE)
+) {
+  options(
+    shiny.devmode = devmode,
+    shiny.devmode.verbose = verbose
+  )
+}
+
+
+#' @describeIn devmode Determines if Shiny is in Developer Mode. If the
+#'   `getOption("shiny.devmode")` is set to `TRUE` and not in testing inside
+#'   `testthat`, then Shiny Developer Mode is enabled.
+#' @section Avoiding direct dependency on shiny:
+#'
+#'   The methods explained in this help file act independently from the rest of
+#'   Shiny but are included to provide blue prints for your own packages. If
+#'   your package already has (or is willing to take) a dependency on Shiny, we
+#'   recommend using the exported Shiny methods for consistent behavior. Note
+#'   that if you use exported Shiny methods, it will cause the Shiny package to
+#'   load. This may be undesirable if your code will be used in (for example) R
+#'   Markdown documents that do not have a Shiny runtime (`runtime: shiny`).
+#'
+#'   If your package can **not** take a dependency on Shiny, we recommending
+#'   re-implementing these two functions:
+#'
+#' \enumerate{
+#' \item `in_devmode()`:
+#'
+#'   This function should return `TRUE` if `getOption("shiny.devmode")` is set.
+#'   In addition, we strongly recommend that it also checks to make sure
+#'   `testthat` is not testing.
+#'
+#' ```r
+#' in_devmode <- function() {
+#'   isTRUE(getOption("shiny.devmode", FALSE)) &&
+#'     !identical(Sys.getenv("TESTTHAT"), "true")
+#' }
+#' ```
+#'
+#' \item `get_devmode_option(name, default, devmode_default, devmode_message)`:
+#'
+#' This function is similar to `getOption(name, default)`, but when the option
+#' is not set, the default value changes depending on the Dev Mode.
+#' `get_devmode_option()` should be implemented as follows:
+#'
+#' * If not in Dev Mode:
+#'   * Return `getOption(name, default)`.
+#' * If in Dev Mode:
+#'   * Get the global option `getOption(name)` value.
+#'   * If the global option value is set:
+#'     * Return the value.
+#'   * If the global option value is not set:
+#'     * Notify the developer that the Dev Mode default value will be used.
+#'     * Return the Dev Mode default value.
+#'
+#' When notifying the developer that the default value has changed, we strongly
+#' recommend displaying a message (`devmode_message`) to `stderr()` once every 8
+#' hours using [rlang::inform()]. This will keep the author up to date as to
+#' which Dev Mode options are being altered. To allow developers a chance to
+#' disable Dev Mode messages, the message should be skipped if
+#' `getOption("shiny.devmode.verbose", TRUE)` is not `TRUE`.
+#'
+#' ```r
+#' get_devmode_option <- function(name, default = NULL, devmode_default, devmode_message) {
+#'   if (!in_devmode()) {
+#'     # Dev Mode disabled, act like `getOption()`
+#'     return(getOption(name, default = default))
+#'   }
+#'
+#'   # Dev Mode enabled, update the default value for `getOption()`
+#'   getOption(name, default = {
+#'     # Notify developer
+#'     if (
+#'       !missing(devmode_message) &&
+#'       !is.null(devmode_message) &&
+#'       getOption("shiny.devmode.verbose", TRUE)
+#'     ) {
+#'       rlang::inform(
+#'         message = devmode_message,
+#'         .frequency = "regularly",
+#'         .frequency_id = devmode_message,
+#'         .file = stderr()
+#'       )
+#'     }
+#'
+#'     # Return Dev Mode default value `devmode_default`
+#'     devmode_default
+#'   })
+#' }
+#' ```
+#' }
+#'
+#' The remaining functions in this file are used for author convenience and are
+#' not recommended for all reimplementation situations.
+#' @export
+#' @examples
+#' in_devmode() # TRUE/FALSE?
+#'
+in_devmode <- function() {
+  isTRUE(getOption("shiny.devmode", FALSE)) &&
+    # !testthat::is_testing()
+    !identical(Sys.getenv("TESTTHAT"), "true")
+}
+
+#' @describeIn devmode Temporarily set Shiny Developer Mode and Developer
+#'   message verbosity
+#' @param code Code to execute with the temporary Dev Mode options set
+#' @export
+#' @examples
+#' # Execute code in a temporary shiny dev mode
+#' with_devmode(TRUE, in_devmode()) # TRUE
+#'
+with_devmode <- function(
+  devmode,
+  code,
+  verbose = getOption("shiny.devmode.verbose", TRUE)
+) {
+  withr::with_options(
+    list(
+      shiny.devmode = devmode,
+      shiny.devmode.verbose = verbose
+    ),
+    code
+  )
+}
+
+
+#' @describeIn devmode If Shiny Developer Mode and verbosity are enabled,
+#'   displays a message once every 8 hrs (by default)
+#' @param message Developer Mode message to be sent to [rlang::inform()]
+#' @param .frequency Frequency of the Developer Mode message used with
+#'   [rlang::inform()]. Defaults to once every 8 hours.
+#' @param .frequency_id [rlang::inform()] message identifier. Defaults to
+#'   `message`.
+#' @param .file Output connection for [rlang::inform()]. Defaults to [stderr()]
+#' @param ... Parameters passed to [rlang::inform()]
+devmode_inform <- function(
+  message,
+  .frequency = "regularly",
+  .frequency_id = message,
+  .file = stderr(),
+  ...
+) {
+
+  if (!(
+    in_devmode() &&
+      isTRUE(getOption("shiny.devmode.verbose", TRUE))
+  )) {
+    return()
+  }
+  if (is.null(message)) {
+    return()
+  }
+
+  rlang::inform(
+    message = paste0("shiny devmode - ", message),
+    .frequency = .frequency,
+    .frequency_id = .frequency_id,
+    .file = .file,
+    ...
+  )
+}
+
+
+
+
+#' @include map.R
+registered_devmode_options <- Map$new()
+
+#' @describeIn devmode Registers a Shiny Developer Mode option with an updated
+#'   value and Developer message. This registration method allows package
+#'   authors to write one message in a single location.
+#'
+#'   For example, the following Shiny Developer Mode options are registered:
+#'
+#' ```r
+#' # Reload the Shiny app when a sourced R file changes
+#' register_devmode_option(
+#'   "shiny.autoreload",
+#'   "Turning on shiny autoreload. To disable, call `options(shiny.autoreload = FALSE)`",
+#'   devmode_default = TRUE
+#' )
+#'
+#' # Use the unminified Shiny JavaScript file, `shiny.js`
+#' register_devmode_option(
+#'   "shiny.minified",
+#'   "Using full shiny javascript file. To use the minified version, call `options(shiny.minified = TRUE)`",
+#'   devmode_default = FALSE
+#' )
+#'
+#' # Display the full stack trace when errors occur during Shiny app execution
+#' register_devmode_option(
+#'   "shiny.fullstacktrace",
+#'   "Turning on full stack trace. To disable, call `options(shiny.fullstacktrace = FALSE)`",
+#'   devmode_default = TRUE
+#' )
+#' ```
+#'
+#' Other known, non-Shiny Developer Mode options:
+#'
+#' * Sass:
+#' ```r
+#' # Display the full stack trace when errors occur during Shiny app execution
+#' register_devmode_option(
+#'   "sass.cache",
+#'   "Turning off sass cache. To use default caching, call `options(sass.cache = TRUE)`",
+#'   devmode_default = FALSE
+#' )
+#' ```
+#' @param name Name of option to look for in `options()`
+#' @param default Default value to return if `in_devmode()` returns
+#'   `TRUE` and the specified option is not set in [`options()`].
+#' @param devmode_message Message to display once every 8 hours when utilizing
+#'   the `devmode_default` value.  If `devmode_message` is missing, the
+#'   registered `devmode_message` value be used.
+#' @param devmode_default Default value to return if `in_devmode()` returns
+#'   `TRUE` and the specified option is not set in [`options()`]. For
+#'   `get_devmode_option()`, if `devmode_default` is missing, the
+#'   registered `devmode_default` value will be used.
+#' @examples
+#' # Ex: Within shiny, we register the option "shiny.minified"
+#' #   to default to `FALSE` when in Dev Mode
+#' \dontrun{register_devmode_option(
+#'   "shiny.minified",
+#'   devmode_message = paste0(
+#'     "Using full shiny javascript file. ",
+#'     "To use the minified version, call `options(shiny.minified = TRUE)`"
+#'   ),
+#'   devmode_default = FALSE
+#' )}
+#'
+register_devmode_option <- function(
+  name,
+  devmode_message = NULL,
+  devmode_default = NULL
+) {
+  if (!is.null(devmode_message)) {
+    stopifnot(length(devmode_message) == 1 && is.character(devmode_message))
+  }
+  registered_devmode_options$set(
+    name,
+    list(devmode_default = devmode_default, devmode_message = devmode_message)
+  )
+}
+
+
+#' @describeIn devmode Provides a consistent way to change the expected
+#'   [getOption()] behavior when Developer Mode is enabled. This method is very
+#'   similar to [getOption()] where the globally set option takes precedence.
+#'   See section "Avoiding direct dependency on shiny" for
+#'   `get_devmode_option()` implementation details.
+#'
+#'   **Package developers:** Register your Dev Mode option using
+#'   `register_devmode_option()` to avoid supplying the same `devmode_default`
+#'   and `devmode_message` values throughout your package. (This requires a
+#'   \pkg{shiny} dependency.)
+#' @export
+#' @examples
+#' # Used within `shiny::runApp(launch.browser)`
+#' get_devmode_option("shiny.minified", TRUE) # TRUE if Dev mode is off
+#' is_minified <- with_devmode(TRUE, {
+#'   get_devmode_option("shiny.minified", TRUE)
+#' })
+#' is_minified # FALSE
+#'
+get_devmode_option <- function(
+  name,
+  default = NULL,
+  devmode_default = missing_arg(),
+  devmode_message = missing_arg()
+) {
+  getOption(
+    name,
+    local({
+      if (!in_devmode()) {
+        # typical case
+        return(default)
+      }
+
+      info <- registered_devmode_options$get(name)
+      if (is.null(info)) {
+        # Not registered,
+        # Warn and return default value
+        rlang::warn(
+          message = paste0(
+            "`get_devmode_option(name)` could not find `name = \"", name, "\"`. ",
+            "Returning `default` value"
+          )
+        )
+        return(default)
+      }
+
+      # display message
+      devmode_inform(
+        maybe_missing(
+          # use provided `devmode_message` value
+          devmode_message,
+          # If `devmode_message` is missing, display registered `devmode_message`
+          default = info$devmode_message
+        )
+      )
+
+      # return value
+      maybe_missing(
+        # use provided `devmode_default` value
+        devmode_default,
+        # if `devmode_default` is missing, provide registered `devmode_default`
+        default = info$devmode_default
+      )
+    })
+  )
+}
+
+
+
+register_devmode_option(
+  "shiny.autoreload",
+  "Turning on shiny autoreload. To disable, call `options(shiny.autoreload = FALSE)`",
+  TRUE
+)
+
+register_devmode_option(
+  "shiny.minified",
+  "Using full shiny javascript file. To use the minified version, call `options(shiny.minified = TRUE)`",
+  FALSE
+)
+
+register_devmode_option(
+  "shiny.fullstacktrace",
+  "Turning on full stack trace. To disable, call `options(shiny.fullstacktrace = FALSE)`",
+  TRUE
+)

R/font-awesome.R

@@ -1,75 +1,461 @@
+# Generated by tools/updateFontAwesome.R: do not edit by hand
 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"
-)
+  "500px",
+  "accessible-icon",
+  "accusoft",
+  "acquisitions-incorporated",
+  "adn",
+  "adversal",
+  "affiliatetheme",
+  "airbnb",
+  "algolia",
+  "alipay",
+  "amazon",
+  "amazon-pay",
+  "amilia",
+  "android",
+  "angellist",
+  "angrycreative",
+  "angular",
+  "app-store",
+  "app-store-ios",
+  "apper",
+  "apple",
+  "apple-pay",
+  "artstation",
+  "asymmetrik",
+  "atlassian",
+  "audible",
+  "autoprefixer",
+  "avianex",
+  "aviato",
+  "aws",
+  "bandcamp",
+  "battle-net",
+  "behance",
+  "behance-square",
+  "bimobject",
+  "bitbucket",
+  "bitcoin",
+  "bity",
+  "black-tie",
+  "blackberry",
+  "blogger",
+  "blogger-b",
+  "bluetooth",
+  "bluetooth-b",
+  "bootstrap",
+  "btc",
+  "buffer",
+  "buromobelexperte",
+  "buy-n-large",
+  "buysellads",
+  "canadian-maple-leaf",
+  "cc-amazon-pay",
+  "cc-amex",
+  "cc-apple-pay",
+  "cc-diners-club",
+  "cc-discover",
+  "cc-jcb",
+  "cc-mastercard",
+  "cc-paypal",
+  "cc-stripe",
+  "cc-visa",
+  "centercode",
+  "centos",
+  "chrome",
+  "chromecast",
+  "cloudflare",
+  "cloudscale",
+  "cloudsmith",
+  "cloudversify",
+  "codepen",
+  "codiepie",
+  "confluence",
+  "connectdevelop",
+  "contao",
+  "cotton-bureau",
+  "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",
+  "creative-commons-zero",
+  "critical-role",
+  "css3",
+  "css3-alt",
+  "cuttlefish",
+  "d-and-d",
+  "d-and-d-beyond",
+  "dailymotion",
+  "dashcube",
+  "deezer",
+  "delicious",
+  "deploydog",
+  "deskpro",
+  "dev",
+  "deviantart",
+  "dhl",
+  "diaspora",
+  "digg",
+  "digital-ocean",
+  "discord",
+  "discourse",
+  "dochub",
+  "docker",
+  "draft2digital",
+  "dribbble",
+  "dribbble-square",
+  "dropbox",
+  "drupal",
+  "dyalog",
+  "earlybirds",
+  "ebay",
+  "edge",
+  "edge-legacy",
+  "elementor",
+  "ello",
+  "ember",
+  "empire",
+  "envira",
+  "erlang",
+  "ethereum",
+  "etsy",
+  "evernote",
+  "expeditedssl",
+  "facebook",
+  "facebook-f",
+  "facebook-messenger",
+  "facebook-square",
+  "fantasy-flight-games",
+  "fedex",
+  "fedora",
+  "figma",
+  "firefox",
+  "firefox-browser",
+  "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-alt",
+  "git-square",
+  "github",
+  "github-alt",
+  "github-square",
+  "gitkraken",
+  "gitlab",
+  "gitter",
+  "glide",
+  "glide-g",
+  "gofore",
+  "goodreads",
+  "goodreads-g",
+  "google",
+  "google-drive",
+  "google-pay",
+  "google-play",
+  "google-plus",
+  "google-plus-g",
+  "google-plus-square",
+  "google-wallet",
+  "gratipay",
+  "grav",
+  "gripfire",
+  "grunt",
+  "guilded",
+  "gulp",
+  "hacker-news",
+  "hacker-news-square",
+  "hackerrank",
+  "hips",
+  "hire-a-helper",
+  "hive",
+  "hooli",
+  "hornbill",
+  "hotjar",
+  "houzz",
+  "html5",
+  "hubspot",
+  "ideal",
+  "imdb",
+  "innosoft",
+  "instagram",
+  "instagram-square",
+  "instalod",
+  "intercom",
+  "internet-explorer",
+  "invision",
+  "ioxhost",
+  "itch-io",
+  "itunes",
+  "itunes-note",
+  "java",
+  "jedi-order",
+  "jenkins",
+  "jira",
+  "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",
+  "mdb",
+  "medapps",
+  "medium",
+  "medium-m",
+  "medrt",
+  "meetup",
+  "megaport",
+  "mendeley",
+  "microblog",
+  "microsoft",
+  "mix",
+  "mixcloud",
+  "mixer",
+  "mizuni",
+  "modx",
+  "monero",
+  "napster",
+  "neos",
+  "nimblr",
+  "node",
+  "node-js",
+  "npm",
+  "ns8",
+  "nutritionix",
+  "octopus-deploy",
+  "odnoklassniki",
+  "odnoklassniki-square",
+  "old-republic",
+  "opencart",
+  "openid",
+  "opera",
+  "optin-monster",
+  "orcid",
+  "osi",
+  "page4",
+  "pagelines",
+  "palfed",
+  "patreon",
+  "paypal",
+  "penny-arcade",
+  "perbyte",
+  "periscope",
+  "phabricator",
+  "phoenix-framework",
+  "phoenix-squadron",
+  "php",
+  "pied-piper",
+  "pied-piper-alt",
+  "pied-piper-hat",
+  "pied-piper-pp",
+  "pied-piper-square",
+  "pinterest",
+  "pinterest-p",
+  "pinterest-square",
+  "playstation",
+  "product-hunt",
+  "pushed",
+  "python",
+  "qq",
+  "quinscape",
+  "quora",
+  "r-project",
+  "raspberry-pi",
+  "ravelry",
+  "react",
+  "reacteurope",
+  "readme",
+  "rebel",
+  "red-river",
+  "reddit",
+  "reddit-alien",
+  "reddit-square",
+  "redhat",
+  "renren",
+  "replyd",
+  "researchgate",
+  "resolving",
+  "rev",
+  "rocketchat",
+  "rockrms",
+  "rust",
+  "safari",
+  "salesforce",
+  "sass",
+  "schlix",
+  "scribd",
+  "searchengin",
+  "sellcast",
+  "sellsy",
+  "servicestack",
+  "shirtsinbulk",
+  "shopify",
+  "shopware",
+  "simplybuilt",
+  "sistrix",
+  "sith",
+  "sketch",
+  "skyatlas",
+  "skype",
+  "slack",
+  "slack-hash",
+  "slideshare",
+  "snapchat",
+  "snapchat-ghost",
+  "snapchat-square",
+  "soundcloud",
+  "sourcetree",
+  "speakap",
+  "speaker-deck",
+  "spotify",
+  "squarespace",
+  "stack-exchange",
+  "stack-overflow",
+  "stackpath",
+  "staylinked",
+  "steam",
+  "steam-square",
+  "steam-symbol",
+  "sticker-mule",
+  "strava",
+  "stripe",
+  "stripe-s",
+  "studiovinari",
+  "stumbleupon",
+  "stumbleupon-circle",
+  "superpowers",
+  "supple",
+  "suse",
+  "swift",
+  "symfony",
+  "teamspeak",
+  "telegram",
+  "telegram-plane",
+  "tencent-weibo",
+  "the-red-yeti",
+  "themeco",
+  "themeisle",
+  "think-peaks",
+  "tiktok",
+  "trade-federation",
+  "trello",
+  "tripadvisor",
+  "tumblr",
+  "tumblr-square",
+  "twitch",
+  "twitter",
+  "twitter-square",
+  "typo3",
+  "uber",
+  "ubuntu",
+  "uikit",
+  "umbraco",
+  "uncharted",
+  "uniregistry",
+  "unity",
+  "unsplash",
+  "untappd",
+  "ups",
+  "usb",
+  "usps",
+  "ussunnah",
+  "vaadin",
+  "viacoin",
+  "viadeo",
+  "viadeo-square",
+  "viber",
+  "vimeo",
+  "vimeo-square",
+  "vimeo-v",
+  "vine",
+  "vk",
+  "vnv",
+  "vuejs",
+  "watchman-monitoring",
+  "waze",
+  "weebly",
+  "weibo",
+  "weixin",
+  "whatsapp",
+  "whatsapp-square",
+  "whmcs",
+  "wikipedia-w",
+  "windows",
+  "wix",
+  "wizards-of-the-coast",
+  "wodu",
+  "wolf-pack-battalion",
+  "wordpress",
+  "wordpress-simple",
+  "wpbeginner",
+  "wpexplorer",
+  "wpforms",
+  "wpressr",
+  "xbox",
+  "xing",
+  "xing-square",
+  "y-combinator",
+  "yahoo",
+  "yammer",
+  "yandex",
+  "yandex-international",
+  "yarn",
+  "yelp",
+  "yoast",
+  "youtube",
+  "youtube-square",
+  "zhihu"
+)

R/globals.R

@@ -1,23 +1,74 @@
 # 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) {
+
+  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() && !is_available(pkg, version)) {
+    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 (!is_available(pkg, version)) 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(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."
-    )
-  }
+  # Create this at the top level, but since the object is from a different
+  # package, we don't want to bake it into the built binary package.
+  restoreCtxStack <<- fastmap::faststack()
+
+  # 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,31 +1,20 @@
-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) {
+check_suggested <- function(package, version = NULL) {
 
-  if (is_installed(package, version)) {
+  if (is_available(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 (is.na(version %||% NA)) "" else paste0("(>= ", version, ")"),
+    " must be installed for this functionality."
   )
 
-  if (interactive() && missing_location) {
+  if (interactive()) {
     message(msg, "\nWould you like to install it?")
     if (utils::menu(c("Yes", "No")) == 1) {
       return(utils::install.packages(package))
@@ -59,8 +48,8 @@ reactIdStr <- function(num) {
 #' 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.
 #'
@@ -75,14 +64,14 @@ reactIdStr <- function(num) {
 #'
 #' 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{reactlogShow} 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{reactlogShow()} 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.
 #'
@@ -91,24 +80,26 @@ NULL
 
 
 #' @describeIn reactlog Return a list of reactive information.  Can be used in conjunction with
-#'   \code{reactlog::\link[reactlog]{reactlog_show}} to later display the reactlog graph.
+#'   [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
+#' @param time A boolean that specifies whether or not to display the
+#' time that each reactive takes to calculate a result.
 #' @export
 reactlogShow <- function(time = TRUE) {
   check_reactlog()
   reactlog::reactlog_show(reactlog(), time = time)
 }
-#' @describeIn reactlog This function is deprecated. You should use \code{\link{reactlogShow}}
+#' @describeIn reactlog This function is deprecated. You should use [reactlogShow()]
 #' @export
 # legacy purposes
 showReactLog <- function(time = TRUE) {
-  shinyDeprecated(new = "`reactlogShow`", version = "1.2.0")
+  shinyDeprecated("1.2.0", "showReactLog()", "reactlogShow()")
+
   reactlogShow(time = time)
 }
 #' @describeIn reactlog Resets the entire reactlog stack.  Useful for debugging and removing all prior reactive history.
@@ -190,10 +181,10 @@ RLog <- R6Class(
       paste0("names(", reactId, ")")
     },
     asListIdStr = function(reactId) {
-      paste0("as.list(", reactId, ")")
+      paste0("reactiveValuesToList(", reactId, ")")
     },
     asListAllIdStr = function(reactId) {
-      paste0("as.list(", reactId, ", all.names = TRUE)")
+      paste0("reactiveValuesToList(", reactId, ", all.names = TRUE)")
     },
     keyIdStr = function(reactId, key) {
       paste0(reactId, "$", key)
@@ -221,7 +212,7 @@ RLog <- R6Class(
     reset = function() {
       .globals$reactIdCounter <- 0L
 
-      self$logStack <- Stack$new()
+      self$logStack <- fastmap::faststack()
       self$msg <- MessageLogger$new(option = private$msgOption)
 
       # setup dummy and missing react information
@@ -569,5 +560,4 @@ MessageLogger = R6Class(
   )
 )
 
-#' @include stack.R
 rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")

R/history.R

@@ -15,21 +15,21 @@ NULL
 #' the conditional on an input or a calculated reactive, you can base it on the
 #' query string). However, note that, if you're changing the query string / hash
 #' programatically from within the server code, you must use
-#' \code{updateQueryString(_yourNewQueryString_, mode = "push")}. The default
-#' \code{mode} for \code{updateQueryString} is \code{"replace"}, which doesn't
+#' `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
-#' \emph{not} get triggered. However, if you're changing the query string / hash
+#' *not* get triggered. However, if you're changing the query string / hash
 #' directly by typing directly in the browser and hitting enter, you don't have
 #' to worry about this.
 #'
 #' @param session	A Shiny session object.
 #'
-#' @return For \code{getQueryString}, a named list. For example, the query
-#'   string \code{?param1=value1&param2=value2} becomes \code{list(param1 =
-#'   value1, param2 = value2)}. For \code{getUrlHash}, a character vector with
-#'   the hash (including the leading \code{#} symbol).
+#' @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 \code{\link{updateQueryString}}
+#' @seealso [updateQueryString()]
 #'
 #' @examples
 #' ## Only run this example in interactive R sessions

R/html-deps.R

@@ -2,20 +2,20 @@
 #'
 #' 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.
-#' @param scrubFile If TRUE (the default), remove \code{src$file} for the
+#'   [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
-#'   \code{src$file}. Setting it to FALSE should be needed only in very unusual
+#'   `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, scrubFile = TRUE) {
   if (is.null(dependency))

R/htmltools.R

@@ -1,8 +0,0 @@
-#' @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
-#' @export validateCssUnit
-#' @export knit_print.html knit_print.shiny.tag knit_print.shiny.tag.list
-#' @export htmlTemplate suppressDependencies
-NULL

R/image-interact-opts.R

@@ -1,16 +1,27 @@
-#' Create an object representing click options
+#' Control interactive plot point events
 #'
-#' This generates an object representing click options, to be passed as the
-#' \code{click} argument of \code{\link{imageOutput}} or
-#' \code{\link{plotOutput}}.
+#' These functions give control over the `click`, `dblClick` and
+#' `hover` events generated by [imageOutput()] and [plotOutput()].
 #'
-#' @param id Input value name. For example, if the value is \code{"plot_click"},
-#'   then the click coordinates will be available as \code{input$plot_click}.
-#' @param clip Should the click area be clipped to the plotting area? If FALSE,
-#'   then the server will receive click events even when the mouse is outside
-#'   the plotting area, as long as it is still inside the image.
+#' @param id Input value name. For example, if the value is `"plot_click"`,
+#'   then the event data 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.
+#' @param delay For `dblClickOpts()`: the maximum delay (in ms) between a
+#'   pair clicks for them to be counted as a double-click.
+#'
+#'   For `hoverOpts()`: how long to delay (in ms) 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 `"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
+#'   `delay` milliseconds before sending an event.
+#' @seealso [brushOpts()] for brushing events.
 #' @export
-clickOpts <- function(id = NULL, clip = TRUE) {
+#' @keywords internal
+clickOpts <- function(id, clip = TRUE) {
   if (is.null(id))
     stop("id must not be NULL")
 
@@ -21,22 +32,9 @@ 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}}.
-#'
-#' @param id Input value name. For example, if the value is
-#'   \code{"plot_dblclick"}, then the click coordinates will be available as
-#'   \code{input$plot_dblclick}.
-#' @param clip Should the click area be clipped to the plotting area? If FALSE,
-#'   then the server will receive double-click events even when the mouse is
-#'   outside the plotting area, as long as it is still inside the image.
-#' @param delay Maximum delay (in ms) between a pair clicks for them to be
-#'   counted as a double-click.
 #' @export
-dblclickOpts <- function(id = NULL, clip = TRUE, delay = 400) {
+#' @rdname clickOpts
+dblclickOpts <- function(id, clip = TRUE, delay = 400) {
   if (is.null(id))
     stop("id must not be NULL")
 
@@ -47,29 +45,12 @@ 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}}.
-#'
-#' @param id Input value name. For example, if the value is \code{"plot_hover"},
-#'   then the hover coordinates will be available as \code{input$plot_hover}.
-#' @param delay How long to delay (in milliseconds) when debouncing or
-#'   throttling, before sending the mouse location to the server.
-#' @param delayType The type of algorithm for limiting the number of hover
-#'   events. Use \code{"throttle"} to limit the number of hover events to one
-#'   every \code{delay} milliseconds. Use \code{"debounce"} to suspend events
-#'   while the cursor is moving, and wait until the cursor has been at rest for
-#'   \code{delay} milliseconds before sending an event.
-#' @param clip Should the hover area be clipped to the plotting area? If FALSE,
-#'   then the server will receive hover events even when the mouse is outside
-#'   the plotting area, as long as it is still inside the image.
-#' @param nullOutside If \code{TRUE} (the default), the value will be set to
-#'   \code{NULL} when the mouse exits the plotting area. If \code{FALSE}, the
+#' @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,
+#' @rdname clickOpts
+hoverOpts <- function(id, delay = 300,
                       delayType = c("debounce", "throttle"), clip = TRUE,
                       nullOutside = TRUE) {
   if (is.null(id))
@@ -87,37 +68,42 @@ 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.
-#' @param fill Fill color of the brush.
-#' @param stroke Outline color of the brush.
+#'   same `id` to disappear.
+#' @param fill Fill color of the brush. If `'auto'`, it derives from the link
+#'   color of the plot's HTML container (if **thematic** is enabled, and `accent`
+#'   is a non-`'auto'` value, that color is used instead).
+#' @param stroke Outline color of the brush. If `'auto'`, it derives from the
+#'   foreground color of the plot's HTML container (if **thematic** is enabled,
+#'   and `fg` is a non-`'auto'` value, that color is used instead).
 #' @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.
+#' @seealso [clickOpts()] for clicking events.
 #' @export
-brushOpts <- function(id = NULL, fill = "#9cf", stroke = "#036",
+brushOpts <- function(id, fill = "#9cf", stroke = "#036",
                       opacity = 0.25, delay = 300,
                       delayType = c("debounce", "throttle"), clip = TRUE,
                       direction = c("xy", "x", "y"),
@@ -125,6 +111,13 @@ brushOpts <- function(id = NULL, fill = "#9cf", stroke = "#036",
   if (is.null(id))
     stop("id must not be NULL")
 
+  if (identical(fill, "auto")) {
+    fill <- getThematicOption("accent", "auto")
+  }
+  if (identical(stroke, "auto")) {
+    stroke <- getThematicOption("fg", "auto")
+  }
+
   list(
     id = id,
     fill = fill,
@@ -137,3 +130,13 @@ brushOpts <- function(id = NULL, fill = "#9cf", stroke = "#036",
     resetOnNew = resetOnNew
   )
 }
+
+getThematicOption <- function(name = "", default = NULL, resolve = FALSE) {
+  if (isNamespaceLoaded("thematic")) {
+    # TODO: use :: once thematic is on CRAN
+    tgo <- utils::getFromNamespace("thematic_get_option", "thematic")
+    tgo(name = name, default = default, resolve = resolve)
+  } else {
+    default
+  }
+}

R/image-interact.R

@@ -1,59 +1,76 @@
-#' Find rows of data that are selected by a brush
+#' Find rows of data selected on an interactive plot.
 #'
-#' This function returns rows from a data frame which are under a brush used
-#' with \code{\link{plotOutput}}.
+#' @description
+#' `brushedPoints()` returns rows from a data frame which are under a brush.
+#' `nearPoints()` returns rows from a data frame which are near a click, hover,
+#' or double-click. Alternatively, set `allRows = TRUE` to return all rows from
+#' the input data with an additional column `selected_` that indicates which
+#' rows of the would be selected.
 #'
-#' 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.
+#' @section ggplot2:
+#' For plots created with ggplot2, it is not necessary to specify the
+#' column names to `xvar`, `yvar`, `panelvar1`, and `panelvar2` as that
+#' information can be automatically derived from the plot specification.
 #'
-#' The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2}
-#' arguments specify which columns in the data correspond to the x variable, y
-#' variable, and panel variables of the plot. For example, if your plot is
-#' \code{plot(x=cars$speed, y=cars$dist)}, and your brush is named
-#' \code{"cars_brush"}, then you would use \code{brushedPoints(cars,
-#' input$cars_brush, "speed", "dist")}.
-#'
-#' For plots created with ggplot2, it should not be necessary to specify the
-#' column names; that information will already be contained in the brush,
-#' provided that variables are in the original data, and not computed. For
-#' example, with \code{ggplot(cars, aes(x=speed, y=dist)) + geom_point()}, you
-#' could use \code{brushedPoints(cars, input$cars_brush)}. If, however, you use
-#' a computed column, like \code{ggplot(cars, aes(x=speed/2, y=dist)) +
-#' geom_point()}, then it will not be able to automatically extract column names
-#' and filter on them. If you want to use this function to filter data, it is
-#' recommended that you not use computed columns; instead, modify the data
+#' Note, however, that this will not work if you use a computed column, like
+#' `aes(speed/2, dist))`. Instead, we recommend that you modify the data
 #' first, and then make the plot with "raw" columns in the modified data.
 #'
-#' If a specified x or y column is a factor, then it will be coerced to an
-#' integer vector. If it is a character vector, then it will be coerced to a
-#' factor and then integer vector. This means that the brush will be considered
-#' to cover a given character/factor value when it covers the center value.
+#' @section Brushing:
+#' If x or y column is a factor, then it will be coerced to an integer vector.
+#' If it is a character vector, then it will be coerced to a factor and then
+#' integer vector. This means that the brush will be considered to cover a
+#' given character/factor value when it covers the center value.
 #'
 #' If the brush is operating in just the x or y directions (e.g., with
-#' \code{brushOpts(direction = "x")}, then this function will filter out points
+#' `brushOpts(direction = "x")`, then this function will filter out points
 #' using just the x or y variable, whichever is appropriate.
 #'
-#' @param brush The data from a brush, such as \code{input$plot_brush}.
-#' @param df A data frame from which to select rows.
-#' @param xvar,yvar A string with the name of the variable on the x or y axis.
-#'   This must also be the name of a column in \code{df}. If absent, then this
-#'   function will try to infer the variable from the brush (only works for
-#'   ggplot2).
-#' @param panelvar1,panelvar2 Each of these is a string with the name of a panel
-#'   variable. For example, if with ggplot2, you facet on a variable called
-#'   \code{cyl}, then you can use \code{"cyl"} here. However, specifying the
-#'   panel variable should not be necessary with ggplot2; Shiny should be able
-#'   to auto-detect the panel variable.
-#' @param allRows If \code{FALSE} (the default) return a data frame containing
-#'   the selected rows. If \code{TRUE}, the input data frame will have a new
-#'   column, \code{selected_}, which indicates whether the row was inside the
-#'   brush (\code{TRUE}) or outside the brush (\code{FALSE}).
+#' @returns
+#' A data frame based on `df`, containing the observations selected by the
+#' brush or near the click event. For `nearPoints()`, the rows will be sorted
+#' by distance to the event.
 #'
-#' @seealso \code{\link{plotOutput}} for example usage.
+#' If `allRows = TRUE`, then all rows will returned, along with a new
+#' `selected_` column that indicates whether or not the point was selected.
+#' The output from `nearPoints()` will no longer be sorted, but you can
+#' set `addDist = TRUE` to get an additional column that gives the pixel
+#' distance to the pointer.
+#'
+#' @param df A data frame from which to select rows.
+#' @param brush,coordinfo The data from a brush or click/dblclick/hover event
+#'   e.g. `input$plot_brush`, `input$plot_click`.
+#' @param xvar,yvar A string giving the name of the variable on the x or y axis.
+#'   These are only required for base graphics, and must be the name of
+#'   a column in `df`.
+#' @param panelvar1,panelvar2 A string giving the name of a panel variable.
+#'   For expert use only; in most cases these will be automatically
+#'   derived from the ggplot2 spec.
+#' @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 selected or not.
+#' @param threshold A maximum distance (in pixels) to the pointer location.
+#'   Rows in the data frame will be selected if the distance to the pointer is
+#'   less than `threshold`.
+#' @param maxpoints Maximum number of rows to return. If `NULL` (the default),
+#'   will return all rows within the threshold distance.
+#' @param addDist If TRUE, add a column named `dist_` that contains the
+#'   distance from the coordinate to the point, in pixels. When no pointer
+#'   event has yet occurred, the value of `dist_` will be `NA`.
+#' @seealso [plotOutput()] for example usage.
 #' @export
+#' @examples
+#' \dontrun{
+#' # Note that in practice, these examples would need to go in reactives
+#' # or observers.
+#'
+#' # This would select all points within 5 pixels of the click
+#' nearPoints(mtcars, input$plot_click)
+#'
+#' # Select just the nearest point within 10 pixels of the click
+#' nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
+#'
+#' }
 brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
                           panelvar1 = NULL, panelvar2 = NULL,
                           allRows = FALSE) {
@@ -75,11 +92,21 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
   use_x <- grepl("x", brush$direction)
   use_y <- grepl("y", brush$direction)
 
+  # We transitioned to using %||% in Shiny 1.6.0. Previously, these vars could
+  # be NA, because the old %OR% operator recognized NA. These warnings and
+  # the NULL replacement are here just to ease the transition in case anyone is
+  # using NA. We can remove these checks in a future version of Shiny.
+  # https://github.com/rstudio/shiny/pull/3172
+  if (is_na(xvar))      { xvar      <- NULL; warning("xvar should be NULL, not NA.") }
+  if (is_na(yvar))      { yvar      <- NULL; warning("yvar should be NULL, not NA.") }
+  if (is_na(panelvar1)) { panelvar1 <- NULL; warning("panelvar1 should be NULL, not NA.") }
+  if (is_na(panelvar2)) { panelvar2 <- NULL; warning("panelvar2 should be NULL, not NA.") }
+
   # Try to extract vars from brush object
-  xvar      <- xvar      %OR% brush$mapping$x
-  yvar      <- yvar      %OR% brush$mapping$y
-  panelvar1 <- panelvar1 %OR% brush$mapping$panelvar1
-  panelvar2 <- panelvar2 %OR% brush$mapping$panelvar2
+  xvar      <- xvar      %||% brush$mapping$x
+  yvar      <- yvar      %||% brush$mapping$y
+  panelvar1 <- panelvar1 %||% brush$mapping$panelvar1
+  panelvar2 <- panelvar2 %||% brush$mapping$panelvar2
 
   # Filter out x and y values
   keep_rows <- rep(TRUE, nrow(df))
@@ -88,17 +115,14 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
       stop("brushedPoints: not able to automatically infer `xvar` from brush")
     if (!(xvar %in% names(df)))
       stop("brushedPoints: `xvar` ('", xvar ,"')  not in names of input")
-    # Extract data values from the data frame
-    x <- asNumber(df[[xvar]])
-    keep_rows <- keep_rows & (x >= brush$xmin & x <= brush$xmax)
+    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")
     if (!(yvar %in% names(df)))
       stop("brushedPoints: `yvar` ('", yvar ,"') not in names of input")
-    y <- asNumber(df[[yvar]])
-    keep_rows <- keep_rows & (y >= brush$ymin & y <= brush$ymax)
+    keep_rows <- keep_rows & within_brush(df[[yvar]], brush, "y")
   }
 
   # Find which rows are matches for the panel vars (if present)
@@ -194,56 +218,8 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ direction: chr "y"
 
 
-#'Find rows of data that are near a click/hover/double-click
-#'
-#'This function returns rows from a data frame which are near a click, hover, or
-#'double-click, when used with \code{\link{plotOutput}}. The rows will be sorted
-#'by their distance to the mouse event.
-#'
-#'It is also possible for this function to return all rows from the input data
-#'frame, but with an additional column \code{selected_}, which indicates which
-#'rows of the input data frame are selected by the brush (\code{TRUE} for
-#'selected, \code{FALSE} for not-selected). This is enabled by setting
-#'\code{allRows=TRUE} option. If this is used, the resulting data frame will not
-#'be sorted by distance to the mouse event.
-#'
-#'The \code{xvar}, \code{yvar}, \code{panelvar1}, and \code{panelvar2} arguments
-#'specify which columns in the data correspond to the x variable, y variable,
-#'and panel variables of the plot. For example, if your plot is
-#'\code{plot(x=cars$speed, y=cars$dist)}, and your click variable is named
-#'\code{"cars_click"}, then you would use \code{nearPoints(cars,
-#'input$cars_brush, "speed", "dist")}.
-#'
-#'@inheritParams brushedPoints
-#'@param coordinfo The data from a mouse event, such as \code{input$plot_click}.
-#'@param threshold A maxmimum distance to the click point; rows in the data
-#'  frame where the distance to the click is less than \code{threshold} will be
-#'  returned.
-#'@param maxpoints Maximum number of rows to return. If NULL (the default),
-#'  return all rows that are within the threshold distance.
-#'@param addDist If TRUE, add a column named \code{dist_} that contains the
-#'  distance from the coordinate to the point, in pixels. When no mouse event
-#'  has yet occured, the value of \code{dist_} will be \code{NA}.
-#'@param allRows If \code{FALSE} (the default) return a data frame containing
-#'  the selected rows. If \code{TRUE}, the input data frame will have a new
-#'  column, \code{selected_}, which indicates whether the row was inside the
-#'  selected by the mouse event (\code{TRUE}) or not (\code{FALSE}).
-#'
-#'@seealso \code{\link{plotOutput}} for more examples.
-#'
-#' @examples
-#' \dontrun{
-#' # Note that in practice, these examples would need to go in reactives
-#' # or observers.
-#'
-#' # This would select all points within 5 pixels of the click
-#' nearPoints(mtcars, input$plot_click)
-#'
-#' # Select just the nearest point within 10 pixels of the click
-#' nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
-#'
-#' }
-#'@export
+#' @export
+#' @rdname brushedPoints
 nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
                        panelvar1 = NULL, panelvar2 = NULL,
                        threshold = 5, maxpoints = NULL, addDist = FALSE,
@@ -264,11 +240,21 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
     stop("nearPoints requires a click/hover/double-click object with x and y values.")
   }
 
+  # We transitioned to using %||% in Shiny 1.6.0. Previously, these vars could
+  # be NA, because the old %OR% operator recognized NA. These warnings and
+  # the NULL replacement are here just to ease the transition in case anyone is
+  # using NA. We can remove these checks in a future version of Shiny.
+  # https://github.com/rstudio/shiny/pull/3172
+  if (is_na(xvar))      { xvar      <- NULL; warning("xvar should be NULL, not NA.") }
+  if (is_na(yvar))      { yvar      <- NULL; warning("yvar should be NULL, not NA.") }
+  if (is_na(panelvar1)) { panelvar1 <- NULL; warning("panelvar1 should be NULL, not NA.") }
+  if (is_na(panelvar2)) { panelvar2 <- NULL; warning("panelvar2 should be NULL, not NA.") }
+
   # Try to extract vars from coordinfo object
-  xvar      <- xvar      %OR% coordinfo$mapping$x
-  yvar      <- yvar      %OR% coordinfo$mapping$y
-  panelvar1 <- panelvar1 %OR% coordinfo$mapping$panelvar1
-  panelvar2 <- panelvar2 %OR% coordinfo$mapping$panelvar2
+  xvar      <- xvar      %||% coordinfo$mapping$x
+  yvar      <- yvar      %||% coordinfo$mapping$y
+  panelvar1 <- panelvar1 %||% coordinfo$mapping$panelvar1
+  panelvar2 <- panelvar2 %||% coordinfo$mapping$panelvar2
 
   if (is.null(xvar))
     stop("nearPoints: not able to automatically infer `xvar` from coordinfo")
@@ -281,8 +267,8 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
     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 coordinates of the point (in img pixel coordinates)
   point_img <- coordinfo$coords_img
@@ -402,11 +388,27 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 #   ..$ y: NULL
 #  $ .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,17 +1,46 @@
 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")) {
+  # shiny.useragg is an experimental option that isn't officially supported or
+  # documented. It's here in the off chance that someone really wants
+  # to use ragg (say, instead of showtext, for custom font rendering).
+  # In the next shiny release, this option will likely be superseded in
+  # favor of a fully customizable graphics device option
+  if ((getOption('shiny.useragg') %||% FALSE) && is_available("ragg")) {
+    pngfun <- ragg::agg_png
+  } else if (capabilities("aqua")) {
+    # i.e., png(type = 'quartz')
     pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
-      nchar(system.file(package = "Cairo"))) {
+  } else if ((getOption('shiny.usecairo') %||% TRUE) && is_available("Cairo")) {
     pngfun <- Cairo::CairoPNG
   } else {
+    # i.e., png(type = 'cairo')
     pngfun <- grDevices::png
   }
 
-  pngfun(filename=filename, width=width, height=height, res=res, ...)
+  args <- rlang::list2(filename=filename, width=width, height=height, res=res, ...)
+
+  # Set a smarter default for the device's bg argument (based on thematic's global state).
+  # Note that, technically, this is really only needed for CairoPNG, since the other
+  # devices allow their bg arg to be overridden by par(bg=...), which thematic does prior
+  # to plot-time, but it shouldn't hurt to inform other the device directly as well
+  if (is.null(args$bg) && isNamespaceLoaded("thematic")) {
+    args$bg <- getThematicOption("bg", "white")
+    # auto vals aren't resolved until plot time, so if we see one, resolve it
+    if (isTRUE("auto" == args$bg)) {
+      args$bg <- getCurrentOutputInfo()[["bg"]]()
+    }
+  }
+
+  # Handle both bg and background device arg
+  # https://github.com/r-lib/ragg/issues/35
+  fmls <- names(formals(pngfun))
+  if (("background" %in% fmls) && (!"bg" %in% fmls)) {
+    if (is.null(args$background)) {
+      args$background <- args$bg
+    }
+    args$bg <- NULL
+  }
+
+  do.call(pngfun, args)
   # Call plot.new() so that even if no plotting operations are performed at
   # least we have a blank background. N.B. we need to set the margin to 0
   # temporarily before plot.new() because when the plot size is small (e.g.
@@ -31,29 +60,29 @@ startPNG <- function(filename, width, height, res, ...) {
 #' 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
+#' 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 \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
+#' 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, \code{Cairo()} provides output that looks worse than
-#' \code{png()}. To disable Cairo output for an app, use
-#' \code{options(shiny.usecairo=FALSE)}.
+#' 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 \code{.png}.
+#'   extension `.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[grDevices]{png}}. Note that this affects the resolution of PNG rendering in
+#'   [grDevices::png()]. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
-#' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
+#' @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'),
@@ -65,7 +94,6 @@ plotPNG <- function(func, filename=tempfile(fileext='.png'),
   filename
 }
 
-#' @importFrom grDevices dev.set dev.cur
 createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
   force(which)
 

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,14 +36,25 @@
 #'
 #' }
 #'
-#' @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, ...) {
 
   value <- restoreInput(id = inputId, default = NULL)
 
   tags$button(id=inputId,
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
     type="button",
     class="btn btn-default action-button",
     `data-val` = value,

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) {
 
@@ -32,7 +36,7 @@ checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
     inputTag$attribs$checked <- "checked"
 
   div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
     div(class = "checkbox",
       tags$label(inputTag, tags$span(label))
     )

R/input-checkboxgroup.R

@@ -7,25 +7,25 @@
 #' @inheritParams textInput
 #' @param choices List of values to show checkboxes for. If elements of the list
 #'   are named then that name rather than the value is displayed to the user. If
-#'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
+#'   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, \code{choiceNames} and \code{choiceValues}
+#'   choice (for this reason, `choiceNames` and `choiceValues`
 #'   must have the same length). If either of these arguments is
-#'   provided, then the other \emph{must} be provided and \code{choices}
-#'   \emph{must not} be provided. The advantage of using both of these over
-#'   a named list for \code{choices} is that \code{choiceNames} allows any
+#'   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
@@ -67,6 +67,9 @@
 #'
 #' shinyApp(ui, server)
 #' }
+#' @section Server value:
+#' Character vector of values corresponding to the boxes that are checked.
+#'
 #' @export
 checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
   inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
@@ -91,10 +94,14 @@ checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
     divClass <- paste(divClass, "shiny-input-container-inline")
 
   # return label and select tag
+  inputLabel <- shinyInputLabel(inputId, label)
   tags$div(id = inputId,
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
     class = divClass,
-    controlLabel(inputId, label),
+    # https://www.w3.org/TR/wai-aria-practices/examples/checkbox/checkbox-1/checkbox-1.html
+    role = "group",
+    `aria-labelledby` = inputLabel$attribs$id,
+    inputLabel,
     options
   )
 }

R/input-date.R

@@ -3,32 +3,32 @@
 #' 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 (1-12)
-#'   \item \code{M} Abbreviated month name
-#'   \item \code{MM} Full month name
-#'   \item \code{dd} Day of month with leading zero
-#'   \item \code{d} Day of month without leading zero
-#'   \item \code{D} Abbreviated weekday name
-#'   \item \code{DD} Full weekday name
+#'   \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
+#'   `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"}.
+#'   `"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
@@ -44,12 +44,12 @@
 #' @param autoclose Whether or not to close the datepicker immediately when a
 #'   date is selected.
 #' @param datesdisabled Which dates should be disabled. Either a Date object,
-#' or a string in \code{yyyy-mm-dd} format.
+#' 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
@@ -78,7 +78,7 @@
 #'
 #'   # 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"))
@@ -86,30 +86,34 @@
 #'
 #' 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, autoclose = TRUE,
   datesdisabled = NULL, daysofweekdisabled = NULL) {
 
-  # If value is a date object, convert it to a string with yyyy-mm-dd format
-  # Same for min and max
-  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
-  if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
-  if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
-  if (inherits(datesdisabled, "Date")) {
-      datesdisabled <- format(datesdisabled,   "%Y-%m-%d")
-  }
+  value <- dateYMD(value, "value")
+  min <- dateYMD(min, "min")
+  max <- dateYMD(max, "max")
+  datesdisabled <- dateYMD(datesdisabled, "datesdisabled")
 
   value <- restoreInput(id = inputId, default = value)
 
   tags$div(id = inputId,
     class = "shiny-date-input form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
 
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     tags$input(type = "text",
                class = "form-control",
+               # `aria-labelledby` attribute is required for accessibility to avoid doubled labels (#2951).
+               `aria-labelledby` = paste0(inputId, "-label"),
+               # title attribute is announced for screen readers for date format.
+               title = paste("Date format:", format),
                `data-date-language` = language,
                `data-date-week-start` = weekstart,
                `data-date-format` = format,
@@ -124,19 +128,49 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
                `data-date-days-of-week-disabled` =
                    jsonlite::toJSON(daysofweekdisabled, null = 'null')
     ),
-    datePickerDependency
+    datePickerDependency()
   )
 }
 
-datePickerDependency <- htmlDependency(
-  "bootstrap-datepicker", "1.6.4", c(href = "shared/datepicker"),
-  script = "js/bootstrap-datepicker.min.js",
-  stylesheet = "css/bootstrap-datepicker3.min.css",
-  # Need to enable noConflict mode. See #1346.
-  head = "<script>
-(function() {
-  var datepicker = $.fn.datepicker.noConflict();
-  $.fn.bsDatepicker = datepicker;
-})();
-</script>"
-)
+
+datePickerVersion <- "1.9.0"
+
+datePickerDependency <- function(theme) {
+  list(
+    htmlDependency(
+      name = "bootstrap-datepicker-js",
+      version = datePickerVersion,
+      src = c(href = "shared/datepicker"),
+      script = if (getOption("shiny.minified", TRUE)) "js/bootstrap-datepicker.min.js"
+               else                                   "js/bootstrap-datepicker.js",
+      # Need to enable noConflict mode. See #1346.
+      head = "<script>(function() {
+        var datepicker = $.fn.datepicker.noConflict();
+        $.fn.bsDatepicker = datepicker;
+      })();
+     </script>"
+    ),
+    bslib::bs_dependency_defer(datePickerCSS)
+  )
+}
+
+datePickerCSS <- function(theme) {
+  if (!is_bs_theme(theme)) {
+    return(htmlDependency(
+      name = "bootstrap-datepicker-css",
+      version = datePickerVersion,
+      src = c(href = "shared/datepicker"),
+      stylesheet = "css/bootstrap-datepicker3.min.css"
+    ))
+  }
+
+  scss_file <- system.file(package = "shiny", "www/shared/datepicker/scss/build3.scss")
+
+  bslib::bs_dependency(
+    input = sass::sass_file(scss_file),
+    theme = theme,
+    name = "bootstrap-datepicker",
+    version = datePickerVersion,
+    cache_key_extra = shinyPackageVersion()
+  )
+}

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 (1-12)
-#'   \item \code{M} Abbreviated month name
-#'   \item \code{MM} Full month name
-#'   \item \code{dd} Day of month with leading zero
-#'   \item \code{d} Day of month without leading zero
-#'   \item \code{D} Abbreviated weekday name
-#'   \item \code{DD} Full weekday name
+#'   \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,18 +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,
     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]]
@@ -90,14 +92,18 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
   attachDependencies(
     div(id = inputId,
       class = "shiny-date-range-input form-group shiny-input-container",
-      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+      style = css(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",
+          # `aria-labelledby` attribute is required for accessibility to avoid doubled labels (#2951).
+          `aria-labelledby` = paste0(inputId, "-label"),
+          # title attribute is announced for screen readers for date format.
+          title = paste("Date format:", format),
           `data-date-language` = language,
           `data-date-week-start` = weekstart,
           `data-date-format` = format,
@@ -107,10 +113,19 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           `data-initial-date` = start,
           `data-date-autoclose` = if (autoclose) "true" else "false"
         ),
-        span(class = "input-group-addon", separator),
+        # 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
+          )
+        ),
         tags$input(
-          class = "input-sm form-control",
+          class = "form-control",
           type = "text",
+          # `aria-labelledby` attribute is required for accessibility to avoid doubled labels (#2951).
+          `aria-labelledby` = paste0(inputId, "-label"),
+          # title attribute is announced for screen readers for date format.
+          title = paste("Date format:", format),
           `data-date-language` = language,
           `data-date-week-start` = weekstart,
           `data-date-format` = format,
@@ -122,6 +137,6 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
         )
       )
     ),
-    datePickerDependency
+    datePickerDependency()
   )
 }

R/input-file.R

@@ -3,30 +3,23 @@
 #' 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.
@@ -38,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(
@@ -55,22 +42,35 @@
 #'
 #' 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, buttonLabel = "Browse...", placeholder = "No file selected") {
@@ -91,7 +91,8 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
     id = inputId,
     name = inputId,
     type = "file",
-    style = "display: none;",
+    # Don't use "display: none;" style, which causes keyboard accessibility issue; instead use the following workaround: https://css-tricks.com/places-its-tempting-to-use-display-none-but-dont/
+    style = "position: absolute !important; top: -99999px !important; left: -99999px !important;",
     `data-restore` = restoredValue
   )
 
@@ -102,11 +103,12 @@ 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),
+    style = css(width = validateCssUnit(width)),
+    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",
           buttonLabel,
           inputTag
@@ -119,7 +121,7 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
 
     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) {
@@ -41,8 +45,8 @@ numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
     inputTag$attribs$step = step
 
   div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label, `for` = inputId),
+    style = css(width = validateCssUnit(width)),
+    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
@@ -29,8 +33,8 @@
 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),
+    style = css(width = validateCssUnit(width)),
+    shinyInputLabel(inputId, label),
     tags$input(id = inputId, type="password", class="form-control", value=value,
                placeholder = placeholder)
   )

R/input-radiobuttons.R

@@ -3,33 +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
+#' 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 \code{c("None selected" = "")}.
+#' 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). If
-#'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
-#'   must not be provided, and vice-versa. The values should be strings; other
-#'   types (such as logicals and numbers) will be coerced to strings.
-#' @param selected The initially selected value (if not specified then defaults
-#'   to the first value)
-#' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
+#'   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 it
+#'   defaults to the first item in `choices`. To start with no items selected,
+#'   use `character(0)`.
+#' @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, \code{choiceNames} and \code{choiceValues} must have the same
-#'   length). If either of these arguments is provided, then the other
-#'   \emph{must} be provided and \code{choices} \emph{must not} be provided. The
-#'   advantage of using both of these over a named list for \code{choices} is
-#'   that \code{choiceNames} allows any type of UI object to be passed through
-#'   (tag objects, icons, HTML code, ...), instead of just simple text. See
-#'   Examples.
+#'   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
@@ -80,6 +80,11 @@
 #'
 #' shinyApp(ui, server)
 #' }
+#'
+#' @section Server value:
+#'
+#'   A character string containing the value of the selected button.
+#'
 #' @export
 radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
   inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
@@ -99,10 +104,14 @@ radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
   divClass <- "form-group shiny-input-radiogroup shiny-input-container"
   if (inline) divClass <- paste(divClass, "shiny-input-container-inline")
 
+  inputLabel <- shinyInputLabel(inputId, label)
   tags$div(id = inputId,
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
     class = divClass,
-    controlLabel(inputId, label),
+    # https://www.w3.org/TR/2017/WD-wai-aria-practices-1.1-20170628/examples/radio/radio-1/radio-1.html
+    role = "radiogroup",
+    `aria-labelledby` = inputLabel$attribs$id,
+    inputLabel,
     options
   )
 }

R/input-select.R

@@ -3,37 +3,44 @@
 #' Create a select list that can be used to choose a single or multiple items
 #' from a list of values.
 #'
-#' By default, \code{selectInput()} and \code{selectizeInput()} use the
-#' JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/selectize/selectize.js}) 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))`
+#'
+#' **Performance note:** `selectInput()` and `selectizeInput()` can slow down
+#' significantly when thousands of choices are used; with legacy browsers like
+#' Internet Explorer, the user interface may hang for many seconds. For large
+#' numbers of choices, Shiny offers a "server-side selectize" option that
+#' massively improves performance and efficiency; see
+#' [this selectize article](https://shiny.rstudio.com/articles/selectize.html)
+#' on the Shiny Dev Center for details.
 #'
 #' @inheritParams textInput
 #' @param choices List of values to select from. If elements of the list are
-#'   named, then that name rather than the value is displayed to the user.
-#'   This can also be a named list whose elements are (either named or
-#'   unnamed) lists or vectors. If this is the case, the outermost names
-#'   will be used as the "optgroup" label for the elements in the respective
-#'   sublist. This allows you to group and label similar choices. See the
-#'   example section for a small demo of this feature.
-#' @param selected The initially selected value (or multiple values if
-#'   \code{multiple = TRUE}). If not specified then defaults to the first value
-#'   for single-select lists and no values for multiple select lists.
+#'   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}} \code{\link{varSelectInput}}
+#' @seealso [updateSelectInput()] [varSelectInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -55,7 +62,7 @@
 #'   }
 #' )
 #'
-#' # demoing optgroup support in the `choices` arg
+#' # demoing group support in the `choices` arg
 #' shinyApp(
 #'   ui = fluidPage(
 #'     selectInput("state", "Choose a state:",
@@ -72,6 +79,11 @@
 #'   }
 #' )
 #' }
+#'
+#' @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,
@@ -96,7 +108,7 @@ selectInput <- function(inputId, label, choices, selected = NULL,
     id = inputId,
     class = if (!selectize) "form-control",
     size = size,
-    selectOptions(choices, selected)
+    selectOptions(choices, selected, inputId, selectize)
   )
   if (multiple)
     selectTag$attribs$multiple <- "multiple"
@@ -104,8 +116,8 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   # return label and select tag
   res <- div(
     class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    controlLabel(inputId, label),
+    style = css(width = validateCssUnit(width)),
+    shinyInputLabel(inputId, label),
     div(selectTag)
   )
 
@@ -121,16 +133,22 @@ firstChoice <- function(choices) {
 }
 
 # Create tags for each of the options; use <optgroup> if necessary.
-# This returns a HTML string instead of tags, because of the 'selected'
-# attribute.
-selectOptions <- function(choices, selected = NULL) {
+# This returns a HTML string instead of tags for performance reasons.
+selectOptions <- function(choices, selected = NULL, inputId, perfWarning = FALSE) {
+  if (length(choices) >= 1000) {
+    warning("The select input \"", inputId, "\" contains a large number of ",
+      "options; consider using server-side selectize for massively improved ",
+      "performance. See the Details section of the ?selectizeInput help topic.",
+      call. = FALSE)
+  }
+
   html <- mapply(choices, names(choices), FUN = function(choice, label) {
     if (is.list(choice)) {
       # If sub-list, create an optgroup and recurse into the sublist
       sprintf(
         '<optgroup label="%s">\n%s\n</optgroup>',
         htmlEscape(label, TRUE),
-        selectOptions(choice, selected)
+        selectOptions(choice, selected, inputId, perfWarning)
       )
 
     } else {
@@ -153,21 +171,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[base]{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(
@@ -179,24 +197,30 @@ selectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
 
 # given a select input and its id, selectize it
 selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
+  if (length(options) == 0) {
+    # For NULL and empty unnamed list, replace with an empty named list, so that
+    # it will get translated to {} in JSON later on.
+    options <- empty_named_list()
+  }
+
+  # Make sure accessibility plugin is included
+  if (!('selectize-plugin-a11y' %in% options$plugins)) {
+    options$plugins <- c(options$plugins, list('selectize-plugin-a11y'))
+  }
+
   res <- checkAsIs(options)
 
-  selectizeDep <- htmlDependency(
-    "selectize", "0.11.2", c(href = "shared/selectize"),
-    stylesheet = "css/selectize.bootstrap3.css",
-    head = format(tagList(
-      HTML('<!--[if lt IE 9]>'),
-      tags$script(src = 'shared/selectize/js/es5-shim.min.js'),
-      HTML('<![endif]-->'),
-      tags$script(src = 'shared/selectize/js/selectize.min.js')
-    ))
-  )
+  deps <- list(selectizeDependency())
 
   if ('drag_drop' %in% options$plugins) {
-    selectizeDep <- list(selectizeDep, htmlDependency(
-      'jqueryui', '1.12.1', c(href = 'shared/jqueryui'),
-      script = 'jquery-ui.min.js'
-    ))
+    deps <- c(
+      deps,
+      list(htmlDependency(
+        'jqueryui', '1.12.1',
+        c(href = 'shared/jqueryui'),
+        script = 'jquery-ui.min.js'
+      ))
+    )
   }
 
   # Insert script on same level as <select> tag
@@ -206,18 +230,64 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
       type = 'application/json',
       `data-for` = inputId, `data-nonempty` = if (nonempty) '',
       `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
-      if (length(res$options)) HTML(toJSON(res$options)) else '{}'
+      HTML(toJSON(res$options))
     )
   )
 
-  attachDependencies(select, selectizeDep)
+  attachDependencies(select, deps)
 }
 
 
+selectizeDependency <- function() {
+  bslib::bs_dependency_defer(selectizeDependencyFunc)
+}
 
+selectizeDependencyFunc <- function(theme) {
+  selectizeVersion <- "0.12.4"
+  if (!is_bs_theme(theme)) {
+    return(selectizeStaticDependency(selectizeVersion))
+  }
 
+  selectizeDir <- system.file(package = "shiny", "www/shared/selectize/")
+  stylesheet <- file.path(
+    selectizeDir, "scss",
+    if ("3" %in% bslib::theme_version(theme)) {
+      "selectize.bootstrap3.scss"
+    } else {
+      "selectize.bootstrap4.scss"
+    }
+  )
+  # It'd be cleaner to ship the JS in a separate, href-based,
+  # HTML dependency (which we currently do for other themable widgets),
+  # but DT, crosstalk, and maybe other pkgs include selectize JS/CSS
+  # in HTML dependency named selectize, so if we were to change that
+  # name, the JS/CSS would be loaded/included twice, which leads to
+  # strange issues, especially since we now include a 3rd party
+  # accessibility plugin https://github.com/rstudio/shiny/pull/3153
+  script <- file.path(
+    selectizeDir, c("js/selectize.min.js", "accessibility/js/selectize-plugin-a11y.min.js")
+  )
+  bslib::bs_dependency(
+    input = sass::sass_file(stylesheet),
+    theme = theme,
+    name = "selectize",
+    version = selectizeVersion,
+    cache_key_extra = shinyPackageVersion(),
+    .dep_args = list(script = script)
+  )
+}
 
-
+selectizeStaticDependency <- function(version) {
+  htmlDependency(
+    "selectize", version,
+    src = c(href = "shared/selectize"),
+    stylesheet = "css/selectize.bootstrap3.css",
+    script = c(
+      "js/selectize.min.js",
+      "accessibility/js/selectize-plugin-a11y.min.js"
+    )
+  )
+}
 
 
 #' Select variables from a data frame
@@ -225,30 +295,31 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 #' Create a select list that can be used to choose a single or multiple items
 #' from the column names of a data frame.
 #'
-#' The resulting server \code{input} value will be returned as:
-#' \itemize{
-#'   \item a symbol if \code{multiple = FALSE}.  The \code{input} value should be
-#'         used with rlang's \code{\link[rlang]{!!}}. For example,
-#'         \code{ggplot2::aes(!!input$variable)}.
-#'   \item a list of symbols if \code{multiple = TRUE}. The \code{input} value
-#'         should be used with rlang's \code{\link[rlang]{!!!}} to expand
-#'         the symbol list as individual arguments. For example,
-#'         \code{dplyr::select(mtcars, !!!input$variabls)} which is
-#'         equivalent to \code{dplyr::select(mtcars, !!input$variabls[[1]], !!input$variabls[[2]], ..., !!input$variabls[[length(input$variabls)]])}.
-#' }
-#'
-#' By default, \code{varSelectInput()} and \code{selectizeInput()} use the
+#' By default, `varSelectInput()` and `selectizeInput()` use the
 #' JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
+#' (<https://github.com/selectize/selectize.js>) to instead of the basic
 #' select input element. To use the standard HTML select input element, use
-#' \code{selectInput()} with \code{selectize=FALSE}.
+#' `selectInput()` with `selectize=FALSE`.
 #'
 #' @inheritParams selectInput
-#' @param data A data frame. Used to retrieve the column names as choices for a \code{\link{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 \code{\link{updateSelectInput}}
+#' @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
@@ -321,21 +392,21 @@ varSelectInput <- function(
 
 
 #' @rdname varSelectInput
-#' @param ... Arguments passed to \code{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 \code{\link[base]{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 variable selectize input created from \code{varSelectizeInput()} allows
+#' @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
-#'   \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
 varSelectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
   selectizeIt(

R/input-slider.R

@@ -1,52 +1,51 @@
 #' Slider Input Widget
 #'
-#' Constructs a slider widget to select a numeric value from a range.
+#' Constructs a slider widget to select a number, date, or date-time from a
+#' range.
 #'
 #' @inheritParams textInput
-#' @param min The minimum value (inclusive) that can be selected.
-#' @param max The maximum value (inclusive) that can be selected.
-#' @param value The initial value of the slider. A numeric vector of length one
-#'   will create a regular slider; a numeric vector of length two will create a
-#'   double-ended range slider. A warning will be issued if the value doesn't
-#'   fit between \code{min} and \code{max}.
+#' @param min,max The minimum and maximum values (inclusive) that can be
+#'   selected.
+#' @param value The initial value of the slider, either a number, a date
+#'   (class Date), or a date-time (class POSIXt). A length one vector will
+#'   create a regular slider; a length two vector will create a double-ended
+#'   range slider. Must lie 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. Either `NULL`, the default, which uses a heuristic to determine the
+#'   step size or a single number. If the values are dates, `step` is in days;
+#'   if the values are date-times, `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[base]{strftime}} function. For Dates, the default is \code{"\%F"}
-#'   (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"}
-#'   (like \code{"2015-07-01 15:32:10"}).
+#'   [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
@@ -70,23 +69,22 @@
 #' # Complete app with UI and server components
 #' shinyApp(ui, server)
 #' }
+#'
+#' @section Server value:
+#' A number, date, or date-time (depending on the class of `value`), or
+#' in the case of slider range, a vector of two numbers/dates/date-times.
+#'
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
-                        round = FALSE, format = NULL, locale = NULL,
-                        ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
-                        pre = NULL, post = NULL, timeFormat = NULL,
-                        timezone = NULL, dragRange = TRUE)
-{
-  if (!missing(format)) {
-    shinyDeprecated(msg = "The `format` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
-                    version = "0.10.2.2")
-  }
-  if (!missing(locale)) {
-    shinyDeprecated(msg = "The `locale` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
-                    version = "0.10.2.2")
-  }
+                        round = FALSE, ticks = TRUE, animate = FALSE,
+                        width = NULL, sep = ",", pre = NULL, post = NULL,
+                        timeFormat = NULL, timezone = NULL, dragRange = TRUE) {
 
-  dataType <- getSliderType(min, max, value)
+  # Force required arguments for maximally informative errors
+  inputId; label; min; max; value
+
+  validate_slider_value(min, max, value, "sliderInput")
+  dataType <- slider_type(value)
 
   if (is.null(timeFormat)) {
     timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
@@ -140,6 +138,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   sliderProps <- dropNulls(list(
     class = "js-range-slider",
     id = inputId,
+    `data-skin` = "shiny",
     `data-type` = if (length(value) > 1) "double",
     `data-min` = formatNoSci(min),
     `data-max` = formatNoSci(max),
@@ -171,8 +170,8 @@ 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),
+    style = css(width = validateCssUnit(width)),
+    shinyInputLabel(inputId, label),
     do.call(tags$input, sliderProps)
   )
 
@@ -201,20 +200,64 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     )
   }
 
-  dep <- list(
-    htmlDependency("ionrangeslider", "2.1.6", c(href="shared/ionrangeslider"),
-      script = "js/ion.rangeSlider.min.js",
-      # ion.rangeSlider also needs normalize.css, which is already included in
-      # Bootstrap.
-      stylesheet = c("css/ion.rangeSlider.css",
-                     "css/ion.rangeSlider.skinShiny.css")
+  attachDependencies(sliderTag, ionRangeSliderDependency())
+}
+
+
+ionRangeSliderVersion <- "2.3.1"
+
+ionRangeSliderDependency <- function() {
+  list(
+    # ion.rangeSlider also needs normalize.css, which is already included in Bootstrap.
+    htmlDependency(
+      "ionrangeslider-javascript", ionRangeSliderVersion,
+      src = c(href = "shared/ionrangeslider"),
+      script = "js/ion.rangeSlider.min.js"
     ),
-    htmlDependency("strftime", "0.9.2", c(href="shared/strftime"),
+    htmlDependency(
+      "strftime", "0.9.2",
+      src = c(href = "shared/strftime"),
       script = "strftime-min.js"
+    ),
+    bslib::bs_dependency_defer(ionRangeSliderDependencyCSS)
+  )
+}
+
+ionRangeSliderDependencyCSS <- function(theme) {
+  if (!is_bs_theme(theme)) {
+    return(htmlDependency(
+      "ionrangeslider-css",
+      ionRangeSliderVersion,
+      src = c(href = "shared/ionrangeslider"),
+      stylesheet = "css/ion.rangeSlider.css"
+    ))
+  }
+
+  # Remap some variable names for ionRangeSlider's scss
+  sass_input <- list(
+    list(
+      # The bootswatch materia theme sets $input-bg: transparent;
+      # which is an issue for the slider's handle(s) (#3130)
+      bg = "if(alpha($input-bg)==0, $body-bg, $input-bg)",
+      fg = sprintf(
+        "if(alpha($input-color)==0, $%s, $input-color)",
+        if ("3" %in% bslib::theme_version(theme)) "text-color" else "body-color"
+      ),
+      accent = "$component-active-bg",
+      `font-family` = "$font-family-base"
+    ),
+    sass::sass_file(
+      system.file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss")
     )
   )
 
-  attachDependencies(sliderTag, dep)
+  bslib::bs_dependency(
+    input = sass_input,
+    theme = theme,
+    name = "ionRangeSlider",
+    version = ionRangeSliderVersion,
+    cache_key_extra = shinyPackageVersion()
+  )
 }
 
 hasDecimals <- function(value) {
@@ -222,7 +265,6 @@ 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)
@@ -250,16 +292,55 @@ findStepSize <- function(min, max, step) {
 }
 
 
+# Throw a warning if ever `value` is not in the [`min`, `max`] range
+validate_slider_value <- function(min, max, value, fun) {
+  if (!is_slider_type(min) || length(min) != 1 || is_na(min)) {
+    rlang::abort("sliderInput(min) must be a single number, Date, or POSIXct")
+  }
+  if (!is_slider_type(min) || length(max) != 1 || is_na(max)) {
+    rlang::abort("sliderInput(value) must be a single number, Date, or POSIXct")
+  }
+  if (!is_slider_type(value) || !length(value) %in% c(1, 2) || any(is_na(value))) {
+    rlang::abort(
+      "sliderInput(value) must be a single or pair of numbers, Dates, or POSIXcts"
+    )
+  }
+
+  if (!identical(class(min), class(value)) || !identical(class(max), class(value))) {
+    rlang::abort(c(
+      "Type mismatch for `min`, `max`, and `value`.",
+      i = "All values must have same type: either numeric, Date, or POSIXt."
+    ))
+  }
+
+  if (min(value) < min || max(value) > max) {
+    rlang::abort("`value` does not lie within [min, max]")
+  }
+}
+
+is_slider_type <- function(x) {
+  is.numeric(x) || inherits(x, "Date") || inherits(x, "POSIXct")
+}
+slider_type <- function(x) {
+  if (is.numeric(x)) {
+    "number"
+  } else if (inherits(x, "Date")) {
+    "date"
+  } else if (inherits(x, "POSIXct")) {
+    "datetime"
+  }
+}
+
 #' @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

@@ -3,30 +3,30 @@
 #' Create a submit button for an app. Apps that include a submit
 #' button do not automatically update their outputs when inputs change,
 #' rather they wait until the user explicitly clicks the submit button.
-#' The use of \code{submitButton} is generally discouraged in favor of
-#' the more versatile \code{\link{actionButton}} (see details below).
+#' 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
-#' \code{\link{actionButton}} instead of \code{submitButton} when you
+#' [actionButton()] instead of `submitButton` when you
 #' want to delay a reaction.
-#' See \href{http://shiny.rstudio.com/articles/action-buttons.html}{this
-#' article} for more information (including a demo of how to "translate"
-#' code using a \code{submitButton} to code using an \code{actionButton}).
+#' See [this
+#' article](https://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 \emph{two} submit buttons in the same app,
+#' 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 \code{\link{renderUI}}
-#' or \code{\link{insertUI}}) will not work.
+#' 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
@@ -58,7 +58,7 @@ submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
     tags$button(
       type="submit",
       class="btn btn-primary",
-      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+      style = css(width = validateCssUnit(width)),
       list(icon, text)
     )
   )

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) {
@@ -35,8 +40,8 @@ textInput <- function(inputId, label, value = "", width = NULL,
   value <- restoreInput(id = inputId, default = value)
 
   div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label, `for` = inputId),
+    style = css(width = validateCssUnit(width)),
+    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) {
@@ -44,18 +50,16 @@ textAreaInput <- function(inputId, label, value = "", width = NULL, height = NUL
     resize <- match.arg(resize, c("both", "none", "vertical", "horizontal"))
   }
 
-  style <- paste(
-    if (!is.null(width))  paste0("width: ",  validateCssUnit(width),  ";"),
-    if (!is.null(height)) paste0("height: ", validateCssUnit(height), ";"),
-    if (!is.null(resize)) paste0("resize: ", resize, ";")
+  style <- css(
+    # The width is specified on the parent div.
+    width = if (!is.null(width)) "width: 100%;",
+    height = validateCssUnit(height),
+    resize = resize
   )
 
-  # Workaround for tag attribute=character(0) bug:
-  #   https://github.com/rstudio/htmltools/issues/65
-  if (length(style) == 0) style <- NULL
-
   div(class = "form-group shiny-input-container",
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     tags$textarea(
       id = inputId,
       class = "form-control",

R/input-utils.R

@@ -1,5 +1,12 @@
-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",
+    # `id` attribute is required for `aria-labelledby` used by screen readers:
+    id = paste0(inputId, "-label"),
+    `for` = inputId
+  )
 }
 
 # This function takes in either a list or vector for `choices` (and
@@ -85,45 +92,83 @@ generateOptions <- function(inputId, selected, inline, type = 'checkbox',
   div(class = "shiny-options-group", options)
 }
 
+# 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
+}
 
-# Takes a vector or list, and adds names (same as the value) to any entries
+# 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) {
-  # Take a vector or list, and convert to list. Also, if any children are
-  # vectors with length > 1, convert those to list. If the list is unnamed,
-  # convert it to a named list with blank names.
-  listify <- function(obj) {
-    # If a list/vector is unnamed, give it blank names
-    makeNamed <- function(x) {
-      if (is.null(names(x))) names(x) <- character(length(x))
-      x
-    }
-
-    res <- lapply(obj, function(val) {
-      if (is.list(val))
-        listify(val)
-      else if (length(val) == 1 && is.null(names(val)))
-        as.character(val)
-      else
-        makeNamed(as.list(val))
-    })
-
-    makeNamed(res)
+  if (hasGroups(choices)) {
+    processGroupedChoices(choices)
+  } else {
+    processFlatChoices(choices)
   }
-
-  choices <- listify(choices)
-  if (length(choices) == 0) return(choices)
-
-  # Recurse into any subgroups
-  choices <- mapply(choices, names(choices), FUN = function(choice, name) {
-    if (!is.list(choice)) return(choice)
-    if (name == "") stop('All sub-lists in "choices" must be named.')
-    choicesWithNames(choice)
-  }, SIMPLIFY = FALSE)
-
-  # default missing names to choice values
-  missing <- names(choices) == ""
-  names(choices)[missing] <- as.character(choices)[missing]
-
-  choices
 }

R/insert-tab.R

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

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(...,

R/knitr.R

@@ -0,0 +1,80 @@
+#' Knitr S3 methods
+#'
+#' These S3 methods are necessary to help Shiny applications and UI chunks embed
+#' themselves in knitr/rmarkdown documents.
+#'
+#' @name knitr_methods
+#' @param x Object to knit_print
+#' @param ... Additional knit_print arguments
+NULL
+
+# If there's an R Markdown runtime option set but it isn't set to Shiny, then
+# return a warning indicating the runtime is inappropriate for this object.
+# Returns NULL in all other cases.
+shiny_rmd_warning <- function() {
+  runtime <- knitr::opts_knit$get("rmarkdown.runtime")
+  if (!is.null(runtime) && runtime != "shiny")
+    # note that the RStudio IDE checks for this specific string to detect Shiny
+    # applications in static document
+    list(structure(
+      "Shiny application in a static R Markdown document",
+      class = "rmd_warning"))
+  else
+    NULL
+}
+
+#' @rdname knitr_methods
+knit_print.shiny.appobj <- function(x, ...) {
+  opts <- x$options %||% list()
+  width <- if (is.null(opts$width)) "100%" else opts$width
+  height <- if (is.null(opts$height)) "400" else opts$height
+
+  runtime <- knitr::opts_knit$get("rmarkdown.runtime")
+  if (!is.null(runtime) && runtime != "shiny") {
+    # If not rendering to a Shiny document, create a box exactly the same
+    # dimensions as the Shiny app would have had (so the document continues to
+    # flow as it would have with the app), and display a diagnostic message
+    width <- validateCssUnit(width)
+    height <- validateCssUnit(height)
+    output <- tags$div(
+      style=paste("width:", width, "; height:", height, "; text-align: center;",
+                  "box-sizing: border-box;", "-moz-box-sizing: border-box;",
+                  "-webkit-box-sizing: border-box;"),
+      class="muted well",
+      "Shiny applications not supported in static R Markdown documents")
+  }
+  else {
+    path <- addSubApp(x)
+    output <- deferredIFrame(path, width, height)
+  }
+
+  # If embedded Shiny apps ever have JS/CSS dependencies (like pym.js) we'll
+  # need to grab those and put them in meta, like in knit_print.shiny.tag. But
+  # for now it's not an issue, so just return the HTML and warning.
+
+  knitr::asis_output(htmlPreserve(format(output, indent=FALSE)),
+                     meta = shiny_rmd_warning(), cacheable = FALSE)
+}
+
+# Let us use a nicer syntax in knitr chunks than literally
+# calling output$value <- renderFoo(...) and fooOutput().
+#' @rdname knitr_methods
+#' @param inline Whether the object is printed inline.
+knit_print.shiny.render.function <- function(x, ..., inline = FALSE) {
+  x <- htmltools::as.tags(x, inline = inline)
+  output <- knitr::knit_print(tagList(x))
+  attr(output, "knit_cacheable") <- FALSE
+  attr(output, "knit_meta") <- append(attr(output, "knit_meta"),
+                                      shiny_rmd_warning())
+  output
+}
+
+# Lets us drop reactive expressions directly into a knitr chunk and have the
+# value printed out! Nice for teaching if nothing else.
+#' @rdname knitr_methods
+knit_print.reactive <- function(x, ..., inline = FALSE) {
+  renderFunc <- if (inline) renderText else renderPrint
+  knitr::knit_print(renderFunc({
+    x()
+  }), inline = inline)
+}

R/map.R

@@ -1,71 +1,51 @@
-# TESTS
-# Simple set/get
-# Simple remove
-# Simple containsKey
-# Simple keys
-# Simple values
-# Simple clear
-# Get of unknown key returns NULL
-# Remove of unknown key does nothing
-# Setting a key twice always results in last-one-wins
-# /TESTS
+#' @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

@@ -3,7 +3,27 @@ NULL
 
 reactLogHandler <- function(req) {
   if (! rLog$isLogging()) {
-    return(NULL)
+    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 (identical(req$PATH_INFO, "/reactlog/mark")) {
@@ -37,6 +57,7 @@ reactLogHandler <- function(req) {
     ))
 
   } else {
+    # continue on like normal
     return(NULL)
   }
 }

R/middleware.R

@@ -14,7 +14,26 @@
 # returns `NULL`, or an `httpResponse`.
 #
 ## ------------------------------------------------------------------------
-httpResponse <- function(status = 200,
+
+#' Create an HTTP response object
+#'
+#' @param status HTTP status code for the response.
+#' @param content_type The value for the `Content-Type` header.
+#' @param content The body of the response, given as a single-element character
+#'   vector (will be encoded as UTF-8) or a raw vector.
+#' @param headers A named list of additional headers to include. Do not include
+#'   `Content-Length` (as it is automatically calculated) or `Content-Type` (the
+#'   `content_type` argument is used instead).
+#'
+#' @examples
+#' httpResponse(status = 405L,
+#'   content_type = "text/plain",
+#'   content = "The requested method was not allowed"
+#' )
+#'
+#' @keywords internal
+#' @export
+httpResponse <- function(status = 200L,
                          content_type = "text/html; charset=UTF-8",
                          content = "",
                          headers = list()) {
@@ -199,6 +218,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)
@@ -287,7 +309,7 @@ HandlerManager <- R6Class("HandlerManager",
     createHttpuvApp = function() {
       list(
         onHeaders = function(req) {
-          maxSize <- getOption('shiny.maxRequestSize') %OR% (5 * 1024 * 1024)
+          maxSize <- getOption('shiny.maxRequestSize') %||% (5 * 1024 * 1024)
           if (maxSize <= 0)
             return(NULL)
 
@@ -308,16 +330,32 @@ HandlerManager <- R6Class("HandlerManager",
         },
         call = .httpServer(
           function (req) {
-            withCallingHandlers(withLogErrors(handlers$invoke(req)),
-              error = function(cond) {
-                sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
-                if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
-                  stop(cond$message, call. = FALSE)
-                } else {
-                  stop(paste("An error has occurred. Check your logs or",
-                             "contact the app author for clarification."),
-                       call. = FALSE)
+            hybrid_chain(
+              hybrid_chain(
+                withCallingHandlers(withLogErrors(handlers$invoke(req)),
+                  error = function(cond) {
+                    sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
+                    if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
+                      stop(cond$message, call. = FALSE)
+                    } else {
+                      stop(paste("An error has occurred. Check your logs or",
+                                 "contact the app author for clarification."),
+                           call. = FALSE)
+                    }
+                  }
+                ),
+                catch = function(err) {
+                  httpResponse(status = 500L,
+                    content_type = "text/html; charset=UTF-8",
+                    content = as.character(htmltools::htmlTemplate(
+                      system.file("template", "error.html", package = "shiny"),
+                      message = conditionMessage(err)
+                    ))
+                  )
                 }
+              ),
+              function(resp) {
+                maybeInjectAutoreload(resp)
               }
             )
           },
@@ -387,6 +425,22 @@ HandlerManager <- R6Class("HandlerManager",
   )
 )
 
+maybeInjectAutoreload <- function(resp) {
+  if (get_devmode_option("shiny.autoreload", FALSE) &&
+      isTRUE(grepl("^text/html($|;)", resp$content_type)) &&
+      is.character(resp$content)) {
+
+    resp$content <- gsub(
+      "</head>",
+      "<script src=\"shared/shiny-autoreload.js\"></script>\n</head>",
+      resp$content,
+      fixed = TRUE
+    )
+  }
+
+  resp
+}
+
 # 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

R/mock-session.R

@@ -0,0 +1,719 @@
+# 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.
+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 == "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) {
+  names(vals) <- vapply(names(vals), func, character(1))
+  vals
+}
+
+#' Returns a noop implementation of the public method `name` of ShinySession.
+#' @include shiny.R
+#' @noRd
+makeNoop <- function(name, msg = paste0(name, " is a noop.")) {
+  if (!(name %in% names(ShinySession$public_methods)))
+    stop(name, " is not public method of ShinySession.")
+  impl <- ShinySession$public_methods[[name]]
+  body(impl) <- rlang::expr({
+    # Force arguments
+    !!lapply(formalArgs(impl), rlang::sym)
+    # Evade "no visible binding" note for reference to `private`
+    (!!as.symbol("private"))$noopWarn(!!name, !!msg)
+    invisible()
+  })
+  impl
+}
+
+#' Accepts a series of symbols as arguments and generates corresponding noop
+#' implementations.
+#' @noRd
+makeWarnNoops <- function(...) {
+  methods <- as.character(list(...))
+  names(methods) <- methods
+  lapply(methods, makeNoop)
+}
+
+#' Returns an implementation of a ShinySession public method that signals an
+#' error.
+#' @include shiny.R
+#' @noRd
+makeError <- function(name, msg = paste0(name, " is for internal use only.")) {
+  if (!(name %in% names(ShinySession$public_methods)))
+    stop(name, " is not public method of ShinySession.")
+  impl <- ShinySession$public_methods[[name]]
+  body(impl) <- rlang::expr({
+    base::stop(!!msg)
+  })
+  impl
+}
+
+#' Accepts a series of named arguments. Each name corresponds to a ShinySession
+#' public method that should signal an error, and each argument corresponds to
+#' an error message.
+#' @noRd
+makeErrors <- function(...) {
+  errors <- rlang::list2(...)
+  mapply(makeError, names(errors), errors, USE.NAMES = TRUE, SIMPLIFY = FALSE)
+}
+
+#' @noRd
+makeExtraMethods <- function() {
+  c(makeWarnNoops(
+    "allowReconnect",
+    "decrementBusyCount",
+    "doBookmark",
+    "exportTestValues",
+    "flushOutput",
+    "getBookmarkExclude",
+    "getTestSnapshotUrl",
+    "incrementBusyCount",
+    "manageHiddenOutputs",
+    "manageInputs",
+    "onBookmark",
+    "onBookmarked",
+    "onInputReceived",
+    "onRestore",
+    "onRestored",
+    "outputOptions",
+    "reactlog",
+    # TODO Consider implementing this. Would require a new method like
+    # session$getDataObj() to access in a test expression.
+    "registerDataObj",
+    "reload",
+    "resetBrush",
+    "sendBinaryMessage",
+    "sendChangeTabVisibility",
+    "sendCustomMessage",
+    "sendInputMessage",
+    "sendInsertTab",
+    "sendInsertUI",
+    "sendModal",
+    "setCurrentTheme",
+    "getCurrentTheme",
+    "sendNotification",
+    "sendProgress",
+    "sendRemoveTab",
+    "sendRemoveUI",
+    "setBookmarkExclude",
+    "setShowcase",
+    "showProgress",
+    "updateQueryString"
+  ), makeErrors(
+    `@uploadEnd` = "for internal use only",
+    `@uploadInit` = "for internal use only",
+    createBookmarkObservers = "for internal use only",
+    dispatch = "for internal use only",
+    handleRequest = "for internal use only",
+    requestFlush = "for internal use only",
+    startTiming = "for internal use only",
+    wsClosed = "for internal use only"
+  ))
+}
+
+#' @description Adds generated instance methods to a MockShinySession instance.
+#'   Note that `lock_objects = FALSE` must be set in the call to `R6Class()`
+#'   that produced the generator object of the instance.
+#' @param instance instance of an R6 object, generally a `MockShinySession`.
+#' @param methods named list of method names to method implementation functions.
+#'   In our typical usage, each function is derived from a public method of
+#'   `ShinySession`. The environment of each implementation function is set to
+#'   `instance$.__enclos_env` before the method is added.
+#' @noRd
+addGeneratedInstanceMethods <- function(instance, methods = makeExtraMethods()) {
+  mapply(function(name, impl) {
+    environment(impl) <- instance$.__enclos_env__
+    instance[[name]] <- impl
+  }, names(methods), methods)
+}
+
+#' Mock Shiny Session
+#'
+#' @description An R6 class suitable for testing purposes. Simulates, to the
+#'   extent possible, the behavior of the `ShinySession` class. The `session`
+#'   parameter provided to Shiny server functions and modules is an instance of
+#'   a `ShinySession` in normal operation.
+#'
+#'   Most kinds of module and server testing do not require this class be
+#'   instantiated manually. See instead [testServer()].
+#'
+#'   In order to support advanced usage, instances of `MockShinySession` are
+#'   **unlocked** so that public methods and fields of instances may be
+#'   modified. For example, in order to test authentication workflows, the
+#'   `user` or `groups` fields may be overridden. Modified instances of
+#'   `MockShinySession` may then be passed explicitly as the `session` argument
+#'   of [testServer()].
+#'
+#' @include timer.R
+#' @export
+MockShinySession <- R6Class(
+  'MockShinySession',
+  portable = FALSE,
+  lock_objects = FALSE,
+  public = list(
+    #' @field env The environment associated with the session.
+    env = NULL,
+    #' @field returned The value returned by the module under test.
+    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"),
+    #' @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',
+    #' @field token On a real `ShinySession`, used to identify this instance in URLs.
+    token = 'character',
+    #' @field cache The session cache object.
+    cache = NULL,
+    #' @field appcache The app cache object.
+    appcache = NULL,
+    #' @field restoreContext Part of bookmarking support in a real
+    #'   `ShinySession` but always `NULL` for a `MockShinySession`.
+    restoreContext = NULL,
+    #' @field groups Character vector of groups associated with an authenticated
+    #'   user. Always `NULL` for a `MockShinySesion`.
+    groups = NULL,
+    #' @field user The username of an authenticated user. Always `NULL` for a
+    #'   `MockShinySession`.
+    user = NULL,
+    #' @field options A list containing session-level shinyOptions.
+    options = NULL,
+
+    #' @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$file_generators <- fastmap()
+
+      private$timer <- MockableTimerCallbacks$new()
+      self$progressStack <- fastmap::faststack()
+
+      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)
+
+      self$token <- createUniqueId(16)
+
+      # Copy app-level options
+      self$options <- getCurrentAppState()$options
+
+      self$cache <- cachem::cache_mem()
+      self$appcache <- cachem::cache_mem()
+
+      # Adds various generated noop and error-producing method implementations.
+      # Note that noop methods can be configured to produce warnings by setting
+      # the option shiny.mocksession.warn = TRUE; see $noopWarn() for details.
+      addGeneratedInstanceMethods(self)
+    },
+    #' @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$was_closed },
+    #' @description Returns `FALSE` if the session has not yet been closed
+    isClosed = function(){ private$was_closed },
+    #' @description Closes the session
+    close = function(){
+      for (output in private$output) {
+        output$suspend()
+      }
+      withReactiveDomain(self, {
+        private$endedCBs$invoke(onError = printError, ..stacktraceon = TRUE)
+      })
+      private$was_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 to 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. These arguments are processed with
+    #'  [rlang::list2()] and so are _[dynamic][rlang::dyn-dots]_. Input names
+    #'  may not be duplicated.
+    #' @examples
+    #' \dontrun{
+    #' session$setInputs(x=1, y=2)
+    #' }
+    setInputs = function(...) {
+      vals <- rlang::dots_list(..., .homonyms = "error")
+      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.
+    #'   Schedules `callback` for execution after some number of `millis`
+    #'   milliseconds.
+    #' @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.
+    #' @return Elapsed time in milliseconds.
+    .now = function() {
+      private$timer$getElapsed()
+    },
+
+    #' @description An internal method which shouldn't be used by others.
+    #'   Defines an output in a way that sets private$currentOutputName
+    #'   appropriately.
+    #' @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 <- private$withCurrentOutput(name, 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. Forces
+    #'   evaluation of any reactive dependencies of the output function.
+    #' @param name The name of the output.
+    #' @return The return value of the function responsible for rendering 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 if (private$file_generators$has(self$ns(name))) {
+        download <- private$file_generators$get(self$ns(name))
+        private$renderFile(self$ns(name), download)
+      } else {
+        v$val
+      }
+    },
+
+    #' @description Returns the given id prefixed by this namespace's id.
+    #' @param id The id to prefix with a namespace id.
+    #' @return The id with a namespace prefix.
+    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.
+    #' @return A new session proxy.
+    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(...) {
+          self$setInputs(!!!mapNames(ns, rlang::dots_list(..., .homonyms = "error")))
+        }
+      )
+    },
+    #' @description Set the environment associated with a testServer() call, but
+    #'  only if it has not previously been set. This ensures that only the
+    #'  environment of the outermost module under test is the one retained. In
+    #'  other words, the first assignment wins.
+    #' @param env The environment to retain.
+    #' @return The provided `env`.
+    setEnv = function(env) {
+      if (is.null(self$env)) {
+        stopifnot(all(c("input", "output", "session") %in% ls(env)))
+        self$env <- env
+      }
+    },
+    #' @description Set the value returned by the module call and proactively
+    #'  flush. Note that this method may be called multiple times if modules
+    #'  are nested. The last assignment, corresponding to an invocation of
+    #'  setReturned() in the outermost module, wins.
+    #' @param value The value returned from the module
+    #' @return The provided `value`.
+    setReturned = function(value) {
+      self$returned <- value
+      value
+    },
+    #' @description Get the value returned by the module call.
+    #' @return The value returned by the module call
+    getReturned = function() self$returned,
+    #' @description Generate a distinct character identifier for use as a proxy
+    #'   namespace.
+    #' @return A character identifier unique to the current session.
+    genId = function() {
+      private$idCounter <- private$idCounter + 1
+      paste0("proxy", private$idCounter)
+    },
+    #' @description Provides a way to access the root `MockShinySession` from
+    #'   any descendant proxy.
+    #' @return The root `MockShinySession`.
+    rootScope = function() {
+      self
+    },
+    #' @description Called by observers when a reactive expression errors.
+    #' @param e An error object.
+    unhandledError = function(e) {
+      self$close()
+    },
+    #' @description Freeze a value until the flush cycle completes.
+    #' @param x A `ReactiveValues` object.
+    #' @param name The name of a reactive value within `x`.
+    freezeValue = function(x, name) {
+      if (!is.reactivevalues(x))
+        stop("x must be a reactivevalues object")
+
+      impl <- .subset2(x, 'impl')
+      key <- .subset2(x, 'ns')(name)
+      impl$freeze(key)
+      self$onFlushed(function() impl$thaw(key))
+    },
+    #' @description Registers the given callback to be invoked when the session
+    #'   is closed (i.e. the connection to the client has been severed). The
+    #'   return value is a function which unregisters the callback. If multiple
+    #'   callbacks are registered, the order in which they are invoked is not
+    #'   guaranteed.
+    #' @param sessionEndedCallback Function to call when the session ends.
+    onSessionEnded = function(sessionEndedCallback) {
+      self$onEnded(sessionEndedCallback)
+    },
+    #' @description Associated a downloadable file with the session.
+    #' @param name The un-namespaced output name to associate with the
+    #'   downloadable file.
+    #' @param filename A string or function designating the name of the file.
+    #' @param contentType A string of the content type of the file. Not used by
+    #'   `MockShinySession`.
+    #' @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.)
+    registerDownload = function(name, filename, contentType, content) {
+      private$file_generators$set(self$ns(name), list(
+        filename = if (is.function(filename)) filename else function() filename,
+        content = content
+      ))
+    },
+    #' @description Get information about the output that is currently being
+    #'   executed.
+    #' @return A list with with the `name` of the output. If no output is
+    #'   currently being executed, this will return `NULL`.
+    getCurrentOutputInfo = function() {
+      name <- private$currentOutputName
+      if (is.null(name)) NULL else list(name = name)
+    }
+  ),
+  private = list(
+    # @field .input Internal ReactiveValues object for normal input sent from client.
+    .input = NULL,
+    # @field flushCBs `Callbacks` called before flush.
+    flushCBs = NULL,
+    # @field flushedCBs `Callbacks` called after flush.
+    flushedCBs = NULL,
+    # @field endedCBs `Callbacks` called when session ends.
+    endedCBs = NULL,
+    # @field timer `MockableTimerCallbacks` called at particular times.
+    timer = NULL,
+    # @field was_closed Set to `TRUE` once the session is closed.
+    was_closed = FALSE,
+    # @field outs List of namespaced output names.
+    outs = list(),
+    # @field nsPrefix Prefix with which to namespace inputs and outputs.
+    nsPrefix = "mock-session",
+    # @field idCounter Incremented every time `$genId()` is called.
+    idCounter = 0,
+    # @field file_generators Map of namespaced output names to lists with
+    #   `filename` and `output` elements, each a function. Updated by
+    #   `$registerDownload()` and read by `$getOutput()`. Files are generated
+    #   on demand when the output is accessed.
+    file_generators = NULL,
+    # @field currentOutputName Namespaced name of the currently executing
+    #'   output, or `NULL` if no output is currently executing.
+    currentOutputName = NULL,
+
+    # @description Writes a downloadable file to disk. If the `content` function
+    #   associated with a download handler does not write a file, an error is
+    #   signaled. Created files are deleted upon session close.
+    # @param name The eamespaced output name associated with the downloadable
+    #   file.
+    # @param download List with two names, `filename` and `content`. Both should
+    #   be functions. `filename` should take no arguments and return a string.
+    #   `content` should accept a path argument and create a file at that path.
+    # @return A path to a temp file.
+    renderFile = function(name, download) {
+      # We make our own tempdir here because it's not safe to delete the result
+      # of tempdir().
+      tmpd <- tempfile()
+      dir.create(tmpd, recursive = TRUE)
+      self$onSessionEnded(function() unlink(tmpd, recursive = TRUE))
+      file <- file.path(tmpd, download$filename())
+      download$content(file)
+      if (!file.exists(file))
+        error("downloadHandler for ", name, " did not write a file.")
+      file
+    },
+
+    # @description Calls `shiny:::flushReact()` and executes all callbacks
+    #   related to reactivity.
+    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()
+    },
+
+    # @description Produces a warning if the option `shiny.mocksession.warn` is
+    #   unset and not `FALSE`.
+    # @param name The name of the mocked method.
+    # @param msg A message describing why the method is not implemented.
+    noopWarn = function(name, msg) {
+      if (getOption("shiny.mocksession.warn", FALSE) == FALSE)
+        return(invisible())
+      out <- paste0(name, " is not fully implemented by MockShinySession: ", msg)
+      out <- paste0(out, "\n", "To disable messages like this, run `options(shiny.mocksession.warn=FALSE)`")
+      warning(out, call. = FALSE)
+    },
+
+    # @description Binds a domain to `expr` and uses `createVarPromiseDomain()`
+    #   to ensure `private$currentOutputName` is set to `name` around any of
+    #   the promise's callbacks. Domains are something like dynamic scopes but
+    #   for promise chains instead of the call stack.
+    # @return A promise.
+    withCurrentOutput = function(name, expr) {
+      if (!is.null(private$currentOutputName)) {
+        stop("Nested calls to withCurrentOutput() are not allowed.")
+      }
+
+      promises::with_promise_domain(
+        createVarPromiseDomain(private, "currentOutputName", name),
+        expr
+      )
+    }
+  ),
+  active = list(
+    #' @field files For internal use only.
+    files = function() stop("$files is for internal use only."),
+    #' @field downloads For internal use only.
+    downloads = function() stop("$downloads is for internal use only."),
+    #' @field closed Deprecated in `ShinySession` and signals an error.
+    closed = function() stop("$closed is deprecated"),
+    #' @field session Deprecated in ShinySession and signals an error.
+    session = function() stop("$session is deprecated"),
+    #' @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)
@@ -29,21 +29,27 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 
 #' Create a modal dialog UI
 #'
-#' This creates the UI for a modal dialog, using Bootstrap's modal class. Modals
-#' are typically used for showing important messages, or for presenting UI that
-#' requires input from the user, such as a username and password input.
+#' @description
+#' `modalDialog()` creates the UI for a modal dialog, using Bootstrap's modal
+#' class. Modals are typically used for showing important messages, or for
+#' presenting UI that requires input from the user, such as a user name and
+#' password input.
 #'
+#' `modalButton()` creates a button that will dismiss the dialog when clicked,
+#' typically used when customising the `footer`.
+#'
+#' @inheritParams actionButton
 #' @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
-#'   ways; instead it must be dismissed by clicking on the dismiss button, or
-#'   from a call to \code{\link{removeModal}} on the server.
-#' @param fade If \code{FALSE}, the modal dialog will have no fade-in animation
+#'   `FALSE` (the default), the modal dialog can't be dismissed in those
+#'   ways; instead it must be dismissed by clicking on a `modalButton()`, or
+#'   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
@@ -169,13 +175,8 @@ modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
   )
 }
 
-#' Create a button for a modal dialog
-#'
-#' When clicked, a \code{modalButton} will dismiss the modal dialog.
-#'
-#' @inheritParams actionButton
-#' @seealso \code{\link{modalDialog}} for examples.
 #' @export
+#' @rdname modalDialog
 modalButton <- function(label, icon = NULL) {
   tags$button(type = "button", class = "btn btn-default",
     `data-dismiss` = "modal", validateIcon(icon), label

R/modules.R

@@ -31,18 +31,148 @@ createSessionProxy <- function(parentSession, ...) {
   # but not `session$userData <- TRUE`) from within a module
   # without any hacks (see PR #1732)
   if (identical(x[[name]], value)) return(x)
+
+  # Special case for $options (issue #3112)
+  if (name == "options") {
+    session <- find_ancestor_session(x)
+    session[[name]] <- value
+    return(x)
+  }
+
   stop("Attempted to assign value on session proxy.")
 }
 
 `[[<-.session_proxy` <- `$<-.session_proxy`
 
+# Given a session_proxy, search `parent` recursively to find the real
+# ShinySession object. If given a ShinySession, simply return it.
+find_ancestor_session <- function(x, depth = 20) {
+  if (depth < 0) {
+    stop("ShinySession not found")
+  }
+  if (inherits(x, "ShinySession")) {
+    return(x)
+  }
+  if (inherits(x, "session_proxy")) {
+    return(find_ancestor_session(.subset2(x, "parent"), depth-1))
+  }
 
-#' Invoke a Shiny module
+  stop("ShinySession not found")
+}
+
+
+#' 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.
+#' <https://shiny.rstudio.com/articles/modules.html> to learn more.
+#'
+#' 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 session Session from which to make a child scope (the default should
+#'   almost always be used).
+#'
+#' @return The return value, if any, from executing the module server function
+#' @seealso <https://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())
+      !!body(module)
+    })
+    session$setReturned(callModule(module, id, session = session))
+  } else {
+    callModule(module, id, session = session)
+  }
+}
+
+
+#' Invoke a Shiny module
+#'
+#' Note: As of 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
@@ -52,9 +182,11 @@ createSessionProxy <- function(parentSession, ...) {
 #'   almost always be used)
 #'
 #' @return The return value, if any, from executing the module server function
-#' @seealso \url{http://shiny.rstudio.com/articles/modules.html}
 #' @export
 callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
+  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,67 +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}.
-#' @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
@@ -91,7 +53,7 @@
 #'
 #' shinyApp(ui, server)
 #' }
-#' @seealso \code{\link{withProgress}}
+#' @seealso [withProgress()]
 #' @format NULL
 #' @usage NULL
 #' @export
@@ -99,12 +61,25 @@ Progress <- R6Class(
   'Progress',
   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"))
     {
+      if (is.null(session))
+        rlang::abort("Can only use Progress$new() inside a Shiny app")
       if (is.null(session$progressStack))
-        stop("'session' is not a ShinySession object.")
+        rlang::abort("`session` is not a ShinySession object.")
 
       private$session <- session
       private$id <- createUniqueId(8)
@@ -117,6 +92,11 @@ Progress <- R6Class(
       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.")
@@ -143,6 +123,11 @@ Progress <- R6Class(
       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) {
       if (is.null(private$value))
         private$value <- private$min
@@ -151,12 +136,17 @@ Progress <- R6Class(
       self$set(value, message, detail)
     },
 
+    #' @description Returns the minimum value.
     getMin = function() private$min,
 
+    #' @description Returns the maximum value.
     getMax = function() private$max,
 
+    #' @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.")
@@ -186,59 +176,60 @@ 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()] or [incProgress()].
 #' @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}.
+#'   progress bar, relative to `min` and `max`.
 #'
+#' @return The result of `expr`.
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
@@ -263,7 +254,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

@@ -5,7 +5,7 @@ processId <- local({
   cached <- NULL
   function() {
     if (is.null(cached)) {
-      cached <<- digest::digest(list(
+      cached <<- rlang::hash(list(
         Sys.info(),
         Sys.time()
       ))
@@ -31,11 +31,13 @@ Context <- R6Class(
     .flushCallbacks = list(),
     .domain = NULL,
     .pid = NULL,
+    .weak = NULL,
 
     initialize = function(
       domain, label='', type='other', prevId='',
       reactId = rLog$noReactId,
-      id = .getReactiveEnvironment()$nextId() # For dummy context
+      id = .getReactiveEnvironment()$nextId(), # For dummy context
+      weak = FALSE
     ) {
       id <<- id
       .label <<- label
@@ -43,6 +45,7 @@ Context <- R6Class(
       .pid <<- processId()
       .reactId <<- reactId
       .reactType <<- type
+      .weak <<- weak
       rLog$createContext(id, label, type, prevId, domain)
     },
     run = function(func) {
@@ -62,7 +65,7 @@ Context <- R6Class(
         that have been registered with onInvalidate()."
 
       if (!identical(.pid, processId())) {
-        stop("Reactive context was created in one process and invalidated from another")
+        rlang::abort("Reactive context was created in one process and invalidated from another.")
       }
 
       if (.invalidated)
@@ -84,7 +87,7 @@ Context <- R6Class(
         immediately."
 
       if (!identical(.pid, processId())) {
-        stop("Reactive context was created in one process and accessed from another")
+        rlang::abort("Reactive context was created in one process and accessed from another.")
       }
 
       if (.invalidated)
@@ -108,6 +111,9 @@ Context <- R6Class(
       lapply(.flushCallbacks, function(flushCallback) {
         flushCallback()
       })
+    },
+    isWeak = function() {
+      .weak
     }
   )
 )
@@ -134,9 +140,13 @@ ReactiveEnvironment <- R6Class(
         if (isTRUE(getOption('shiny.suppressMissingContextError'))) {
           return(getDummyContext())
         } else {
-          stop('Operation not allowed without an active reactive context. ',
-               '(You tried to do something that can only be done from inside a ',
-               'reactive expression or observer.)')
+          rlang::abort(c(
+            'Operation not allowed without an active reactive context.',
+            paste0(
+              'You tried to do something that can only be done from inside a ',
+              'reactive consumer.'
+            )
+          ))
         }
       }
       return(.currentContext)
@@ -196,7 +206,8 @@ getCurrentContext <- function() {
   .getReactiveEnvironment()$currentContext()
 }
 hasCurrentContext <- function() {
-  !is.null(.getReactiveEnvironment()$.currentContext)
+  !is.null(.getReactiveEnvironment()$.currentContext) ||
+    isTRUE(getOption("shiny.suppressMissingContextError"))
 }
 
 getDummyContext <- function() {

R/reactive-domains.R

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

@@ -1,30 +1,31 @@
 #' Plot output with cached images
 #'
-#' Renders a reactive plot, with plot images cached to disk.
+#' Renders a reactive plot, with plot images cached to disk. As of Shiny 1.6.0,
+#' this is a shortcut for using [bindCache()] with [renderPlot()].
 #'
-#' \code{expr} is an expression that generates a plot, similar to that in
-#' \code{renderPlot}. Unlike with \code{renderPlot}, this expression does not
+#' `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.
 #'
-#' \code{cacheKeyExpr} is an expression which, when evaluated, returns an object
-#' which will be serialized and hashed using the \code{\link[digest]{digest}}
+#' `cacheKeyExpr` is an expression which, when evaluated, returns an object
+#' which will be serialized and hashed using the [rlang::hash()]
 #' function to generate a string that will be used as a cache key. This key is
 #' used to identify the contents of the plot: if the cache key is the same as a
 #' previous time, it assumes that the plot is the same and can be retrieved from
 #' the cache.
 #'
-#' This \code{cacheKeyExpr} is reactive, and so it will be re-evaluated when any
+#' 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, \code{expr}.
+#' 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
+#' 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
+#' --- 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
@@ -32,128 +33,39 @@
 #' to normal R objects before returning them. Your expression could even
 #' serialize and hash that information in an efficient way and return a string,
 #' which will in turn be hashed (very quickly) by the
-#' \code{\link[digest]{digest}} function.
+#' [rlang::hash()] function.
 #'
-#' Internally, the result from \code{cacheKeyExpr} is combined with the name of
-#' the output (if you assign it to \code{output$plot1}, it will be combined
-#' with \code{"plot1"}) to form the actual key that is used. As a result, even
-#' if there are multiple plots that have the same \code{cacheKeyExpr}, they
+#' 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 \code{cache} parameter. There
-#'   are two ways of having Shiny automatically create and clean up the disk
-#'   cache.
-#'
-#' \describe{
-#'   \item{1}{To scope the cache to one run of a Shiny application (shared
-#'     among possibly multiple user sessions), use \code{cache="app"}. This
-#'     is the default. The cache will be shared across multiple sessions, so
-#'     there is potentially a large performance benefit if there are many users
-#'     of the application. When the application stops running, the cache will
-#'     be deleted. If plots cannot be safely shared across users, this should
-#'     not be used.}
-#'   \item{2}{To scope the cache to one session, use \code{cache="session"}.
-#'     When a new user session starts -- in other words, when a web browser
-#'     visits the Shiny application -- a new cache will be created on disk
-#'     for that session. When the session ends, the cache will be deleted.
-#'     The cache will not be shared across multiple sessions.}
-#'  }
-#'
-#'   If either \code{"app"} or \code{"session"} is used, the cache will be 10 MB
-#'   in size, and will be stored stored in memory, using a
-#'   \code{\link{memoryCache}} object. Note that the cache space will be shared
-#'   among all cached plots within a single application or session.
-#'
-#'   In some cases, you may want more control over the caching behavior. For
-#'   example, you may want to use a larger or smaller cache, share a cache
-#'   among multiple R processes, or you may want the cache to persist across
-#'   multiple runs of an application, or even across multiple R processes.
-#'
-#'   To use different settings for an application-scoped cache, you can call
-#'   \code{\link{shinyOptions}()} at the top of your app.R, server.R, or
-#'   global.R. For example, this will create a cache with 20 MB of space
-#'   instead of the default 10 MB:
-#'   \preformatted{
-#'   shinyOptions(cache = memoryCache(size = 20e6))
-#'   }
-#'
-#'   To use different settings for a session-scoped cache, you can call
-#'   \code{\link{shinyOptions}()} at the top of your server function. To use
-#'   the session-scoped cache, you must also call \code{renderCachedPlot} with
-#'   \code{cache="session"}. This will create a 20 MB cache for the session:
-#'   \preformatted{
-#'   function(input, output, session) {
-#'     shinyOptions(cache = memoryCache(size = 20e6))
-#'
-#'     output$plot <- renderCachedPlot(
-#'       ...,
-#'       cache = "session"
-#'     )
-#'   }
-#'   }
-#'
-#'   If you want to create a cache that is shared across multiple concurrent
-#'   R processes, you can use a \code{\link{diskCache}}. You can create an
-#'   application-level shared cache by putting this at the top of your app.R,
-#'   server.R, or global.R:
-#'   \preformatted{
-#'   shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
-#'   }
-#'
-#'   This will create a subdirectory in your system temp directory named
-#'   \code{myapp-cache} (replace \code{myapp-cache} with a unique name of
-#'   your choosing). On most platforms, this directory will be removed when
-#'   your system reboots. This cache will persist across multiple starts and
-#'   stops of the R process, as long as you do not reboot.
-#'
-#'   To have the cache persist even across multiple reboots, you can create the
-#'   cache in a location outside of the temp directory. For example, it could
-#'   be a subdirectory of the application:
-#'   \preformatted{
-#'   shinyOptions(cache = diskCache("./myapp-cache"))
-#'   }
-#'
-#'   In this case, resetting the cache will have to be done manually, by deleting
-#'   the directory.
-#'
-#'   You can also scope a cache to just one plot, or selected plots. To do that,
-#'   create a \code{\link{memoryCache}} or \code{\link{diskCache}}, and pass it
-#'   as the \code{cache} argument of \code{renderCachedPlot}.
-#'
 #' @section Interactive plots:
 #'
-#'   \code{renderCachedPlot} can be used to create interactive plots. See
-#'   \code{\link{plotOutput}} for more information and examples.
+#'   `renderCachedPlot` can be used to create interactive plots. See
+#'   [plotOutput()] for more information and examples.
 #'
 #'
 #' @inheritParams renderPlot
+#' @inheritParams bindCache
 #' @param cacheKeyExpr An expression that returns a cache key. This key should
 #'   be a unique identifier for a plot: the assumption is that if the cache key
 #'   is the same, then the plot will be the same.
-#' @param sizePolicy A function that takes two arguments, \code{width} and
-#'   \code{height}, and returns a list with \code{width} and \code{height}. The
+#' @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 \code{\link{sizeGrowthRatio}} for more
+#'   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
-#'   \code{"app"} (the default), \code{"session"}, or a cache object like
-#'   a \code{\link{diskCache}}. See the Cache Scoping section for more
-#'   information.
+#' @param width,height not used. They are specified via the argument
+#'   `sizePolicy`.
 #'
-#' @seealso See \code{\link{renderPlot}} for the regular, non-cached version of
-#'   this function. For more about configuring caches, see
-#'   \code{\link{memoryCache}} and \code{\link{diskCache}}.
+#' @seealso See [renderPlot()] for the regular, non-cached version of this
+#'   function. It can be used with [bindCache()] to get the same effect as
+#'   `renderCachedPlot()`. For more about configuring caches, see
+#'   [cachem::cache_mem()] and [cachem::cache_disk()].
 #'
 #'
 #' @examples
@@ -244,7 +156,7 @@
 #'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
 #'       },
 #'       cacheKeyExpr = { list(input$n) },
-#'       cache = memoryCache()
+#'       cache = cachem::cache_mem()
 #'     )
 #'     output$plot2 <- renderCachedPlot({
 #'         Sys.sleep(2)  # Add an artificial delay
@@ -253,7 +165,7 @@
 #'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
 #'       },
 #'       cacheKeyExpr = { list(input$n) },
-#'       cache = memoryCache()
+#'       cache = cachem::cache_mem()
 #'     )
 #'   }
 #' )
@@ -264,22 +176,22 @@
 #' # 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))
+#' shinyOptions(cache = cachem::cache_mem(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"))
+#' shinyOptions(cache = cachem::cache_disk(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"))
+#' shinyOptions(cache = cachem::cache_disk("./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))
+#'   shinyOptions(cache = cachem::cache_mem(max_size = 5e6))
 #'
 #'   output$plot <- renderCachedPlot(
 #'     ...,
@@ -295,257 +207,35 @@ renderCachedPlot <- function(expr,
   res = 72,
   cache = "app",
   ...,
-  outputArgs = list()
+  alt = "Plot object",
+  outputArgs = list(),
+  width = NULL,
+  height = NULL
 ) {
 
-  # 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(...)
+  expr <- substitute(expr)
+  if (!is_quosure(expr)) {
+    expr <- new_quosure(expr, env = parent.frame())
+  }
 
   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`.')
-    }
+  if (!is_quosure(cacheKeyExpr)) {
+    cacheKeyExpr <- new_quosure(cacheKeyExpr, env = parent.frame())
   }
 
-  # 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())
+  if (!is.null(width) || !is.null(height)) {
+    warning("Unused argument(s) 'width' and/or 'height'. ",
+            "'sizePolicy' is used instead.")
   }
 
-  # 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)
-      }
+  inject(
+    bindCache(
+      renderPlot(!!expr, res = res, alt = alt, outputArgs = outputArgs, ...),
+      !!cacheKeyExpr,
+      sizePolicy = sizePolicy,
+      cache = cache
     )
-  })
-
-
-  # 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)
+  )
 }
 
 
@@ -562,7 +252,7 @@ renderCachedPlot <- function(expr,
 #' @param width,height Base width and height.
 #' @param growthRate Growth rate multiplier.
 #'
-#' @seealso This is to be used with \code{\link{renderCachedPlot}}.
+#' @seealso This is to be used with [renderCachedPlot()].
 #'
 #' @examples
 #' f <- sizeGrowthRatio(500, 500, 1.25)

R/render-plot.R

@@ -1,57 +1,72 @@
 #' Plot Output
 #'
-#' Renders a reactive plot that is suitable for assigning to an \code{output}
+#' Renders a reactive plot that is suitable for assigning to an `output`
 #' slot.
 #'
-#' The corresponding HTML output tag should be \code{div} or \code{img} and have
-#' the CSS class name \code{shiny-plot-output}.
+#' The corresponding HTML output tag should be `div` or `img` and have
+#' the CSS class name `shiny-plot-output`.
 #'
 #' @section Interactive plots:
 #'
-#'   With ggplot2 graphics, the code in \code{renderPlot} should return a ggplot
+#'   With ggplot2 graphics, the code in `renderPlot` should return a ggplot
 #'   object; if instead the code prints the ggplot2 object with something like
-#'   \code{print(p)}, then the coordinates for interactive graphics will not be
+#'   `print(p)`, then the coordinates for interactive graphics will not be
 #'   properly scaled to the data space.
 #'
-#'   See \code{\link{plotOutput}} for more information about interactive plots.
+#'   See [plotOutput()] for more information about interactive plots.
 #'
 #' @seealso For the corresponding client-side output function, and example
-#'   usage, see \code{\link{plotOutput}}. For more details on how the plots are
-#'   generated, and how to control the output, see \code{\link{plotPNG}}.
+#'   usage, see [plotOutput()]. For more details on how the plots are
+#'   generated, and how to control the output, see [plotPNG()].
+#'   [renderCachedPlot()] offers a way to cache generated plots to
+#'   expedite the rendering of identical plots.
 #'
 #' @param expr An expression that generates a plot.
-#' @param width,height The width/height of the rendered plot, in pixels; or
-#'   \code{'auto'} to use the \code{offsetWidth}/\code{offsetHeight} of the HTML
-#'   element that is bound to this plot. You can also pass in a function that
-#'   returns the width/height in pixels or \code{'auto'}; in the body of the
-#'   function you may reference reactive values and functions. When rendering an
-#'   inline plot, you must provide numeric values (in pixels) to both
-#'   \code{width} and \code{height}.
+#' @param width,height Height and width can be specified in three ways:
+#'   * `"auto"`, the default, uses the size specified by [plotOutput()]
+#'      (i.e. the `offsetWidth`/`offsetHeight`` of the HTML element bound to
+#'      this plot.)
+#'  * An integer, defining the width/height in pixels.
+#'  * A function that returns the width/height in pixels (or `"auto"`).
+#'    The function is executed in a reactive context so that you can refer to
+#'    reactive values and expression to make the width/height reactive.
+#'
+#'   When rendering an inline plot, you must provide numeric values (in pixels)
+#'   to both \code{width} and \code{height}.
 #' @param res Resolution of resulting plot, in pixels per inch. This value is
-#'   passed to \code{\link[grDevices]{png}}. Note that this affects the resolution of PNG
+#'   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 \code{\link[grDevices]{png}}.
+#' @param alt Alternate text for the HTML `<img>` tag
+#'   if it cannot be displayed or viewed (i.e., the user uses a screen reader).
+#'   In addition to a character string, the value may be a reactive expression
+#'   (or a function referencing reactive values) that returns a character string.
+#'   NULL or "" is not recommended because those should be limited to decorative images
+#'   (the default is "Plot object").
+#' @param ... Arguments to be passed through to [grDevices::png()].
 #'   These can be used to set the width, height, background color, etc.
-#' @param env The environment in which to evaluate \code{expr}.
-#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
+#' @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 execOnResize If \code{FALSE} (the default), then when a plot is
-#'   resized, Shiny will \emph{replay} the plot drawing commands with
-#'   \code{\link[grDevices]{replayPlot}()} instead of re-executing \code{expr}.
+#' @param execOnResize If `FALSE` (the default), then when a plot is
+#'   resized, Shiny will *replay* the plot drawing commands with
+#'   [grDevices::replayPlot()] instead of re-executing `expr`.
 #'   This can result in faster plot redrawing, but there may be rare cases where
 #'   it is undesirable. If you encounter problems when resizing a plot, you can
-#'   have Shiny re-execute the code on resize by setting this to \code{TRUE}.
+#'   have Shiny re-execute the code on resize by setting this to `TRUE`.
 #' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to \code{\link{plotOutput}} when \code{renderPlot} is used in an
+#'   call to [plotOutput()] when `renderPlot` is used in an
 #'   interactive R Markdown document.
 #' @export
-renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
-                       env=parent.frame(), quoted=FALSE,
-                       execOnResize=FALSE, outputArgs=list()
+renderPlot <- function(expr, width = 'auto', height = 'auto', res = 72, ...,
+                       alt = "Plot object",
+                       env = parent.frame(), quoted = FALSE,
+                       execOnResize = FALSE, outputArgs = list()
 ) {
+
+  expr <- get_quosure(expr, env, quoted)
   # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
   # is called
-  installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
+  func <- quoToFunction(expr, "renderPlot", ..stacktraceon = TRUE)
 
   args <- list(...)
 
@@ -69,7 +84,16 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   else
     heightWrapper <- function() { height }
 
-  getDims <- function() {
+  if (is.reactive(alt))
+    altWrapper <- alt
+  else if (is.function(alt))
+    altWrapper <- reactive({ alt() })
+  else
+    altWrapper <- function() { alt }
+
+  # This is the function that will be used as getDims by default, but it can be
+  # overridden (which happens when bindCache() is used).
+  getDimsDefault <- function() {
     width <- widthWrapper()
     height <- heightWrapper()
 
@@ -88,6 +112,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   # the plotObj() reactive.
   session <- NULL
   outputName <- NULL
+  getDims <- NULL
 
   # Calls drawPlot, invoking the user-provided `func` (which may or may not
   # return a promise). The idea is that the (cached) return value from this
@@ -98,7 +123,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
       {
         # If !execOnResize, don't invalidate when width/height changes.
         dims <- if (execOnResize) getDims() else isolate(getDims())
-        pixelratio <- session$clientData$pixelratio %OR% 1
+        pixelratio <- session$clientData$pixelratio %||% 1
         do.call("drawPlot", c(
           list(
             name = outputName,
@@ -106,6 +131,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
             func = func,
             width = dims$width,
             height = dims$height,
+            alt = altWrapper(),
             pixelratio = pixelratio,
             res = res
           ), args))
@@ -124,17 +150,21 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 
   # 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, ...) {
+  # The `get_dims` parameter defaults to `getDimsDefault`. However, it can be
+  # overridden, so that `bindCache` can use a different version.
+  renderFunc <- function(shinysession, name, ..., get_dims = getDimsDefault) {
+
     outputName <<- name
     session <<- shinysession
+    if (is.null(getDims)) getDims <<- get_dims
 
     hybrid_chain(
       drawReactive(),
       function(result) {
         dims <- getDims()
-        pixelratio <- session$clientData$pixelratio %OR% 1
+        pixelratio <- session$clientData$pixelratio %||% 1
         result <- do.call("resizeSavedPlot", c(
-          list(name, shinysession, result, dims$width, dims$height, pixelratio, res),
+          list(name, shinysession, result, dims$width, dims$height, altWrapper(), pixelratio, res),
           args
         ))
 
@@ -150,15 +180,27 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   outputFunc <- plotOutput
   if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
 
-  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+  markedFunc <- markRenderFunction(
+    outputFunc,
+    renderFunc,
+    outputArgs,
+    cacheHint = list(userExpr = get_expr(expr), res = res)
+  )
+  class(markedFunc) <- c("shiny.renderPlot", class(markedFunc))
+  markedFunc
 }
 
-resizeSavedPlot <- function(name, session, result, width, height, pixelratio, res, ...) {
+resizeSavedPlot <- function(name, session, result, width, height, alt, pixelratio, res, ...) {
   if (result$img$width == width && result$img$height == height &&
       result$pixelratio == pixelratio && result$res == res) {
     return(result)
   }
 
+  if (isNamespaceLoaded("showtext")) {
+    showtextOpts <- showtext::showtext_opts(dpi = res*pixelratio)
+    on.exit({showtext::showtext_opts(showtextOpts)}, add = TRUE)
+  }
+
   coordmap <- NULL
   outfile <- plotPNG(function() {
     grDevices::replayPlot(result$recordedPlot)
@@ -170,6 +212,7 @@ resizeSavedPlot <- function(name, session, result, width, height, pixelratio, re
     src = session$fileUrl(name, outfile, contentType = "image/png"),
     width = width,
     height = height,
+    alt = alt,
     coordmap = coordmap,
     error = attr(coordmap, "error", exact = TRUE)
   )
@@ -177,7 +220,7 @@ resizeSavedPlot <- function(name, session, result, width, height, pixelratio, re
   result
 }
 
-drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
+drawPlot <- function(name, session, func, width, height, alt, pixelratio, res, ...) {
   #  1. Start PNG
   #  2. Enable displaylist recording
   #  3. Call user-defined func
@@ -194,13 +237,25 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
   domain <- createGraphicsDevicePromiseDomain(device)
   grDevices::dev.control(displaylist = "enable")
 
+  # In some cases (at least when `png(type='cairo')), showtext's font
+  # rendering needs to know about the device's resolution to work properly.
+  # I don't see any immediate harm in setting the dpi option for any device,
+  # but it's worth noting that the option doesn't currently work with CairoPNG.
+  # https://github.com/yixuan/showtext/issues/33
+  showtextOpts <- if (isNamespaceLoaded("showtext")) {
+    showtext::showtext_opts(dpi = res*pixelratio)
+  } else {
+    NULL
+  }
+
   hybrid_chain(
     hybrid_chain(
       promises::with_promise_domain(domain, {
         hybrid_chain(
           func(),
-          function(value, .visible) {
-            if (.visible) {
+          function(value) {
+            res <- withVisible(value)
+            if (res$visible) {
               # A modified version of print.ggplot which returns the built ggplot object
               # as well as the gtable grob. This overrides the ggplot::print.ggplot
               # method, but only within the context of renderPlot. The reason this needs
@@ -218,7 +273,7 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
                 # similar to ggplot2. But for base graphics, it would already have
                 # been rendered when func was called above, and the print should
                 # have no effect.
-                result <- ..stacktraceon..(print(value))
+                result <- ..stacktraceon..(print(res$value))
                 # TODO jcheng 2017-04-11: Verify above ..stacktraceon..
               })
               result
@@ -240,6 +295,9 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
       }),
       finally = function() {
         grDevices::dev.off(device)
+        if (length(showtextOpts)) {
+          showtext::showtext_opts(showtextOpts)
+        }
       }
     ),
     function(result) {
@@ -247,6 +305,7 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
         src = session$fileUrl(name, outfile, contentType='image/png'),
         width = width,
         height = height,
+        alt = alt,
         coordmap = result$coordmap,
         # Get coordmap error message if present
         error = attr(result$coordmap, "error", exact = TRUE)
@@ -353,62 +412,88 @@ custom_print.ggplot <- function(x) {
 # With a faceted ggplot2 plot, the outer list contains two objects, each of
 # which represents one panel. In this example, there is one panelvar, but there
 # can be up to two of them.
-# mtc <- mtcars
-# mtc$am <- factor(mtc$am)
-# p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am))
-# str(getGgplotCoordmap(p, 400, 300, 72))
+# p <- print(ggplot(mpg) + geom_point(aes(fl, cty), alpha = 0.2) + facet_wrap(~drv, scales = "free_x"))
+# str(getGgplotCoordmap(p, 500, 400, 72))
 # List of 2
-#  $ panels:List of 2
+#  $ panels:List of 3
 #   ..$ :List of 8
 #   .. ..$ panel     : num 1
 #   .. ..$ row       : int 1
 #   .. ..$ col       : int 1
 #   .. ..$ panel_vars:List of 1
-#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
+#   .. .. ..$ panelvar1: chr "4"
 #   .. ..$ log       :List of 2
 #   .. .. ..$ x: NULL
 #   .. .. ..$ y: NULL
-#   .. ..$ domain    :List of 4
-#   .. .. ..$ left  : num 1.32
-#   .. .. ..$ right : num 5.62
-#   .. .. ..$ bottom: num 9.22
-#   .. .. ..$ top   : num 35.1
+#   .. ..$ domain    :List of 5
+#   .. .. ..$ left           : num 0.4
+#   .. .. ..$ right          : num 4.6
+#   .. .. ..$ bottom         : num 7.7
+#   .. .. ..$ top            : num 36.3
+#   .. .. ..$ discrete_limits:List of 1
+#   .. .. .. ..$ x: chr [1:4] "d" "e" "p" "r"
 #   .. ..$ mapping   :List of 3
-#   .. .. ..$ x        : chr "wt"
-#   .. .. ..$ y        : chr "mpg"
-#   .. .. ..$ panelvar1: chr "am"
+#   .. .. ..$ x        : chr "fl"
+#   .. .. ..$ y        : chr "cty"
+#   .. .. ..$ panelvar1: chr "drv"
 #   .. ..$ range     :List of 4
 #   .. .. ..$ left  : num 33.3
-#   .. .. ..$ right : num 191
-#   .. .. ..$ bottom: num 328
+#   .. .. ..$ right : num 177
+#   .. .. ..$ bottom: num 448
 #   .. .. ..$ top   : num 23.1
 #   ..$ :List of 8
 #   .. ..$ panel     : num 2
 #   .. ..$ row       : int 1
 #   .. ..$ col       : int 2
 #   .. ..$ panel_vars:List of 1
-#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
+#   .. .. ..$ panelvar1: chr "f"
 #   .. ..$ log       :List of 2
 #   .. .. ..$ x: NULL
 #   .. .. ..$ y: NULL
-#   .. ..$ domain    :List of 4
-#   .. .. ..$ left  : num 1.32
-#   .. .. ..$ right : num 5.62
-#   .. .. ..$ bottom: num 9.22
-#   .. .. ..$ top   : num 35.1
+#   .. ..$ domain    :List of 5
+#   .. .. ..$ left           : num 0.4
+#   .. .. ..$ right          : num 5.6
+#   .. .. ..$ bottom         : num 7.7
+#   .. .. ..$ top            : num 36.3
+#   .. .. ..$ discrete_limits:List of 1
+#   .. .. .. ..$ x: chr [1:5] "c" "d" "e" "p" ...
 #   .. ..$ mapping   :List of 3
-#   .. .. ..$ x        : chr "wt"
-#   .. .. ..$ y        : chr "mpg"
-#   .. .. ..$ panelvar1: chr "am"
+#   .. .. ..$ x        : chr "fl"
+#   .. .. ..$ y        : chr "cty"
+#   .. .. ..$ panelvar1: chr "drv"
 #   .. ..$ range     :List of 4
-#   .. .. ..$ left  : num 197
-#   .. .. ..$ right : num 355
-#   .. .. ..$ bottom: num 328
+#   .. .. ..$ left  : num 182
+#   .. .. ..$ right : num 326
+#   .. .. ..$ bottom: num 448
+#   .. .. ..$ top   : num 23.1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 3
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 3
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: chr "r"
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 5
+#   .. .. ..$ left           : num 0.4
+#   .. .. ..$ right          : num 3.6
+#   .. .. ..$ bottom         : num 7.7
+#   .. .. ..$ top            : num 36.3
+#   .. .. ..$ discrete_limits:List of 1
+#   .. .. .. ..$ x: chr [1:3] "e" "p" "r"
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "fl"
+#   .. .. ..$ y        : chr "cty"
+#   .. .. ..$ panelvar1: chr "drv"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 331
+#   .. .. ..$ right : num 475
+#   .. .. ..$ bottom: num 448
 #   .. .. ..$ top   : num 23.1
 #  $ dims  :List of 2
-#   ..$ width : num 400
-#   ..$ height: num 300
-
+#   ..$ width : num 500
+#   ..$ height: num 400
 
 getCoordmap <- function(x, width, height, res) {
   if (inherits(x, "ggplot_build_gtable")) {
@@ -525,6 +610,10 @@ find_panel_info_api <- function(b) {
   coord  <- ggplot2::summarise_coord(b)
   layers <- ggplot2::summarise_layers(b)
 
+  `%NA_OR%` <- function(x, y) {
+    if (is_na(x)) y else x
+  }
+
   # Given x and y scale objects and a coord object, return a list that has
   # the bases of log transformations for x and y, or NULL if it's not a
   # log transform.
@@ -541,8 +630,8 @@ find_panel_info_api <- function(b) {
 
     # First look for log base in scale, then coord; otherwise NULL.
     list(
-      x = get_log_base(xscale$trans) %OR% coord$xlog %OR% NULL,
-      y = get_log_base(yscale$trans) %OR% coord$ylog %OR% NULL
+      x = get_log_base(xscale$trans) %NA_OR% coord$xlog %NA_OR% NULL,
+      y = get_log_base(yscale$trans) %NA_OR% coord$ylog %NA_OR% NULL
     )
   }
 
@@ -570,6 +659,9 @@ find_panel_info_api <- function(b) {
       domain$bottom <- -domain$bottom
     }
 
+    domain <- add_discrete_limits(domain, xscale, "x")
+    domain <- add_discrete_limits(domain, yscale, "y")
+
     domain
   }
 
@@ -689,6 +781,9 @@ find_panel_info_non_api <- function(b, ggplot_format) {
       domain$bottom <- -domain$bottom
     }
 
+    domain <- add_discrete_limits(domain, xscale, "x")
+    domain <- add_discrete_limits(domain, yscale, "y")
+
     domain
   }
 
@@ -851,6 +946,14 @@ find_panel_info_non_api <- function(b, ggplot_format) {
   })
 }
 
+# Use public API for getting the unit's type (grid::unitType(), added in R 4.0)
+# https://github.com/wch/r-source/blob/f9b8a42/src/library/grid/R/unit.R#L179
+getUnitType <- function(u) {
+  tryCatch(
+    get("unitType", envir = asNamespace("grid"))(u),
+    error = function(e) attr(u, "unit", exact = TRUE)
+  )
+}
 
 # Given a gtable object, return the x and y ranges (in pixel dimensions)
 find_panel_ranges <- function(g, res) {
@@ -866,11 +969,11 @@ find_panel_ranges <- function(g, res) {
     if (inherits(x, "unit.list")) {
       # For ggplot2 <= 1.0.1
       vapply(x, FUN.VALUE = logical(1), function(u) {
-        isTRUE(attr(u, "unit", exact = TRUE) == "null")
+        isTRUE(getUnitType(u) == "null")
       })
     } else {
       # For later versions of ggplot2
-      attr(x, "unit", exact = TRUE) == "null"
+      getUnitType(x) == "null"
     }
   }
 
@@ -910,7 +1013,11 @@ find_panel_ranges <- function(g, res) {
 
     # The plotting panels all are 'null' units.
     null_sizes <- rep(NA_real_, length(rel_sizes))
-    null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
+    # Workaround for `[.unit` forbidding zero-length subsets
+    # https://github.com/wch/r-source/blob/f9b8a42/src/library/grid/R/unit.R#L448-L450
+    if (length(null_idx)) {
+      null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
+    }
 
     # Total size allocated for panels is the total image size minus absolute
     # (non-panel) elements.
@@ -995,3 +1102,23 @@ find_panel_ranges <- function(g, res) {
     )
   })
 }
+
+# Remember the x/y limits of discrete axes. This info is
+# necessary to properly inverse map the numeric (i.e., trained)
+# positions back to the data scale, for example:
+# https://github.com/rstudio/shiny/pull/2410#issuecomment-487783828
+# https://github.com/rstudio/shiny/pull/2410#issuecomment-488100881
+#
+# Eventually, we may want to consider storing the entire ggplot2
+# object server-side and querying information from that object
+# as we need it...that's the only way we'll ever be able to
+# faithfully brush examples like this:
+# https://github.com/rstudio/shiny/issues/2411
+add_discrete_limits <- function(domain, scale, var = "x") {
+  var <- match.arg(var, c("x", "y"))
+  if (!is.function(scale$is_discrete) || !is.function(scale$get_limits)) return(domain)
+  if (scale$is_discrete()) {
+    domain$discrete_limits[[var]] <- scale$get_limits()
+  }
+  domain
+}

R/render-table.R

@@ -1,60 +1,81 @@
 #' Table Output
 #'
-#' Creates a reactive table that is suitable for assigning to an \code{output}
-#' slot.
+#' @description
+#' The `tableOuptut()`/`renderTable()` pair creates a reactive table that is
+#' suitable for display small matrices and data frames. The columns are
+#' formatted with [xtable::xtable()].
 #'
-#' The corresponding HTML output tag should be \code{div} and have the CSS
-#' class name \code{shiny-html-output}.
+#' See [renderDataTable()] for data frames that are too big to fit on a single
+#' page.
 #'
 #' @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
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   # table example
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       fluidRow(
+#'         column(12,
+#'           tableOutput('table')
+#'         )
+#'       )
+#'     ),
+#'     server = function(input, output) {
+#'       output$table <- renderTable(iris)
+#'     }
+#'   )
+#' }
 renderTable <- function(expr, striped = FALSE, hover = FALSE,
                         bordered = FALSE, spacing = c("s", "xs", "m", "l"),
                         width = "auto", align = NULL,
                         rownames = FALSE, colnames = TRUE,
                         digits = NULL, na = "NA", ...,
                         env = parent.frame(), quoted = FALSE,
-                        outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+                        outputArgs=list())
+{
+  expr <- get_quosure(expr, env, quoted)
+  func <- quoToFunction(expr, "renderTable")
 
   if (!is.function(spacing)) spacing <- match.arg(spacing)
 

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/runapp.R

@@ -0,0 +1,562 @@
+#' 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
+#' `"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 `"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 `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 `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
+#'   `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 `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 `"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{
+#' # Start app in the current working directory
+#' runApp()
+#'
+#' # Start app in a subdirectory called myapp
+#' runApp("myapp")
+#' }
+#'
+#' ## 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(
+#'       numericInput('n', 'Number of obs', 100),
+#'       plotOutput('plot')
+#'     ),
+#'     server = function(input, output) {
+#'       output$plot <- renderPlot({ hist(runif(input$n)) })
+#'     }
+#'   ))
+#'
+#'
+#'   # Running a Shiny app object
+#'   app <- shinyApp(
+#'     ui = bootstrapPage(
+#'       numericInput('n', 'Number of obs', 100),
+#'       plotOutput('plot')
+#'     ),
+#'     server = function(input, output) {
+#'       output$plot <- renderPlot({ hist(runif(input$n)) })
+#'     }
+#'   )
+#'   runApp(app)
+#' }
+#' @export
+runApp <- function(appDir=getwd(),
+                   port=getOption('shiny.port'),
+                   launch.browser = getOption('shiny.launch.browser', interactive()),
+                   host=getOption('shiny.host', '127.0.0.1'),
+                   workerId="", quiet=FALSE,
+                   display.mode=c("auto", "normal", "showcase"),
+                   test.mode=getOption('shiny.testmode', FALSE)) {
+  on.exit({
+    handlerManager$clear()
+  }, add = TRUE)
+
+  if (isRunning()) {
+    stop("Can't call `runApp()` from within `runApp()`. If your ",
+         "application code contains `runApp()`, please remove it.")
+  }
+
+  # Make warnings print immediately
+  # Set pool.scheduler to support pool package
+  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)
+
+  # ============================================================================
+  # Global onStart/onStop callbacks
+  # ============================================================================
+  # Invoke user-defined onStop callbacks, before the application's internal
+  # onStop callbacks.
+  on.exit({
+    .globals$onStopCallbacks$invoke()
+    .globals$onStopCallbacks <- Callbacks$new()
+  }, add = TRUE)
+
+  require(shiny)
+
+  # ============================================================================
+  # Convert to Shiny app object
+  # ============================================================================
+  appParts <- as.shiny.appobj(appDir)
+
+  # ============================================================================
+  # Initialize app state object
+  # ============================================================================
+  # This is so calls to getCurrentAppState() can be used to find (A) whether an
+  # app is running and (B), get options and data associated with the app.
+  initCurrentAppState(appParts)
+  on.exit(clearCurrentAppState(), add = TRUE)
+  # Any shinyOptions set after this point will apply to the current app only
+  # (and will not persist after the app stops).
+
+  # ============================================================================
+  # shinyOptions
+  # ============================================================================
+  # A unique identifier associated with this run of this application. It is
+  # shared across sessions.
+  shinyOptions(appToken = createUniqueId(8))
+
+  # Set up default cache for app.
+  if (is.null(getShinyOption("cache", default = NULL))) {
+    shinyOptions(cache = cachem::cache_mem(max_size = 200 * 1024^2))
+  }
+
+  # 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.)
+  applyCapturedAppOptions(appParts$appOptions)
+
+  # ============================================================================
+  # runApp options set via shinyApp(options = list(...))
+  # ============================================================================
+  # The lines below set some of the app's running options, which
+  # can be:
+  #   - left unspecified (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'
+
+  # ============================================================================
+  # Hosted environment
+  # ============================================================================
+  workerId(workerId)
+
+  if (inShinyServer()) {
+    # If SHINY_PORT is set, we're running under Shiny Server. Check the version
+    # to make sure it is compatible. Older versions of Shiny Server don't set
+    # SHINY_SERVER_VERSION, those will return "" which is considered less than
+    # any valid version.
+    ver <- Sys.getenv('SHINY_SERVER_VERSION')
+    if (utils::compareVersion(ver, .shinyServerMinVersion) < 0) {
+      warning('Shiny Server v', .shinyServerMinVersion,
+              ' or later is required; please upgrade!')
+    }
+  }
+
+  # ============================================================================
+  # Shinytest
+  # ============================================================================
+  # Set the testmode shinyoption so that this can be read by both the
+  # ShinySession and the UI code (which executes separately from the
+  # ShinySession code).
+  shinyOptions(testmode = test.mode)
+  if (test.mode) {
+    message("Running application in test mode.")
+  }
+
+  # ============================================================================
+  # Showcase mode
+  # ============================================================================
+  # Showcase mode is disabled by default; it must be explicitly enabled in
+  # either the DESCRIPTION file for directory-based apps, or via
+  # the display.mode parameter. The latter takes precedence.
+  setShowcaseDefault(0)
+
+  # If appDir specifies a path, and display mode is specified in the
+  # DESCRIPTION file at that path, apply it here.
+  if (is.character(appDir)) {
+    # if appDir specifies a .R file (single-file Shiny app), look for the
+    # DESCRIPTION in the parent directory
+    desc <- file.path.ci(
+      if (tolower(tools::file_ext(appDir)) == "r")
+        dirname(appDir)
+      else
+        appDir, "DESCRIPTION")
+    if (file.exists(desc)) {
+      con <- file(desc, encoding = checkEncoding(desc))
+      on.exit(close(con), add = TRUE)
+      settings <- read.dcf(con)
+      if ("DisplayMode" %in% colnames(settings)) {
+        mode <- settings[1, "DisplayMode"]
+        if (mode == "Showcase") {
+          setShowcaseDefault(1)
+          if ("IncludeWWW" %in% colnames(settings)) {
+            .globals$IncludeWWW <- as.logical(settings[1, "IncludeWWW"])
+            if (is.na(.globals$IncludeWWW)) {
+              stop("In your Description file, `IncludeWWW` ",
+                   "must be set to `True` (default) or `False`")
+            }
+          } else {
+            .globals$IncludeWWW <- TRUE
+          }
+        }
+      }
+    }
+  }
+
+  ## default is to show the .js, .css and .html files in the www directory
+  ## (if not in showcase mode, this variable will simply be ignored)
+  if (is.null(.globals$IncludeWWW) || is.na(.globals$IncludeWWW)) {
+    .globals$IncludeWWW <- TRUE
+  }
+
+  # If display mode is specified as an argument, apply it (overriding the
+  # value specified in DESCRIPTION, if any).
+  display.mode <- match.arg(display.mode)
+  if (display.mode == "normal") {
+    setShowcaseDefault(0)
+  }
+  else if (display.mode == "showcase") {
+    setShowcaseDefault(1)
+  }
+
+  # ============================================================================
+  # Server port
+  # ============================================================================
+  # determine port if we need to
+  if (is.null(port)) {
+
+    # Try up to 20 random ports. If we don't succeed just plow ahead
+    # with the final value we tried, and let the "real" startServer
+    # somewhere down the line fail and throw the error to the user.
+    #
+    # If we (think we) succeed, save the value as .globals$lastPort,
+    # and try that first next time the user wants a random port.
+
+    for (i in 1:20) {
+      if (!is.null(.globals$lastPort)) {
+        port <- .globals$lastPort
+        .globals$lastPort <- NULL
+      }
+      else {
+        # Try up to 20 random ports
+        while (TRUE) {
+          port <- p_randomInt(3000, 8000)
+          # Reject ports in this range that are considered unsafe by Chrome
+          # http://superuser.com/questions/188058/which-ports-are-considered-unsafe-on-chrome
+          # https://github.com/rstudio/shiny/issues/1784
+          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
+            break
+          }
+        }
+      }
+
+      # Test port to see if we can use it
+      tmp <- try(startServer(host, port, list()), silent=TRUE)
+      if (!inherits(tmp, 'try-error')) {
+        stopServer(tmp)
+        .globals$lastPort <- port
+        break
+      }
+    }
+  }
+
+  # ============================================================================
+  # onStart/onStop callbacks
+  # ============================================================================
+  # Set up the onStop before we call onStart, so that it gets called even if an
+  # error happens in onStart.
+  if (!is.null(appParts$onStop))
+    on.exit(appParts$onStop(), add = TRUE)
+  if (!is.null(appParts$onStart))
+    appParts$onStart()
+
+  # ============================================================================
+  # Start/stop httpuv app
+  # ============================================================================
+  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)
+
+  # ============================================================================
+  # Launch web browser
+  # ============================================================================
+  if (!is.character(port)) {
+    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))
+      launch.browser(appUrl)
+    else if (launch.browser)
+      utils::browseURL(appUrl)
+  } else {
+    appUrl <- NULL
+  }
+
+  # ============================================================================
+  # Application hooks
+  # ============================================================================
+  callAppHook("onAppStart", appUrl)
+  on.exit({
+    callAppHook("onAppStop", appUrl)
+  }, add = TRUE)
+
+  # ============================================================================
+  # Run event loop via httpuv
+  # ============================================================================
+  .globals$reterror <- NULL
+  .globals$retval <- NULL
+  .globals$stopped <- FALSE
+  # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
+  # reactive(), Callbacks$invoke(), and others
+  ..stacktraceoff..(
+    captureStackTraces({
+      while (!.globals$stopped) {
+        ..stacktracefloor..(serviceApp())
+      }
+    })
+  )
+
+  if (isTRUE(.globals$reterror)) {
+    stop(.globals$retval)
+  }
+  else if (.globals$retval$visible)
+    .globals$retval$value
+  else
+    invisible(.globals$retval$value)
+}
+
+#' Stop the currently running Shiny app
+#'
+#' Stops the currently running Shiny app, returning control to the caller of
+#' [runApp()].
+#'
+#' @param returnValue The value that should be returned from
+#'   [runApp()].
+#' @export
+stopApp <- function(returnValue = invisible()) {
+  # reterror will indicate whether retval is an error (i.e. it should be passed
+  # to stop() when the serviceApp loop stops) or a regular value (in which case
+  # it should simply be returned with the appropriate visibility).
+  .globals$reterror <- FALSE
+  ..stacktraceoff..(
+    tryCatch(
+      {
+        captureStackTraces(
+          .globals$retval <- withVisible(..stacktraceon..(force(returnValue)))
+        )
+      },
+      error = function(e) {
+        .globals$retval <- e
+        .globals$reterror <- TRUE
+      }
+    )
+  )
+
+  .globals$stopped <- TRUE
+  httpuv::interrupt()
+}
+
+#' Run Shiny Example Applications
+#'
+#' Launch Shiny example applications, and optionally, your system's web browser.
+#'
+#' @param example The name of the example to run, or `NA` (the default) to
+#'   list the available examples.
+#' @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.
+#' @param host The IPv4 address that the application should listen on. Defaults
+#'   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
+#'   `showcase`, but may be set to `normal` to see the example without
+#'   code or commentary.
+#' @inheritParams runApp
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   # List all available examples
+#'   runExample()
+#'
+#'   # Run one of the examples
+#'   runExample("01_hello")
+#'
+#'   # Print the directory containing the code for all examples
+#'   system.file("examples", package="shiny")
+#' }
+#' @export
+runExample <- function(example=NA,
+                       port=getOption("shiny.port"),
+                       launch.browser = getOption('shiny.launch.browser', interactive()),
+                       host=getOption('shiny.host', '127.0.0.1'),
+                       display.mode=c("auto", "normal", "showcase")) {
+  examplesDir <- system.file('examples', package='shiny')
+  dir <- resolve(examplesDir, example)
+  if (is.null(dir)) {
+    if (is.na(example)) {
+      errFun <- message
+      errMsg <- ''
+    }
+    else {
+      errFun <- stop
+      errMsg <- paste('Example', example, 'does not exist. ')
+    }
+
+    errFun(errMsg,
+           'Valid examples are "',
+           paste(list.files(examplesDir), collapse='", "'),
+           '"')
+  }
+  else {
+    runApp(dir, port = port, host = host, launch.browser = launch.browser,
+           display.mode = display.mode)
+  }
+}
+
+#' Run a gadget
+#'
+#' 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
+#'   [`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
+#'   [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
+#' \dontrun{
+#' library(shiny)
+#'
+#' ui <- fillPage(...)
+#'
+#' server <- function(input, output, session) {
+#'   ...
+#' }
+#'
+#' # Either pass ui/server as separate arguments...
+#' runGadget(ui, server)
+#'
+#' # ...or as a single app object
+#' runGadget(shinyApp(ui, server))
+#' }
+#' @export
+runGadget <- function(app, server = NULL, port = getOption("shiny.port"),
+  viewer = paneViewer(), stopOnCancel = TRUE) {
+
+  if (!is.shiny.appobj(app)) {
+    app <- shinyApp(app, server)
+  }
+
+  if (isTRUE(stopOnCancel)) {
+    app <- decorateServerFunc(app, function(input, output, session) {
+      observeEvent(input$cancel, {
+        stopApp(stop("User cancel", call. = FALSE))
+      })
+    })
+  }
+
+  if (is.null(viewer)) {
+    viewer <- utils::browseURL
+  }
+
+  shiny::runApp(app, port = port, launch.browser = viewer)
+}
+
+# Add custom functionality to a Shiny app object's server func
+decorateServerFunc <- function(appobj, serverFunc) {
+  origServerFuncSource <- appobj$serverFuncSource
+  appobj$serverFuncSource <- function() {
+    origServerFunc <- origServerFuncSource()
+    function(input, output, session) {
+      serverFunc(input, output, session)
+
+      # The clientData and session arguments are optional; check if
+      # each exists
+      args <- argsForServerFunc(origServerFunc, session)
+      do.call(origServerFunc, args)
+    }
+  }
+  appobj
+}

R/server-input-handlers.R

@@ -5,38 +5,36 @@ 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".
+#' the format of "packageName.widgetName". It should be called from the
+#' package's `.onLoad()` function.
 #'
-#' 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
-#' single-element character vector.
+#' 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
-#'   parameters:
-#'    \enumerate{
-#'      \item{The value of this input as provided by the client, deserialized
-#'      using jsonlite.}
-#'      \item{The \code{shinysession} in which the input exists.}
-#'      \item{The name of the input.}
-#'    }
-#' @param force If \code{TRUE}, will overwrite any existing handler without
-#' warning. If \code{FALSE}, will throw an error if this class already has
-#' a handler defined.
+#'   `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 `shinysession` in which the
+#'   input exists.} \item{The name of the input.} }
+#' @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{
 #' # Register an input handler which rounds a input number to the nearest integer
+#' # In a package, this should be called from the .onLoad function.
 #' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
 #'   if (is.null(x)) return(NA)
 #'   round(x)
@@ -48,7 +46,7 @@ inputHandlers <- Map$new()
 #' }
 #'
 #' }
-#' @seealso \code{\link{removeInputHandler}}
+#' @seealso [removeInputHandler()]
 #' @export
 registerInputHandler <- function(type, fun, force=FALSE){
   if (inputHandlers$containsKey(type) && !force){
@@ -63,9 +61,9 @@ 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)
@@ -103,8 +101,8 @@ applyInputHandler <- function(name, val, shinysession) {
 #' values.
 #'
 #' The raw input values should be in a named list. Some values may have names
-#' like \code{"x:shiny.date"}. This function would apply the \code{"shiny.date"}
-#' input handler to the value, and then rename the result to \code{"x"}, in the
+#' 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.

R/server-resource-paths.R

@@ -0,0 +1,169 @@
+.globals$resourcePaths <- list()
+.globals$resources <- list()
+
+#' Resource Publishing
+#'
+#' 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. 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.
+#'
+#' @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) {
+  if (length(prefix) != 1) stop("prefix must be of length 1")
+  if (grepl("^\\.+$", prefix)) stop("prefix can't be composed of dots only")
+  if (!grepl('[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, "'")
+    }
+  )
+
+  # # 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."
+  #     )
+  #   }
+  # }
+
+  # If a shiny app is currently running, dynamically register this path with
+  # the corresponding httpuv server object.
+  if (!is.null(getShinyOption("server", default = NULL)))
+  {
+    getShinyOption("server")$setStaticPath(.list = stats::setNames(normalizedPath, prefix))
+  }
+
+  # .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='')
+
+  return(resInfo$func(subreq))
+}

R/server.R

@@ -22,133 +22,34 @@ registerClient <- function(client) {
 }
 
 
-.globals$resourcePaths <- list()
-.globals$resources <- list()
-
 .globals$showcaseDefault <- 0
 
 .globals$showcaseOverride <- FALSE
 
-#' 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.
-#'
-#' @param prefix The URL prefix (without slashes). Valid characters are a-z,
-#'   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.
-#'
-#' @seealso \code{\link{singleton}}
-#'
-#' @examples
-#' addResourcePath('datasets', system.file('data', package='datasets'))
-#' @export
-addResourcePath <- function(prefix, directoryPath) {
-  prefix <- prefix[1]
-  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case = TRUE, perl = TRUE)) {
-    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, "'")
-    }
-  )
-
-  # 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$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)
-  )
-}
-
-# 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='')
-
-  return(resInfo$func(subreq))
-}
 
 #' Define Server Functionality
 #'
-#' 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
-#' function (as the last expression in the code), without calling
-#' \code{shinyServer()}.
+#' @description \lifecycle{superseded}
 #'
-#' Call \code{shinyServer} from your application's \code{server.R}
+#' @description 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 `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
+#' `shinyServer()`.
+#'
+#' 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](https://rstudio.github.io/shiny/tutorial/) for more
 #' on how to write a server function.
 #'
 #' @param func The server function for this application. See the details section
@@ -175,7 +76,19 @@ resourcePathHandler <- function(req) {
 #' }
 #' }
 #' @export
+#' @keywords internal
 shinyServer <- function(func) {
+  if (in_devmode()) {
+    shinyDeprecated(
+      "0.10.0", "shinyServer()",
+      details = paste0(
+        "When removing `shinyServer()`, ",
+        "ensure that the last expression returned from server.R ",
+        "is the function normally supplied to `shinyServer(func)`."
+      )
+    )
+  }
+
   .globals$server <- list(func)
   invisible(func)
 }
@@ -209,6 +122,8 @@ decodeMessage <- function(data) {
   return(mainMessage)
 }
 
+autoReloadCallbacks <- Callbacks$new()
+
 createAppHandlers <- function(httpHandlers, serverFuncSource) {
   appvars <- new.env()
   appvars$server <- NULL
@@ -234,6 +149,22 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
         return(TRUE)
       }
 
+      if (identical(ws$request$PATH_INFO, "/autoreload/")) {
+        if (!get_devmode_option("shiny.autoreload", FALSE)) {
+          ws$close()
+          return(TRUE)
+        }
+
+        callbackHandle <- autoReloadCallbacks$register(function() {
+          ws$send("autoreload")
+          ws$close()
+        })
+        ws$onClose(function() {
+          callbackHandle()
+        })
+        return(TRUE)
+      }
+
       if (!is.null(getOption("shiny.observer.error", NULL))) {
         warning(
           call. = FALSE,
@@ -458,6 +389,49 @@ startApp <- function(appObj, port, host, quiet) {
     ),
     .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"),
@@ -513,601 +487,17 @@ serviceApp <- function() {
 
 .shinyServerMinVersion <- '0.3.4'
 
-# Global flag that's TRUE whenever we're inside of the scope of a call to runApp
-.globals$running <- FALSE
-
 #' Check whether a Shiny application is running
 #'
 #' This function tests whether a Shiny application is currently running.
 #'
-#' @return \code{TRUE} if a Shiny application is currently running. Otherwise,
-#'   \code{FALSE}.
+#' @return `TRUE` if a Shiny application is currently running. Otherwise,
+#'   `FALSE`.
 #' @export
 isRunning <- function() {
-  .globals$running
+  !is.null(getCurrentAppState())
 }
 
-#' 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
-#' 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
-#' 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
-#'    expression that produces a Shiny app object.
-#'   \item A list with \code{ui} and \code{server} components.
-#'   \item A Shiny app object created by \code{\link{shinyApp}}.
-#'   }
-#' @param port The TCP port that the application should listen on. If the
-#'   \code{port} is not specified, and the \code{shiny.port} option is set (with
-#'   \code{options(shiny.port = XX)}), then that port will be used. Otherwise,
-#'   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
-#'   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.
-#' @param test.mode Should the application be launched in test mode? This is
-#'   only used for recording or running automated tests. Defaults to the
-#'   \code{shiny.testmode} option, or FALSE if the option is not set.
-#'
-#' @examples
-#' \dontrun{
-#' # Start app in the current working directory
-#' runApp()
-#'
-#' # Start app in a subdirectory called myapp
-#' runApp("myapp")
-#' }
-#'
-#' ## 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(
-#'       numericInput('n', 'Number of obs', 100),
-#'       plotOutput('plot')
-#'     ),
-#'     server = function(input, output) {
-#'       output$plot <- renderPlot({ hist(runif(input$n)) })
-#'     }
-#'   ))
-#'
-#'
-#'   # Running a Shiny app object
-#'   app <- shinyApp(
-#'     ui = bootstrapPage(
-#'       numericInput('n', 'Number of obs', 100),
-#'       plotOutput('plot')
-#'     ),
-#'     server = function(input, output) {
-#'       output$plot <- renderPlot({ hist(runif(input$n)) })
-#'     }
-#'   )
-#'   runApp(app)
-#' }
-#' @export
-runApp <- function(appDir=getwd(),
-                   port=getOption('shiny.port'),
-                   launch.browser=getOption('shiny.launch.browser',
-                                            interactive()),
-                   host=getOption('shiny.host', '127.0.0.1'),
-                   workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase"),
-                   test.mode=getOption('shiny.testmode', FALSE)) {
-  on.exit({
-    handlerManager$clear()
-  }, add = TRUE)
-
-  if (.globals$running) {
-    stop("Can't call `runApp()` from within `runApp()`. If your ",
-         "application code contains `runApp()`, please remove it.")
-  }
-  .globals$running <- TRUE
-  on.exit({
-    .globals$running <- FALSE
-  }, add = TRUE)
-
-  # Enable per-app Shiny options, for shinyOptions() and getShinyOption().
-  oldOptionSet <- .globals$options
-  on.exit({
-    .globals$options <- oldOptionSet
-  },add = TRUE)
-
-  # 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(
-    # 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()) {
-    # If SHINY_PORT is set, we're running under Shiny Server. Check the version
-    # to make sure it is compatible. Older versions of Shiny Server don't set
-    # SHINY_SERVER_VERSION, those will return "" which is considered less than
-    # any valid version.
-    ver <- Sys.getenv('SHINY_SERVER_VERSION')
-    if (utils::compareVersion(ver, .shinyServerMinVersion) < 0) {
-      warning('Shiny Server v', .shinyServerMinVersion,
-              ' or later is required; please upgrade!')
-    }
-  }
-
-  # Showcase mode is disabled by default; it must be explicitly enabled in
-  # either the DESCRIPTION file for directory-based apps, or via
-  # 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)) {
-    # if appDir specifies a .R file (single-file Shiny app), look for the
-    # DESCRIPTION in the parent directory
-    desc <- file.path.ci(
-      if (tolower(tools::file_ext(appDir)) == "r")
-        dirname(appDir)
-      else
-        appDir, "DESCRIPTION")
-    if (file.exists(desc)) {
-      con <- file(desc, encoding = checkEncoding(desc))
-      on.exit(close(con), add = TRUE)
-      settings <- read.dcf(con)
-      if ("DisplayMode" %in% colnames(settings)) {
-        mode <- settings[1, "DisplayMode"]
-        if (mode == "Showcase") {
-          setShowcaseDefault(1)
-          if ("IncludeWWW" %in% colnames(settings)) {
-            .globals$IncludeWWW <- as.logical(settings[1, "IncludeWWW"])
-            if (is.na(.globals$IncludeWWW)) {
-              stop("In your Description file, `IncludeWWW` ",
-                   "must be set to `True` (default) or `False`")
-            }
-          } else {
-            .globals$IncludeWWW <- TRUE
-          }
-        }
-      }
-    }
-  }
-
-  ## default is to show the .js, .css and .html files in the www directory
-  ## (if not in showcase mode, this variable will simply be ignored)
-  if (is.null(.globals$IncludeWWW) || is.na(.globals$IncludeWWW)) {
-    .globals$IncludeWWW <- TRUE
-  }
-
-  # If display mode is specified as an argument, apply it (overriding the
-  # value specified in DESCRIPTION, if any).
-  display.mode <- match.arg(display.mode)
-  if (display.mode == "normal") {
-    setShowcaseDefault(0)
-  }
-  else if (display.mode == "showcase") {
-    setShowcaseDefault(1)
-  }
-
-  require(shiny)
-
-  # determine port if we need to
-  if (is.null(port)) {
-
-    # Try up to 20 random ports. If we don't succeed just plow ahead
-    # with the final value we tried, and let the "real" startServer
-    # somewhere down the line fail and throw the error to the user.
-    #
-    # If we (think we) succeed, save the value as .globals$lastPort,
-    # and try that first next time the user wants a random port.
-
-    for (i in 1:20) {
-      if (!is.null(.globals$lastPort)) {
-        port <- .globals$lastPort
-        .globals$lastPort <- NULL
-      }
-      else {
-        # Try up to 20 random ports
-        while (TRUE) {
-          port <- p_randomInt(3000, 8000)
-          # Reject ports in this range that are considered unsafe by Chrome
-          # http://superuser.com/questions/188058/which-ports-are-considered-unsafe-on-chrome
-          # https://github.com/rstudio/shiny/issues/1784
-          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
-            break
-          }
-        }
-      }
-
-      # Test port to see if we can use it
-      tmp <- try(startServer(host, port, list()), silent=TRUE)
-      if (!inherits(tmp, 'try-error')) {
-        stopServer(tmp)
-        .globals$lastPort <- port
-        break
-      }
-    }
-  }
-
-  # 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 onStop before we call onStart, so that it gets called even if an
-  # error happens in onStart.
-  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)) {
-    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))
-      launch.browser(appUrl)
-    else if (launch.browser)
-      utils::browseURL(appUrl)
-  } else {
-    appUrl <- NULL
-  }
-
-  # call application hooks
-  callAppHook("onAppStart", appUrl)
-  on.exit({
-    callAppHook("onAppStop", appUrl)
-  }, add = TRUE)
-
-  .globals$reterror <- NULL
-  .globals$retval <- NULL
-  .globals$stopped <- FALSE
-  # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
-  # reactive(), Callbacks$invoke(), and others
-  ..stacktraceoff..(
-    captureStackTraces({
-      while (!.globals$stopped) {
-        ..stacktracefloor..(serviceApp())
-        Sys.sleep(0.001)
-      }
-    })
-  )
-
-  if (isTRUE(.globals$reterror)) {
-    stop(.globals$retval)
-  }
-  else if (.globals$retval$visible)
-    .globals$retval$value
-  else
-    invisible(.globals$retval$value)
-}
-
-#' Stop the currently running Shiny app
-#'
-#' Stops the currently running Shiny app, returning control to the caller of
-#' \code{\link{runApp}}.
-#'
-#' @param returnValue The value that should be returned from
-#'   \code{\link{runApp}}.
-#' @export
-stopApp <- function(returnValue = invisible()) {
-  # reterror will indicate whether retval is an error (i.e. it should be passed
-  # to stop() when the serviceApp loop stops) or a regular value (in which case
-  # it should simply be returned with the appropriate visibility).
-  .globals$reterror <- FALSE
-  ..stacktraceoff..(
-    tryCatch(
-      {
-        captureStackTraces(
-          .globals$retval <- withVisible(..stacktraceon..(force(returnValue)))
-        )
-      },
-      error = function(e) {
-        .globals$retval <- e
-        .globals$reterror <- TRUE
-      }
-    )
-  )
-
-  .globals$stopped <- TRUE
-  httpuv::interrupt()
-}
-
-#' Run Shiny Example Applications
-#'
-#' 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
-#'   list the available examples.
-#' @param port The TCP port that the application should listen on. Defaults to
-#'   choosing 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.
-#' @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.
-#' @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
-#'   code or commentary.
-#'
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   # List all available examples
-#'   runExample()
-#'
-#'   # Run one of the examples
-#'   runExample("01_hello")
-#'
-#'   # Print the directory containing the code for all examples
-#'   system.file("examples", package="shiny")
-#' }
-#' @export
-runExample <- function(example=NA,
-                       port=NULL,
-                       launch.browser=getOption('shiny.launch.browser',
-                                                interactive()),
-                       host=getOption('shiny.host', '127.0.0.1'),
-                       display.mode=c("auto", "normal", "showcase")) {
-  examplesDir <- system.file('examples', package='shiny')
-  dir <- resolve(examplesDir, example)
-  if (is.null(dir)) {
-    if (is.na(example)) {
-      errFun <- message
-      errMsg <- ''
-    }
-    else {
-      errFun <- stop
-      errMsg <- paste('Example', example, 'does not exist. ')
-    }
-
-    errFun(errMsg,
-           'Valid examples are "',
-           paste(list.files(examplesDir), collapse='", "'),
-           '"')
-  }
-  else {
-    runApp(dir, port = port, host = host, launch.browser = launch.browser,
-           display.mode = display.mode)
-  }
-}
-
-#' Run a gadget
-#'
-#' Similar to \code{runApp}, but handles \code{input$cancel} automatically, and
-#' if running in RStudio, defaults to viewing the app in the Viewer pane.
-#'
-#' @param app Either a Shiny app object as created by
-#'   \code{\link[=shiny]{shinyApp}} et al, or, a UI object.
-#' @param server Ignored if \code{app} is a Shiny app object; otherwise, passed
-#'   along to \code{shinyApp} (i.e. \code{shinyApp(ui = app, server = server)}).
-#' @param port See \code{\link[=shiny]{runApp}}.
-#' @param viewer Specify where the gadget should be displayed--viewer pane,
-#'   dialog window, or external browser--by passing in a call to one of the
-#'   \code{\link{viewer}} functions.
-#' @param stopOnCancel If \code{TRUE} (the default), then an \code{observeEvent}
-#'   is automatically created that handles \code{input$cancel} by calling
-#'   \code{stopApp()} with an error. Pass \code{FALSE} if you want to handle
-#'   \code{input$cancel} yourself.
-#' @return The value returned by the gadget.
-#'
-#' @examples
-#' \dontrun{
-#' library(shiny)
-#'
-#' ui <- fillPage(...)
-#'
-#' server <- function(input, output, session) {
-#'   ...
-#' }
-#'
-#' # Either pass ui/server as separate arguments...
-#' runGadget(ui, server)
-#'
-#' # ...or as a single app object
-#' runGadget(shinyApp(ui, server))
-#' }
-#' @export
-runGadget <- function(app, server = NULL, port = getOption("shiny.port"),
-  viewer = paneViewer(), stopOnCancel = TRUE) {
-
-  if (!is.shiny.appobj(app)) {
-    app <- shinyApp(app, server)
-  }
-
-  if (isTRUE(stopOnCancel)) {
-    app <- decorateServerFunc(app, function(input, output, session) {
-      observeEvent(input$cancel, {
-        stopApp(stop("User cancel", call. = FALSE))
-      })
-    })
-  }
-
-  if (is.null(viewer)) {
-    viewer <- utils::browseURL
-  }
-
-  shiny::runApp(app, port = port, launch.browser = viewer)
-}
-
-# Add custom functionality to a Shiny app object's server func
-decorateServerFunc <- function(appobj, serverFunc) {
-  origServerFuncSource <- appobj$serverFuncSource
-  appobj$serverFuncSource <- function() {
-    origServerFunc <- origServerFuncSource()
-    function(input, output, session) {
-      serverFunc(input, output, session)
-
-      # The clientData and session arguments are optional; check if
-      # each exists
-      args <- argsForServerFunc(origServerFunc, session)
-      do.call(origServerFunc, args)
-    }
-  }
-  appobj
-}
-
-#' Viewer options
-#'
-#' Use these functions to control where the gadget is displayed in RStudio (or
-#' other R environments that emulate RStudio's viewer pane/dialog APIs). If
-#' viewer APIs are not available in the current R environment, then the gadget
-#' will be displayed in the system's default web browser (see
-#' \code{\link[utils]{browseURL}}).
-#'
-#' @return A function that takes a single \code{url} parameter, suitable for
-#'   passing as the \code{viewer} argument of \code{\link{runGadget}}.
-#'
-#' @rdname viewer
-#' @name viewer
-NULL
-
-#' @param minHeight The minimum height (in pixels) desired to show the gadget in
-#'   the viewer pane. If a positive number, resize the pane if necessary to show
-#'   at least that many pixels. If \code{NULL}, use the existing viewer pane
-#'   size. If \code{"maximize"}, use the maximum available vertical space.
-#' @rdname viewer
-#' @export
-paneViewer <- function(minHeight = NULL) {
-  viewer <- getOption("viewer")
-  if (is.null(viewer)) {
-    utils::browseURL
-  } else {
-    function(url) {
-      viewer(url, minHeight)
-    }
-  }
-}
-
-#' @param dialogName The window title to display for the dialog.
-#' @param width,height The desired dialog width/height, in pixels.
-#' @rdname viewer
-#' @export
-dialogViewer <- function(dialogName, width = 600, height = 600) {
-  viewer <- getOption("shinygadgets.showdialog")
-  if (is.null(viewer)) {
-    utils::browseURL
-  } else {
-    function(url) {
-      viewer(dialogName, url, width = width, height = height)
-    }
-  }
-}
-
-#' @param browser See \code{\link[utils]{browseURL}}.
-#' @rdname viewer
-#' @export
-browserViewer <- function(browser = getOption("browser")) {
-  function(url) {
-    utils::browseURL(url, browser = browser)
-  }
-}
 
 # Returns TRUE if we're running in Shiny Server or other hosting environment,
 # otherwise returns FALSE.
@@ -1118,5 +508,5 @@ inShinyServer <- function() {
 # This check was moved out of the main function body because of an issue with
 # the RStudio debugger. (#1474)
 isEmptyMessage <- function(msg) {
-  identical(charToRaw("\003\xe9"), msg)
+  identical(as.raw(c(0x03, 0xe9)), msg)
 }

R/shiny-options.R

@@ -8,62 +8,249 @@ getShinyOption <- function(name, default = NULL) {
   # Make sure to use named (not numeric) indexing
   name <- as.character(name)
 
-  if (name %in% names(.globals$options))
-    .globals$options[[name]]
-  else
-    default
+  # Check if there's a current session
+  session <- getDefaultReactiveDomain()
+  if (!is.null(session)) {
+    if (name %in% names(session$options)) {
+      return(session$options[[name]])
+    } else {
+      return(default)
+    }
+  }
+
+  # Check if there's a current app
+  app_state <- getCurrentAppState()
+  if (!is.null(app_state)) {
+    if (name %in% names(app_state$options)) {
+      return(app_state$options[[name]])
+    } else {
+      return(default)
+    }
+  }
+
+  # If we got here, look in global options
+  if (name %in% names(.globals$options)) {
+    return(.globals$options[[name]])
+  } else {
+    return(default)
+  }
 }
 
 #' Get or set Shiny options
 #'
-#' \code{getShinyOption} retrieves the value of a Shiny option.
-#' \code{shinyOptions} sets the value of Shiny options; it can also be used to
-#' return a list of all currently-set Shiny options.
+#' @description
 #'
-#' There is a global option set, which is available by default. When a Shiny
-#' application is run with \code{\link{runApp}}, that option set is duplicated
-#' and the new option set is available for getting or setting values. If options
-#' are set from global.R, app.R, ui.R, or server.R, or if they are set from
-#' inside the server function, then the options will be scoped to the
-#' application. When the application exits, the new option set is discarded and
-#' the global option set is restored.
+#' There are two mechanisms for working with options for Shiny. One is the
+#' [options()] function, which is part of base R, and the other is the
+#' `shinyOptions()` function, which is in the Shiny package. The reason for
+#' these two mechanisms is has to do with legacy code and scoping.
 #'
-#' @param ... Options to set, with the form \code{name = value}.
+#' The [options()] function sets options globally, for the duration of the R
+#' process. The [getOption()] function retrieves the value of an option. All
+#' shiny related options of this type are prefixed with `"shiny."`.
 #'
-#' @examples
-#' \dontrun{
-#' shinyOptions(myOption = 10)
-#' getShinyOption("myOption")
+#' The `shinyOptions()` function sets the value of a shiny option, but unlike
+#' `options()`, it is not always global in scope; the options may be scoped
+#' globally, to an application, or to a user session in an application,
+#' depending on the context. The `getShinyOption()` function retrieves a value
+#' of a shiny option. Currently, the options set via `shinyOptions` are for
+#' internal use only.
+#'
+#' @section Options with `options()`:
+#'
+#' \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 `r version_jquery` 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.autoload.r (defaults to `TRUE`)}{If `TRUE`, then the R/
+#'   of a shiny app will automatically be sourced.}
+#' \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.}
+#' \item{shiny.devmode (defaults to `NULL`)}{Option to enable Shiny Developer Mode. When set,
+#'   different default `getOption(key)` values will be returned. See [devmode()] for more details.}
+### Not documenting as 'shiny.devmode.verbose' is for niche use only
+# ' \item{shiny.devmode.verbose (defaults to `TRUE`)}{If `TRUE`, will display messages printed
+# '   about which options are being set. See [devmode()] for more details. }
+### (end not documenting 'shiny.devmode.verbose')
 #' }
+#'
+#'
+#' @section Scoping for `shinyOptions()`:
+#'
+#'   There are three levels of scoping for `shinyOptions()`: global,
+#'   application, and session.
+#'
+#'   The global option set is available by default. Any calls to
+#'   `shinyOptions()` and `getShinyOption()` outside of an app will access the
+#'   global option set.
+#'
+#'   When a Shiny application is run with [runApp()], the global option set is
+#'   duplicated and the new option set is available at the application level. If
+#'   options are set from `global.R`, `app.R`, `ui.R`, or `server.R` (but
+#'   outside of the server function), then the application-level options will be
+#'   modified.
+#'
+#'   Each time a user session is started, the application-level option set is
+#'   duplicated, for that session. If the options are set from inside the server
+#'   function, then they will be scoped to the session.
+#'
+#' @section Options with `shinyOptions()`:
+#'
+#'   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{cache}{A caching object that will be used by
+#'   [renderCachedPlot()]. If not specified, a [cachem::cache_mem()] will be
+#'   used.} }
+#'
+#' @param ... Options to set, with the form `name = value`.
+#' @aliases shiny-options
 #' @export
 shinyOptions <- function(...) {
   newOpts <- list(...)
 
   if (length(newOpts) > 0) {
+    # If we're within a session, modify at the session level.
+    session <- getDefaultReactiveDomain()
+    if (!is.null(session)) {
+      # Modify session-level-options
+      session$options <- dropNulls(mergeVectors(session$options, newOpts))
+      return(invisible(session$options))
+    }
+
+    # If not in a session, but we have a currently running app, modify options
+    # at the app level.
+    app_state <- getCurrentAppState()
+    if (!is.null(app_state)) {
+      # Modify app-level options
+      app_state$options <- dropNulls(mergeVectors(app_state$options, newOpts))
+      return(invisible(app_state$options))
+    }
+
+    # If no currently running app, modify global options and return them.
     .globals$options <- dropNulls(mergeVectors(.globals$options, newOpts))
-    invisible(.globals$options)
-  } else {
-    .globals$options
+    return(invisible(.globals$options))
   }
-}
 
+  # If not setting any options, just return current option set, visibly.
 
-# Eval an expression with a new option set
-withLocalOptions <- function(expr) {
-  oldOptionSet <- .globals$options
-  on.exit(.globals$options <- oldOptionSet)
+  session <- getDefaultReactiveDomain()
+  if (!is.null(session)) {
+    return(session$options)
+  }
 
-  expr
+  app_state <- getCurrentAppState()
+  if (!is.null(app_state)) {
+    return(app_state$options)
+  }
+
+  return(.globals$options)
 }
 
 
 # Get specific shiny options and put them in a list, reset those shiny options,
 # and then return the options list. This should be during the creation of a
-# shiny app object, which happens before another option frame is added to the
-# options stack (the new option frame is added when the app is run). This
-# function "consumes" the options when the shinyApp object is created, so the
-# options won't affect another app that is created later.
-consumeAppOptions <- function() {
+# shiny app object. This function "consumes" the options when the shinyApp
+# object is created, so the options won't affect another app that is created
+# later.
+#
+# ==== Example ====
+# shinyOptions(bookmarkStore = 1234)
+# # This now returns 1234.
+# getShinyOption("bookmarkStore")
+#
+# # Creating the app captures the bookmarkStore option and clears it.
+# s <- shinyApp(
+#   fluidPage(verbatimTextOutput("txt")),
+#   function(input, output) {
+#     output$txt <- renderText(getShinyOption("bookmarkStore"))
+#   }
+# )
+#
+# # This now returns NULL.
+# getShinyOption("bookmarkStore")
+#
+# When running the app, the app will display "1234"
+# runApp(s)
+#
+# # After quitting the app, this still returns NULL.
+# getShinyOption("bookmarkStore")
+# ==================
+#
+# If another app had been created after s was created, but before s was run,
+# then it would capture the value of "bookmarkStore" at the time of creation.
+captureAppOptions <- function() {
   options <- list(
     appDir = getwd(),
     bookmarkStore = getShinyOption("bookmarkStore")
@@ -74,9 +261,9 @@ consumeAppOptions <- function() {
   options
 }
 
-# Do the inverse of consumeAppOptions. This should be called once the app is
+# Do the inverse of captureAppOptions. This should be called once the app is
 # started.
-unconsumeAppOptions <- function(options) {
+applyCapturedAppOptions <- function(options) {
   if (!is.null(options)) {
     do.call(shinyOptions, options)
   }

R/shiny-package.R

@@ -0,0 +1,34 @@
+# See also R/reexports.R
+
+## usethis namespace: start
+## usethis namespace: end
+#' @importFrom lifecycle deprecated
+#' @importFrom grDevices dev.set dev.cur
+#' @importFrom fastmap fastmap
+#' @importFrom promises %...!%
+#' @importFrom promises %...>%
+#' @importFrom promises
+#'    promise promise_resolve promise_reject is.promising
+#'    as.promise
+#' @importFrom rlang
+#'    quo enquo as_function get_expr get_env new_function enquos
+#'    eval_tidy expr pairlist2 new_quosure enexpr as_quosure is_quosure inject
+#'    enquos0 zap_srcref %||% is_na
+#'    is_false
+#'    missing_arg is_missing maybe_missing
+#' @importFrom ellipsis
+#'    check_dots_empty check_dots_unnamed
+#' @import htmltools
+#' @import httpuv
+#' @import xtable
+#' @import R6
+#' @import mime
+NULL
+
+# It's necessary to Depend on methods so Rscript doesn't fail. It's necessary
+# to import(methods) in NAMESPACE so R CMD check doesn't complain. This
+# approach isn't foolproof because Rscript -e pkgname::func() doesn't actually
+# cause methods to be attached, but it's not a problem for shiny::runApp()
+# since we call require(shiny) as part of loading the app.
+#' @import methods
+NULL

R/shinyapp.R

@@ -3,40 +3,41 @@
 #' 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 \code{runApp} call
+#'   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 \code{width} and
-#'   \code{height} parameters which provide a hint to the embedding environment
+#'   "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 \code{GET}
-#'   request to determine whether the \code{ui} should be used to handle the
+#' @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
@@ -70,10 +71,10 @@
 #'   runApp(app)
 #' }
 #' @export
-shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
+shinyApp <- function(ui, server, onStart=NULL, options=list(),
                      uiPattern="/", enableBookmarking=NULL) {
-  if (is.null(server)) {
-    stop("`server` missing from shinyApp")
+  if (!is.function(server)) {
+    stop("`server` must be a function", call. = FALSE)
   }
 
   # Ensure that the entire path is a match
@@ -92,8 +93,7 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
 
   # Store the appDir and bookmarking-related options, so that we can read them
   # from within the app.
-  shinyOptions(appDir = getwd())
-  appOptions <- consumeAppOptions()
+  appOptions <- captureAppOptions()
 
   structure(
     list(
@@ -113,7 +113,10 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
 #' @export
 shinyAppDir <- function(appDir, options=list()) {
   if (!utils::file_test('-d', appDir)) {
-    stop("No Shiny application exists at the path \"", appDir, "\"")
+    rlang::abort(
+      paste0("No Shiny application exists at the path \"", appDir, "\""),
+      class = "invalidShinyAppDir"
+    )
   }
 
   # In case it's a relative path, convert to absolute (so we're not adversely
@@ -125,7 +128,10 @@ shinyAppDir <- function(appDir, options=list()) {
   } else if (file.exists.ci(appDir, "app.R")) {
     shinyAppDir_appR("app.R", appDir, options = options)
   } else {
-    stop("App dir must contain either app.R or server.R.")
+    rlang::abort(
+      "App dir must contain either app.R or server.R.",
+      class = "invalidShinyAppDir"
+    )
   }
 }
 
@@ -141,10 +147,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.
@@ -155,7 +172,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]]
         }
@@ -185,7 +202,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]]
       }
@@ -215,14 +232,24 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
+    # 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"))
+    }
     monitorHandle <<- initAutoReloadMonitor(appDir)
-    if (file.exists(file.path.ci(appDir, "global.R")))
-      sourceUTF8(file.path.ci(appDir, "global.R"))
   }
   onStop <- function() {
     setwd(oldwd)
-    monitorHandle()
-    monitorHandle <<- NULL
+    # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured
+    # This will cause `onStop` to be called.
+    #   The `oldwd` will exist, but `monitorHandle` is not a function yet.
+    if (is.function(monitorHandle)) {
+      monitorHandle()
+      monitorHandle <<- NULL
+    }
   }
 
   structure(
@@ -267,9 +294,11 @@ initAutoReloadMonitor <- function(dir) {
     ".*\\.(r|html?|js|css|png|jpe?g|gif)$")
 
   lastValue <- NULL
-  obs <- observe({
-    files <- sort(list.files(dir, pattern = filePattern, recursive = TRUE,
-      ignore.case = TRUE))
+  observeLabel <- paste0("File Auto-Reload - '", basename(dir), "'")
+  obs <- observe(label = observeLabel, {
+    files <- sort_c(
+      list.files(dir, pattern = filePattern, recursive = TRUE, ignore.case = TRUE)
+    )
     times <- file.info(files)$mtime
     names(times) <- files
 
@@ -279,19 +308,95 @@ initAutoReloadMonitor <- function(dir) {
     } else if (!identical(lastValue, times)) {
       # We've changed!
       lastValue <<- times
-      for (session in appsByToken$values()) {
-        session$reload()
-      }
+      autoReloadCallbacks$invoke()
     }
 
     invalidateLater(getOption("shiny.autoreload.interval", 500))
   })
 
+  onStop(obs$destroy)
+
   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. If `appDir` is `NULL` or
+#'   not supplied, the nearest enclosing directory that is a Shiny app, starting
+#'   with the current directory, is used.
+#' @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=NULL, renv=new.env(parent=globalenv()), globalrenv=globalenv()){
+  require(shiny)
+
+  if (is.null(appDir)) {
+    appDir <- findEnclosingApp(".")
+  }
+
+  descFile <- file.path.ci(appDir, "DESCRIPTION")
+  if (file.exists(file.path.ci(appDir, "NAMESPACE")) ||
+      (file.exists(descFile) &&
+       identical(as.character(read.dcf(descFile, fields = "Type")), "Package")))
+  {
+    warning(
+      "Loading R/ subdirectory for Shiny application, but this directory appears ",
+      "to contain an R package. Sourcing files in R/ may cause unexpected behavior."
+    )
+  }
+
+  if (!is.null(globalrenv)){
+    # Evaluate global.R, if it exists.
+    globalPath <- file.path.ci(appDir, "global.R")
+    if (file.exists(globalPath)){
+      withr::with_dir(appDir, {
+        sourceUTF8(basename(globalPath), envir=globalrenv)
+      })
+    }
+  }
+
+
+  helpersDir <- file.path(appDir, "R")
+
+  disabled <- list.files(helpersDir, pattern="^_disable_autoload\\.r$", recursive=FALSE, ignore.case=TRUE)
+  if (length(disabled) > 0){
+    return(invisible(renv))
+  }
+
+  helpers <- list.files(helpersDir, pattern="\\.[rR]$", recursive=FALSE, full.names=TRUE)
+  # Ensure files in R/ are sorted according to the 'C' locale before sourcing.
+  # This convention is based on the default for packages. For details, see:
+  # https://cran.r-project.org/doc/manuals/r-release/R-exts.html#The-DESCRIPTION-file
+  helpers <- sort_c(helpers)
+  helpers <- normalizePath(helpers)
+
+  withr::with_dir(appDir, {
+    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)
@@ -301,12 +406,25 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
   # 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()))
+      wasDir <- setwd(appDir)
+      on.exit(setwd(wasDir))
+
+      # TODO: we should support hot reloading on R/*.R changes.
+      # 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())
+        loadSupport(appDir, renv=sharedEnv, globalrenv=NULL)
+      } else {
+        sharedEnv <- globalenv()
+      }
+      result <- sourceUTF8(fullpath, envir = new.env(parent = sharedEnv))
 
       if (!is.shiny.appobj(result))
         stop("app.R did not return a shiny.appobj object.")
 
-      unconsumeAppOptions(result$appOptions)
+      applyCapturedAppOptions(result$appOptions)
 
       return(result)
     }
@@ -344,15 +462,23 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
-    monitorHandle <<- initAutoReloadMonitor(appDir)
     if (!is.null(appObj()$onStart)) appObj()$onStart()
+    monitorHandle <<- initAutoReloadMonitor(appDir)
+    invisible()
   }
   onStop <- function() {
     setwd(oldwd)
-    monitorHandle()
-    monitorHandle <<- NULL
+    # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured
+    # This will cause `onStop` to be called.
+    #   The `oldwd` will exist, but `monitorHandle` is not a function yet.
+    if (is.function(monitorHandle)) {
+      monitorHandle()
+      monitorHandle <<- NULL
+    }
   }
 
+  appObjOptions <- appObj()$options
+
   structure(
     list(
       # fallbackWWWDir is _not_ listed in staticPaths, because it needs to
@@ -371,33 +497,41 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
       serverFuncSource = dynServerFuncSource,
       onStart = onStart,
       onStop = onStop,
-      options = options
+      options = joinOptions(appObjOptions, options)
     ),
     class = "shiny.appobj"
   )
 }
 
 
-#' @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"))
@@ -406,35 +540,42 @@ 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
-#' @param ... Additional parameters to be passed to print.
+#' @rdname shiny.appobj
+#' @param ... Ignored.
 #' @export
 print.shiny.appobj <- function(x, ...) {
-  opts <- x$options %OR% list()
-  opts <- opts[names(opts) %in%
-      c("port", "launch.browser", "host", "quiet",
-        "display.mode", "test.mode")]
-
-  # 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)
+  runApp(x)
 }
 
-#' @rdname shinyApp
+# Joins two options objects (i.e. the `options` argument to shinyApp(),
+# shinyAppDir(), etc.). The values in `b` should take precedence over the values
+# in `a`. Given the current options available, it is safe to throw away any
+# values in `a` that are provided in `b`. But in the future, if new options are
+# introduced that need to be combined in some way instead of simply overwritten,
+# then this will be the place to do it. See the implementations of
+# print.shiny.appobj() and runApp() (for the latter, look specifically for
+# "findVal()") to determine the set of possible options.
+joinOptions <- function(a, b) {
+  stopifnot(is.null(a) || is.list(a))
+  stopifnot(is.null(b) || is.list(b))
+
+  mergeVectors(a, b)
+}
+
+#' @rdname shiny.appobj
 #' @method as.tags shiny.appobj
 #' @export
 as.tags.shiny.appobj <- function(x, ...) {
   # jcheng 06/06/2014: Unfortunate copy/paste between this function and
   # knit_print.shiny.appobj, but I am trying to make the most conservative
   # change possible due to upcoming release.
-  opts <- x$options %OR% list()
+  opts <- x$options %||% list()
   width <- if (is.null(opts$width)) "100%" else opts$width
   height <- if (is.null(opts$height)) "400" else opts$height
 
@@ -454,87 +595,3 @@ deferredIFrame <- function(path, width, height) {
     class = "shiny-frame shiny-frame-deferred"
   )
 }
-
-#' Knitr S3 methods
-#'
-#' These S3 methods are necessary to help Shiny applications and UI chunks embed
-#' themselves in knitr/rmarkdown documents.
-#'
-#' @name knitr_methods
-#' @param x Object to knit_print
-#' @param ... Additional knit_print arguments
-NULL
-
-# If there's an R Markdown runtime option set but it isn't set to Shiny, then
-# return a warning indicating the runtime is inappropriate for this object.
-# Returns NULL in all other cases.
-shiny_rmd_warning <- function() {
-  runtime <- knitr::opts_knit$get("rmarkdown.runtime")
-  if (!is.null(runtime) && runtime != "shiny")
-    # note that the RStudio IDE checks for this specific string to detect Shiny
-    # applications in static document
-    list(structure(
-      "Shiny application in a static R Markdown document",
-      class = "rmd_warning"))
-  else
-    NULL
-}
-
-#' @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
-  height <- if (is.null(opts$height)) "400" else opts$height
-
-  runtime <- knitr::opts_knit$get("rmarkdown.runtime")
-  if (!is.null(runtime) && runtime != "shiny") {
-    # If not rendering to a Shiny document, create a box exactly the same
-    # dimensions as the Shiny app would have had (so the document continues to
-    # flow as it would have with the app), and display a diagnostic message
-    width <- validateCssUnit(width)
-    height <- validateCssUnit(height)
-    output <- tags$div(
-      style=paste("width:", width, "; height:", height, "; text-align: center;",
-                  "box-sizing: border-box;", "-moz-box-sizing: border-box;",
-                  "-webkit-box-sizing: border-box;"),
-      class="muted well",
-      "Shiny applications not supported in static R Markdown documents")
-  }
-  else {
-    path <- addSubApp(x)
-    output <- deferredIFrame(path, width, height)
-  }
-
-  # If embedded Shiny apps ever have JS/CSS dependencies (like pym.js) we'll
-  # need to grab those and put them in meta, like in knit_print.shiny.tag. But
-  # for now it's not an issue, so just return the HTML and warning.
-
-  knitr::asis_output(htmlPreserve(format(output, indent=FALSE)),
-                     meta = shiny_rmd_warning(), cacheable = FALSE)
-}
-
-# Let us use a nicer syntax in knitr chunks than literally
-# 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))
-  attr(output, "knit_cacheable") <- FALSE
-  attr(output, "knit_meta") <- append(attr(output, "knit_meta"),
-                                      shiny_rmd_warning())
-  output
-}
-
-# Lets us drop reactive expressions directly into a knitr chunk and have the
-# value printed out! Nice for teaching if nothing else.
-#' @rdname knitr_methods
-#' @export
-knit_print.reactive <- function(x, ..., inline = FALSE) {
-  renderFunc <- if (inline) renderText else renderPrint
-  knitr::knit_print(renderFunc({
-    x()
-  }), inline = inline)
-}

R/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
@@ -24,7 +24,9 @@ withMathJax <- function(...) {
   )
 }
 
-renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
+renderPage <- function(ui, showcase=0, testMode=FALSE) {
+  lang <- getLang(ui)
+
   # 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")) {
@@ -38,32 +40,99 @@ renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
     # Put the body into the default template
     ui <- htmlTemplate(
       system.file("template", "default.html", package = "shiny"),
-      body = ui
+      lang = lang,
+      body = ui,
+      # this template is a complete HTML document
+      document_ = TRUE
     )
   }
 
-  shiny_deps <- list(
-    htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
-    htmlDependency("jquery", "1.12.4", c(href="shared"), script = "jquery.min.js"),
-    htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
-      script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
-      stylesheet = "shiny.css")
+  jquery <- function() {
+    version <- getOption("shiny.jquery.version", 3)
+    if (version == 3) {
+      return(htmlDependency(
+        "jquery", version_jquery,
+        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 <- c(
+    list(jquery()),
+    shinyDependencies()
   )
 
   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")
+      htmlDependency("shiny-testmode", shinyPackageVersion(),
+                     c(href="shared"), script = "shiny-testmode.js")
   }
 
   html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
-  writeUTF8(html, con = connection)
+  enc2utf8(paste(collapse = "\n", html))
+}
+
+shinyDependencies <- function() {
+  list(
+    bslib::bs_dependency_defer(shinyDependencyCSS),
+    htmlDependency(
+      name = "shiny-javascript",
+      version = shinyPackageVersion(),
+      src = c(href = "shared"),
+      script =
+        if (isTRUE(
+          get_devmode_option(
+            "shiny.minified",
+            TRUE
+          )
+        ))
+          "shiny.min.js"
+        else
+          "shiny.js"
+    )
+  )
+}
+
+shinyDependencyCSS <- function(theme) {
+  version <- shinyPackageVersion()
+
+  if (!is_bs_theme(theme)) {
+    return(htmlDependency(
+      name = "shiny-css",
+      version = version,
+      src = c(href = "shared"),
+      stylesheet = "shiny.min.css"
+    ))
+  }
+
+  scss_home <- system.file("www/shared/shiny_scss", package = "shiny")
+  scss_files <- file.path(scss_home, c("bootstrap.scss", "shiny.scss"))
+  scss_files <- lapply(scss_files, sass::sass_file)
+
+  bslib::bs_dependency(
+    input = scss_files,
+    theme = theme,
+    name = "shiny-sass",
+    version = version,
+    cache_key_extra = version
+  )
 }
 
 #' Create a Shiny UI handler
 #'
-#' Historically this function was used in ui.R files to register a user
+#' @description \lifecycle{superseded}
+#'
+#' @description Historically this function was used in ui.R files to register a user
 #' interface with Shiny. It is no longer required as of Shiny 0.10; simply
 #' ensure that the last expression to be returned from ui.R is a user interface.
 #' This function is kept for backwards compatibility with older applications. It
@@ -71,8 +140,20 @@ renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
 #'
 #' @param ui A user interace definition
 #' @return The user interface definition, without modifications or side effects.
+#' @keywords internal
 #' @export
 shinyUI <- function(ui) {
+  if (in_devmode()) {
+    shinyDeprecated(
+      "0.10.0", "shinyUI()",
+      details = paste0(
+        "When removing `shinyUI()`, ",
+        "ensure that the last expression returned from ui.R is a user interface ",
+        "normally supplied to `shinyUI(ui)`."
+      )
+    )
+  }
+
   .globals$ui <- list(ui)
   ui
 }
@@ -81,16 +162,18 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
 
   force(ui)
 
+  allowed_methods <- "GET"
+  if (is.function(ui)) {
+    allowed_methods <- attr(ui, "http_methods_supported", exact = TRUE) %||% allowed_methods
+  }
+
   function(req) {
-    if (!identical(req$REQUEST_METHOD, 'GET'))
+    if (!isTRUE(req$REQUEST_METHOD %in% allowed_methods))
       return(NULL)
 
     if (!isTRUE(grepl(uiPattern, req$PATH_INFO)))
       return(NULL)
 
-    textConn <- file(open = "w+")
-    on.exit(close(textConn))
-
     showcaseMode <- .globals$showcaseDefault
     if (.globals$showcaseOverride) {
       mode <- showcaseModeOfReq(req)
@@ -98,7 +181,7 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
         showcaseMode <- mode
     }
 
-    testMode <- .globals$testMode %OR% FALSE
+    testMode <- getShinyOption("testmode", default = FALSE)
 
     # Create a restore context using query string
     bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
@@ -130,8 +213,11 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
     if (is.null(uiValue))
       return(NULL)
 
-    renderPage(uiValue, textConn, showcaseMode, testMode)
-    html <- paste(readLines(textConn, encoding = 'UTF-8'), collapse='\n')
-    return(httpResponse(200, content=enc2utf8(html)))
+    if (inherits(uiValue, "httpResponse")) {
+      return(uiValue)
+    } else {
+      html <- renderPage(uiValue, showcaseMode, testMode)
+      return(httpResponse(200, content=html))
+    }
   }
 }

R/shinywrappers.R

@@ -1,34 +1,105 @@
-utils::globalVariables('func')
+utils::globalVariables('func', add = TRUE)
 
 #' Mark a function as a render function
 #'
-#' Should be called by implementers of \code{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
-#' output widgets out of just the render function.
+#' 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 output
+#' widgets out of just the render function.
 #'
 #' @param uiFunc A function that renders Shiny UI. Must take a single argument:
 #'   an output ID.
 #' @param renderFunc A function that is suitable for assigning to a Shiny output
 #'   slot.
-#' @param outputArgs A list of arguments to pass to the \code{uiFunc}. Render
-#'   functions should include \code{outputArgs = list()} in their own parameter
-#'   list, and pass through the value to \code{markRenderFunction}, to allow
-#'   app authors to customize outputs. (Currently, this is only supported for
-#'   dynamically generated UIs, such as those created by Shiny code snippets
-#'   embedded in R Markdown documents).
-#' @return The \code{renderFunc} function, with annotations.
+#' @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).
+#' @param cacheHint One of `"auto"`, `FALSE`, or some other information to
+#'   identify this instance for caching using [bindCache()]. If `"auto"`, it
+#'   will try to automatically infer caching information. If `FALSE`, do not
+#'   allow caching for the object. Some render functions (such as [renderPlot])
+#'   contain internal state that makes them unsuitable for caching.
+#' @param cacheWriteHook Used if the render function is passed to `bindCache()`.
+#'   This is an optional callback function to invoke before saving the value
+#'   from the render function to the cache. This function must accept one
+#'   argument, the value returned from `renderFunc`, and should return the value
+#'   to store in the cache.
+#' @param cacheReadHook Used if the render function is passed to `bindCache()`.
+#'   This is an optional callback function to invoke after reading a value from
+#'   the cache (if there is a cache hit). The function will be passed one
+#'   argument, the value retrieved from the cache. This can be useful when some
+#'   side effect needs to occur for a render function to behave correctly. For
+#'   example, some render functions call [createWebDependency()] so that Shiny
+#'   is able to serve JS and CSS resources.
+#' @return The `renderFunc` function, with annotations.
+#'
+#' @seealso [createRenderFunction()], [quoToFunction()]
 #' @export
-markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
+markRenderFunction <- function(
+  uiFunc,
+  renderFunc,
+  outputArgs = list(),
+  cacheHint = "auto",
+  cacheWriteHook = NULL,
+  cacheReadHook = NULL
+) {
+  force(renderFunc)
+
   # a mutable object that keeps track of whether `useRenderFunction` has been
   # executed (this usually only happens when rendering Shiny code snippets in
   # an interactive R Markdown document); its initial value is FALSE
   hasExecuted <- Mutable$new()
   hasExecuted$set(FALSE)
 
-  origRenderFunc <- renderFunc
-  renderFunc <- function(...) {
+  if (is.null(uiFunc)) {
+    uiFunc <- function(id) {
+      pre(
+        "No UI/output function provided for render function. ",
+        "Please see ?shiny::markRenderFunction and ?shiny::createRenderFunction."
+      )
+    }
+  }
+
+  if (identical(cacheHint, "auto")) {
+    origUserFunc <- attr(renderFunc, "wrappedFunc", exact = TRUE)
+    # The result could be NULL, but don't warn now because it'll only affect
+    # users if they try to use caching. We'll warn when someone calls
+    # bindCache() on this object.
+    if (is.null(origUserFunc)) {
+      cacheHint <- NULL
+    } else {
+      # Add in the wrapper render function and they output function, because
+      # they can be useful for distinguishing two renderX functions that receive
+      # the same user expression but do different things with them (like
+      # renderText and renderPrint).
+      cacheHint <- list(
+        origUserFunc = origUserFunc,
+        renderFunc   = renderFunc,
+        outputFunc   = uiFunc
+      )
+    }
+  }
+
+  if (!is.null(cacheHint) && !is_false(cacheHint)) {
+    if (!is.list(cacheHint)) {
+      cacheHint <- list(cacheHint)
+    }
+    # For functions, remove the env and source refs because they can cause
+    #   spurious differences.
+    # For expressions, remove source refs.
+    # For everything else, do nothing.
+    cacheHint <- lapply(cacheHint, function(x) {
+      if      (is.function(x)) formalsAndBody(x)
+      else if (is.language(x)) zap_srcref(x)
+      else                     x
+    })
+  }
+
+  wrappedRenderFunc <- function(...) {
     # if the user provided something through `outputArgs` BUT the
     # `useRenderFunction` was not executed, then outputArgs will be ignored,
     # so throw a warning to let user know the correct usage
@@ -41,58 +112,100 @@ markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
       # stop warning from happening again for the same object
       hasExecuted$set(TRUE)
     }
-    if (is.null(formals(origRenderFunc))) origRenderFunc()
-    else origRenderFunc(...)
+    if (is.null(formals(renderFunc))) renderFunc()
+    else renderFunc(...)
   }
 
-  structure(renderFunc,
-            class       = c("shiny.render.function", "function"),
-            outputFunc  = uiFunc,
-            outputArgs  = outputArgs,
-            hasExecuted = hasExecuted)
+  structure(
+    wrappedRenderFunc,
+    class          = c("shiny.render.function", "function"),
+    outputFunc     = uiFunc,
+    outputArgs     = outputArgs,
+    hasExecuted    = hasExecuted,
+    cacheHint      = cacheHint,
+    cacheWriteHook = cacheWriteHook,
+    cacheReadHook  = cacheReadHook
+  )
+}
+
+#' @export
+print.shiny.render.function <- function(x, ...) {
+  cat_line("<shiny.render.function>")
 }
 
 #' Implement render functions
 #'
+#' This function is a wrapper for [markRenderFunction()] which provides support
+#' for async computation via promises.
+#'
 #' @param func A function without parameters, that returns user data. If the
 #'   returned value is a promise, then the render function will proceed in async
 #'   mode.
-#' @param transform A function that takes four arguments: \code{value},
-#'   \code{session}, \code{name}, and \code{...} (for future-proofing). This
-#'   function will be invoked each time a value is returned from \code{func},
+#' @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 \code{outputFunc}.
-#'   Render functions should include \code{outputArgs = list()} in their own
-#'   parameter list, and pass through the value as this argument, to allow app
-#'   authors to customize outputs. (Currently, this is only supported for
-#'   dynamically generated UIs, such as those created by Shiny code snippets
-#'   embedded in R Markdown documents).
+#' @inheritParams markRenderFunction
 #' @return An annotated render function, ready to be assigned to an
-#'   \code{output} slot.
+#'   `output` slot.
 #'
+#' @seealso [quoToFunction()], [markRenderFunction()].
+#'
+#' @examples
+#' # A very simple render function
+#' renderTriple <- function(x) {
+#'   x <- substitute(x)
+#'   if (!rlang::is_quosure(x)) {
+#'     x <- rlang::new_quosure(x, env = parent.frame())
+#'   }
+#'   func <- quoToFunction(x, "renderTriple")
+#'
+#'   createRenderFunction(
+#'     func,
+#'     transform = function(value, session, name, ...) {
+#'       paste(rep(value, 3), collapse=", ")
+#'     },
+#'     outputFunc = textOutput
+#'   )
+#' }
+#'
+#' # Test render function from the console
+#' a <- 1
+#' r <- renderTriple({ a + 1 })
+#' a <- 2
+#' r()
 #' @export
 createRenderFunction <- function(
-  func, transform = function(value, session, name, ...) value,
-  outputFunc = NULL, outputArgs = NULL
+  func,
+  transform = function(value, session, name, ...) value,
+  outputFunc = NULL,
+  outputArgs = NULL,
+  cacheHint = "auto",
+  cacheWriteHook = NULL,
+  cacheReadHook = NULL
 ) {
-
   renderFunc <- function(shinysession, name, ...) {
     hybrid_chain(
       func(),
-      function(value, .visible) {
-        transform(setVisible(value, .visible), shinysession, name, ...)
+      function(value) {
+        transform(value, shinysession, name, ...)
       }
     )
   }
 
-  if (!is.null(outputFunc))
-    markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
-  else
-    renderFunc
+  # Hoist func's wrappedFunc attribute into renderFunc, so that when we pass
+  # renderFunc on to markRenderFunction, it is able to find the original user
+  # function.
+  if (identical(cacheHint, "auto")) {
+    attr(renderFunc, "wrappedFunc") <- attr(func, "wrappedFunc", exact = TRUE)
+  }
+
+  markRenderFunction(outputFunc, renderFunc, outputArgs, cacheHint,
+                     cacheWriteHook, cacheReadHook)
 }
 
 useRenderFunction <- function(renderFunc, inline = FALSE) {
@@ -135,6 +248,22 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
   useRenderFunction(x, inline = inline)
 }
 
+# Get relevant attributes from a render function object.
+renderFunctionAttributes <- function(x) {
+  attrs <- c("outputFunc", "outputArgs", "hasExecuted", "cacheHint")
+  names(attrs) <- attrs
+  lapply(attrs, function(name) attr(x, name, exact = TRUE))
+}
+
+# Add a named list of attributes to an object
+addAttributes <- function(x, attrs) {
+  nms <- names(attrs)
+  for (i in seq_along(attrs)) {
+    attr(x, nms[i]) <- attrs[[i]]
+  }
+  x
+}
+
 
 #' Mark a render function with attributes that will be used by the output
 #'
@@ -165,37 +294,40 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 
 #' 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`. (For backward
+#'   compatibility reasons, if this argument is missing, a warning will be
+#'   emitted, and if the file is in the temp directory it will be deleted. In
+#'   the future, this warning will become an error.)
 #' @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
 #'
@@ -266,19 +398,59 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #' shinyApp(ui, server)
 #' }
 renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
-                        deleteFile=TRUE, outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+                        deleteFile, outputArgs=list())
+{
+  expr <- get_quosure(expr, env, quoted)
+  func <- quoToFunction(expr, "renderImage")
+
+  # missing() must be used directly within the function with the given arg
+  if (missing(deleteFile)) {
+    deleteFile <- NULL
+  }
+
+  # Tracks whether we've reported the `deleteFile` warning yet; we don't want to
+  # do it on every invalidation (though we will end up doing it at least once
+  # per output per session).
+  warned <- FALSE
 
   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))
+      shouldDelete <- deleteFile
+
+      # jcheng 2020-05-08
+      #
+      # Until Shiny 1.5.0, the default for deleteFile was, incredibly, TRUE.
+      # Changing it to default to FALSE might cause existing Shiny apps to pile
+      # up images in their temp directory (for long lived R processes). Not
+      # having a default (requiring explicit value) is the right long-term move,
+      # but would break today's apps.
+      #
+      # Compromise we decided on was to eventually require TRUE/FALSE, but for
+      # now, change the default behavior to only delete temp files; and emit a
+      # warning encouraging people to not rely on the default.
+      if (is.null(shouldDelete)) {
+        shouldDelete <- isTRUE(try(silent = TRUE,
+          file.exists(imageinfo$src) && isTemp(imageinfo$src, mustExist = TRUE)
+        ))
+
+        if (!warned) {
+          warned <<- TRUE
+          warning("The renderImage output named '",
+            getCurrentOutputInfo()$name,
+            "' is missing the deleteFile argument; as of Shiny 1.5.0, you must ",
+            "use deleteFile=TRUE or deleteFile=FALSE. (This warning will ",
+            "become an error in a future version of Shiny.)",
+            call. = FALSE
+          )
+        }
+      }
+
+      if (shouldDelete) {
+        on.exit(unlink(imageinfo$src), add = TRUE)
       }
 
       # If contentType not specified, autodetect based on extension
-      contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
+      contentType <- imageinfo$contentType %||% getContentType(imageinfo$src)
 
       # Extra values are everything in imageinfo except 'src' and 'contentType'
       extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
@@ -287,45 +459,85 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
       c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
         extra_attr)
     },
-    imageOutput, outputArgs)
+    imageOutput,
+    outputArgs,
+    cacheHint = FALSE
+  )
 }
 
+# TODO: If we ever take a dependency on fs, it'd be great to replace this with
+# fs::path_has_parent().
+isTemp <- function(path, tempDir = tempdir(), mustExist) {
+  if (!isTRUE(mustExist)) {
+    # jcheng 2020-05-11: I added mustExist just to make it totally obvious that
+    # the path must exist. We don't support the case where the file doesn't
+    # exist because it makes normalizePath unusable, and it's a bit scary
+    # security-wise to compare paths without normalization. Using fs would fix
+    # this as it knows how to normalize paths that don't exist.
+    stop("isTemp(mustExist=FALSE) is not implemented")
+  }
 
-#' Printable Output
+  if (mustExist && !file.exists(path)) {
+    stop("path does not exist")
+  }
+
+  if (nchar(tempDir) == 0 || !dir.exists(tempDir)) {
+    # This should never happen, but just to be super paranoid...
+    stop("invalid temp dir")
+  }
+
+  path <- normalizePath(path, winslash = "/", mustWork = mustExist)
+
+  tempDir <- normalizePath(tempDir, winslash = "/", mustWork = TRUE)
+  if (path == tempDir) {
+    return(FALSE)
+  }
+
+  tempDir <- ensure_trailing_slash(tempDir)
+  if (path == tempDir) {
+    return(FALSE)
+  }
+
+  return(substr(path, 1, nchar(tempDir)) == tempDir)
+}
+
+#' Text Output
 #'
-#' Makes a reactive version of the given function that captures any printed
-#' output, and also captures its printable result (unless
-#' \code{\link[base]{invisible}}), into a string. The resulting function is suitable
-#' for assigning to an  \code{output} slot.
+#' @description
+#' `renderPrint()` prints the result of `expr`, while `renderText()` pastes it
+#' together into a single string. `renderPrint()` is equivalent to [print()];
+#' `renderText()` is equivalent to [cat()]. Both functions capture all other
+#' printed output generated while evaluating `expr`.
 #'
-#' The corresponding HTML output tag can be anything (though \code{pre} is
+#' `renderPrint()` is usually paired with [verbatimTextOutput()];
+#' `renderText()` is usually paired with [textOutput()].
+#'
+#' @details
+#' 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.
+#' @return
+#' For `renderPrint()`, note the given expression returns `NULL` then `NULL`
+#' will actually be visible in the output. To display nothing, make your
+#' function return [invisible()].
 #'
-#' Note that unlike most other Shiny output functions, if the given function
-#' returns \code{NULL} then \code{NULL} will actually be visible in the output.
-#' To display nothing, make your function return \code{\link[base]{invisible}()}.
-#'
-#' @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 expr An expression to evaluate.
+#' @param env The environment in which to evaluate `expr`. For expert use only.
+#' @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[base]{options}('width')}.
+#' @param width Width of printed output.
 #' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to \code{\link{verbatimTextOutput}} when \code{renderPrint} is used
-#'   in an interactive R Markdown document.
-#' @seealso \code{\link{renderText}} for displaying the value returned from a
-#'   function, instead of the printed output.
+#'   call to [verbatimTextOutput()] or [textOutput()] when the functions are
+#'   used in an interactive RMarkdown document.
 #'
 #' @example res/text-example.R
 #' @export
 renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
-                        width = getOption('width'), outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+                        width = getOption('width'), outputArgs=list())
+{
+  expr <- get_quosure(expr, env, quoted)
+  func <- quoToFunction(expr, "renderPrint")
 
   # Set a promise domain that sets the console width
   #   and captures output
@@ -338,12 +550,12 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
       {
         promises::with_promise_domain(domain, func())
       },
-      function(value, .visible) {
-        if (.visible) {
-          cat(file = domain$conn, paste(utils::capture.output(value, append = TRUE), collapse = "\n"))
+      function(value) {
+        res <- withVisible(value)
+        if (res$visible) {
+          cat(file = domain$conn, paste(utils::capture.output(res$value, append = TRUE), collapse = "\n"))
         }
-        res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
-        res
+        paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
       },
       finally = function() {
         close(domain$conn)
@@ -351,7 +563,15 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     )
   }
 
-  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
+  markRenderFunction(
+    verbatimTextOutput,
+    renderFunc,
+    outputArgs,
+    cacheHint = list(
+      label = "renderPrint",
+      origUserExpr = get_expr(expr)
+    )
+  )
 }
 
 createRenderPrintPromiseDomain <- function(width) {
@@ -395,43 +615,23 @@ createRenderPrintPromiseDomain <- function(width) {
   )
 }
 
-#' 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
-#' vector.
-#'
-#' The corresponding HTML output tag can be anything (though \code{pre} is
-#' recommended if you need a monospace font and whitespace preserved) and should
-#' have the CSS class name \code{shiny-text-output}.
-#'
-#' The result of executing \code{func} will passed to \code{cat}, inside a
-#' \code{\link[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
-#'   is useful if you want to save an expression in a variable.
-#' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to \code{\link{textOutput}} when \code{renderText} is used in an
-#'   interactive R Markdown document.
-#'
-#' @seealso \code{\link{renderPrint}} for capturing the print output of a
-#'   function, rather than the returned text value.
-#'
-#' @example res/text-example.R
+#' @param sep A separator passed to `cat` to be appended after each
+#'   element.
 #' @export
+#' @rdname renderPrint
 renderText <- function(expr, env=parent.frame(), quoted=FALSE,
-                       outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+                       outputArgs=list(), sep=" ") {
+
+  expr <- get_quosure(expr, env, quoted)
+  func <- quoToFunction(expr, "renderText")
 
   createRenderFunction(
     func,
     function(value, session, name, ...) {
-      paste(utils::capture.output(cat(value)), collapse="\n")
+      paste(utils::capture.output(cat(value, sep=sep)), collapse="\n")
     },
-    textOutput, outputArgs
+    textOutput,
+    outputArgs
   )
 }
 
@@ -439,19 +639,19 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' 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 \code{\link{uiOutput}}
+#' @seealso [uiOutput()]
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -472,9 +672,11 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #' shinyApp(ui, server)
 #' }
 #'
-renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
-                     outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
+                     outputArgs = list())
+{
+  expr <- get_quosure(expr, env, quoted)
+  func <- quoToFunction(expr, "renderUI")
 
   createRenderFunction(
     func,
@@ -484,7 +686,8 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
 
       processDeps(result, shinysession)
     },
-    uiOutput, outputArgs
+    uiOutput,
+    outputArgs
   )
 }
 
@@ -494,25 +697,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](https://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
@@ -520,7 +723,7 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
 #' if (interactive()) {
 #'
 #' ui <- fluidPage(
-#'   downloadLink("downloadData", "Download")
+#'   downloadButton("downloadData", "Download")
 #' )
 #'
 #' server <- function(input, output) {
@@ -545,50 +748,50 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
     shinysession$registerDownload(name, filename, contentType, content)
   }
   snapshotExclude(
-    markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+    markRenderFunction(downloadButton, renderFunc, outputArgs, cacheHint = FALSE)
   )
 }
 
-#' Table output with the JavaScript library DataTables
+#' Table output with the JavaScript DataTables library
 #'
+#' @description
 #' Makes a reactive version of the given function that returns a data frame (or
-#' matrix), which will be rendered with the DataTables library. Paging,
-#' searching, filtering, and sorting can be done on the R side using Shiny as
-#' the server infrastructure.
+#' matrix), which will be rendered with the [DataTables](https://datatables.net)
+#' library. Paging, searching, filtering, and sorting can be done on the R side
+#' using Shiny as the server infrastructure.
+#'
+#' 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
+#' [DT](https://github.com/rstudio/DT) that allows you to create both
+#' server-side and client-side DataTables, and supports additional features.
+#' Learn more at <https://rstudio.github.io/DT/shiny.html>.
 #'
-#' For the \code{options} argument, the character elements that have the class
-#' \code{"AsIs"} (usually returned from \code{\link[base]{I}()}) will be evaluated in
-#' 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
-#' elements in the list.
 #' @param expr An expression that returns a data frame or a matrix.
+#' @inheritParams renderTable
 #' @param options A list of initialization options to be passed to DataTables,
-#'   or a function to return such a list.
+#'   or a function to return such a list.  You can find a complete list of
+#'   options at <https://datatables.net/reference/option/>.
+#'
+#'   Any top-level strings with class `"AsIs"` (as created by [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. This only applies to the
+#'   root-level elements of options list, and does not worked for lower-level
+#'   elements in the list.
 #' @param searchDelay The delay for searching, in milliseconds (to avoid too
 #'   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.
+#' @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}
-#' @note This function only provides the server-side version of DataTables
-#'   (using R to process the data object on the server side). There is a
-#'   separate package \pkg{DT} (\url{https://github.com/rstudio/DT}) that allows
-#'   you to create both server-side and client-side DataTables, and supports
-#'   additional DataTables features. Consider using \code{DT::renderDataTable()}
-#'   and \code{DT::dataTableOutput()} (see
-#'   \url{http://rstudio.github.io/DT/shiny.html} for more information).
 #' @export
 #' @inheritParams renderPlot
 #' @examples
@@ -616,8 +819,18 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             callback = 'function(oTable) {}', escape = TRUE,
                             env = parent.frame(), quoted = FALSE,
-                            outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+                            outputArgs=list())
+{
+
+  if (in_devmode()) {
+    shinyDeprecated(
+      "0.11.1", "shiny::renderDataTable()", "DT::renderDataTable()",
+      details = "See <https://rstudio.github.io/DT/shiny.html> for more information"
+    )
+  }
+
+  expr <- get_quosure(expr, env, quoted)
+  func <- quoToFunction(expr, "renderDataTable")
 
   renderFunc <- function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
@@ -651,7 +864,8 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     )
   }
 
-  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs,
+    cacheHint = FALSE)
 
   renderFunc <- snapshotPreprocessOutput(renderFunc, function(value) {
     # Remove the action field so that it's not saved in test snapshots. It
@@ -707,56 +921,64 @@ checkDT9 <- function(options) {
 
 # Deprecated functions ------------------------------------------------------
 
+#' Deprecated reactive functions
+#'
+#' @description \lifecycle{superseded}
+#'
+#' @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")
+  shinyDeprecated("0.4.0", "reactivePlot()", "renderPlot()")
   renderPlot({ func() }, width=width, height=height, ...)
 }
 
 #' 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")
+  shinyDeprecated("0.4.0", "reactiveTable()", "renderTable()")
   renderTable({ 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")
+  shinyDeprecated("0.4.0", "reactivePrint()", "renderPrint()")
   renderPrint({ 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")
+  shinyDeprecated("0.4.0", "reactiveUI()", "renderUI()")
   renderUI({ 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")
+  shinyDeprecated("0.4.0", "reactiveText()", "renderText()")
   renderText({ func() })
 }

R/showcase.R

@@ -104,20 +104,18 @@ navTabsDropdown <- function(files) {
 
 tabContentHelper <- function(files, path, language) {
   lapply(files, function(file) {
-    with(tags,
-      div(class=paste("tab-pane",
+      tags$div(class=paste("tab-pane",
                       if (tolower(file) %in% c("app.r", "server.r")) " active"
                       else "",
                       sep=""),
           id=paste(gsub(".", "_", file, fixed=TRUE),
                    "_code", sep=""),
-          pre(class="shiny-code",
+          tags$pre(class="shiny-code",
               # we need to prevent the indentation of <code> ... </code>
               HTML(format(tags$code(
                 class=paste0("language-", language),
                 paste(readUTF8(file.path.ci(path, file)), collapse="\n")
               ), indent = FALSE))))
-    )
   })
 }
 
@@ -222,4 +220,3 @@ showcaseUI <- function(ui) {
     showcaseBody(ui)
   )
 }
-

R/stack.R

@@ -1,70 +0,0 @@
-# A Stack object backed by a list. The backing list will grow or shrink as
-# the stack changes in size.
-Stack <- R6Class(
-  'Stack',
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-
-    initialize = function(init = 20L) {
-      # init is the initial size of the list. It is also used as the minimum
-      # size of the list as it shrinks.
-      private$stack <- vector("list", init)
-      private$init <- init
-    },
-
-    push = function(..., .list = NULL) {
-      args <- c(list(...), .list)
-      new_size <- count + length(args)
-
-      # Grow if needed; double in size
-      while (new_size > length(stack)) {
-        stack[length(stack) * 2] <<- list(NULL)
-      }
-      stack[count + seq_along(args)] <<- args
-      count <<- new_size
-
-      invisible(self)
-    },
-
-    pop = function() {
-      if (count == 0L)
-        return(NULL)
-
-      value <- stack[[count]]
-      stack[count] <<- list(NULL)
-      count <<- count - 1L
-
-      # Shrink list if < 1/4 of the list is used, down to a minimum size of `init`
-      len <- length(stack)
-      if (len > init && count < len/4) {
-        new_len <- max(init, ceiling(len/2))
-        stack <<- stack[seq_len(new_len)]
-      }
-
-      value
-    },
-
-    peek = function() {
-      if (count == 0L)
-        return(NULL)
-      stack[[count]]
-    },
-
-    size = function() {
-      count
-    },
-
-    # Return the entire stack as a list, where the first item in the list is the
-    # oldest item in the stack, and the last item is the most recently added.
-    as_list = function() {
-      stack[seq_len(count)]
-    }
-  ),
-
-  private = list(
-    stack = NULL,   # A list that holds the items
-    count = 0L,     # Current number of items in the stack
-    init = 20L      # Initial and minimum size of the stack
-  )
-)

R/test-export.R

@@ -4,10 +4,10 @@
 #' event occurs. These events are triggered by accessing a snapshot URL.
 #'
 #' This function only has an effect if the app is launched in test mode. This is
-#' done by calling \code{runApp()} with \code{test.mode=TRUE}, or by setting the
-#' global option \code{shiny.testmode} to \code{TRUE}.
+#' 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 \code{FALSE}.
+#' @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

R/test-server.R

@@ -0,0 +1,156 @@
+#' 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 A server function (i.e. a function with `input`, `output`,
+#'   and `session`), or a module function (i.e. a function with first
+#'   argument `id` that calls [moduleServer()].
+#'
+#'   You can also provide an app, a path an app, or anything that
+#'   [`as.shiny.appobj()`] can handle.
+#' @param expr Test code containing expectations. The objects from inside the
+#'   server function environment will be made available in the environment of
+#'   the test expression (this is done using a data mask with
+#'   [rlang::eval_tidy()]). This includes the parameters of the server function
+#'   (e.g. `input`, `output`, and `session`), along with any other values
+#'   created inside of the server function.
+#' @param args Additional arguments to pass to the module function. If `app` is
+#'   a module, and no `id` argument is provided, one will be generated and
+#'   supplied automatically.
+#' @param session The [`MockShinySession`] object to use as the [reactive
+#'   domain][shiny::domains]. The same session object is used as the domain both
+#'   during invocation of the server or module under test and during evaluation
+#'   of `expr`.
+#' @include mock-session.R
+#' @rdname testServer
+#' @examples
+#' # Testing a server function  ----------------------------------------------
+#' server <- function(input, output, session) {
+#'   x <- reactive(input$a * input$b)
+#' }
+#'
+#' testServer(server, {
+#'   session$setInputs(a = 2, b = 3)
+#'   stopifnot(x() == 6)
+#' })
+#'
+#'
+#' # Testing a module --------------------------------------------------------
+#' myModuleServer <- 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(myModuleServer, args = list(multiplier = 2), {
+#'   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.
+#' })
+#' @export
+testServer <- function(app = NULL, expr, args = list(), session = MockShinySession$new()) {
+  require(shiny)
+
+  if (!is.null(getDefaultReactiveDomain()))
+    stop("testServer() is for use only within tests and may not indirectly call itself.")
+
+  on.exit(if (!session$isClosed()) session$close(), add = TRUE)
+  quosure <- rlang::enquo(expr)
+
+  if (isModuleServer(app)) {
+    if (!("id" %in% names(args)))
+      args[["id"]] <- session$genId()
+    # app is presumed to be a module, and modules may take additional arguments,
+    # so splice in any args.
+    withMockContext(session, rlang::exec(app, !!!args))
+
+    # If app is a module, then we must use both the module function's immediate
+    # environment and also its enclosing environment to construct the mask.
+    parent_clone <- rlang::env_clone(parent.env(session$env))
+    clone <- rlang::env_clone(session$env, parent_clone)
+    mask <- rlang::new_data_mask(clone, parent_clone)
+    withMockContext(session, rlang::eval_tidy(quosure, mask, rlang::caller_env()))
+    return(invisible())
+  }
+
+  if (is.null(app)) {
+    path <- findEnclosingApp(".")
+    app <- shinyAppDir(path)
+  } else if (isServer(app)) {
+    app <- shinyApp(fluidPage(), app)
+  } else {
+    app <- as.shiny.appobj(app)
+  }
+
+  if (!is.null(app$onStart))
+    app$onStart()
+  if (!is.null(app$onStop))
+    on.exit(app$onStop(), add = TRUE)
+
+  server <- app$serverFuncSource()
+  if (!"session" %in% names(formals(server)))
+    stop("Tested application server functions must declare input, output, and session arguments.")
+  if (length(args))
+    stop("Arguments were provided to a server function.")
+
+  body(server) <- rlang::expr({
+    session$setEnv(base::environment())
+    !!body(server)
+  })
+  withMockContext(session,
+    server(input = session$input, output = session$output, session = session)
+  )
+
+  # # If app is a server, we use only the server function's immediate
+  # # environment to construct the mask.
+  mask <- rlang::new_data_mask(rlang::env_clone(session$env))
+  withMockContext(session, {
+    rlang::eval_tidy(quosure, mask, rlang::caller_env())
+  })
+  invisible()
+}
+
+withMockContext <- function(session, expr) {
+  isolate(
+    withReactiveDomain(session, {
+      withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
+        # Sets a cache for renderCachedPlot() with cache = "app" to use.
+        shinyOptions("cache" = session$appcache)
+        expr
+      })
+    })
+  )
+}
+
+
+# Helpers -----------------------------------------------------------------
+
+isModuleServer <- function(x) {
+  is.function(x) && names(formals(x))[[1]] == "id"
+}
+
+isServer <- function(x) {
+  if (!is.function(x)) {
+    return(FALSE)
+  }
+
+  if (length(formals(x)) < 3) {
+    return(FALSE)
+  }
+
+  identical(names(formals(x))[1:3], c("input", "output", "session"))
+}

R/test.R

@@ -0,0 +1,189 @@
+#' 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`.
+#'   This can also by any errors signaled when evaluating the `file`.
+#'
+#' @return A 1-row data frame representing a single test run. `result` and
+#'   is a "list column", or a column that contains list elements.
+#' @noRd
+result_row <- function(file, pass, result) {
+  stopifnot(is.list(result))
+  df <- data.frame(
+    file = file,
+    pass = pass,
+    result = I(result),
+    stringsAsFactors = FALSE
+  )
+  class(df) <- c("shiny_runtests", class(df))
+  df
+}
+
+#' Check to see if the given directory contains at least one script, and that
+#' all scripts in the directory are shinytest scripts.
+#' Scans for the magic string of `app <- ShinyDriver$new(` as an indicator that
+#' this is a shinytest.
+#' @noRd
+is_legacy_shinytest_dir <- function(path){
+  is_shinytest_script <- function(file) {
+    if (!file.exists(file)) {
+      return(FALSE)
+    }
+
+    text <- readLines(file, warn = FALSE)
+    any(
+      grepl("app\\s*<-\\s*ShinyDriver\\$new\\(", text, perl=TRUE)
+    )
+  }
+
+  files <- dir(path, full.names = TRUE)
+  files <- files[!file.info(files)$isdir]
+  if (length(files) == 0) {
+    return(FALSE)
+  }
+  all(vapply(files, is_shinytest_script, logical(1)))
+}
+
+#' 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.
+#' @param assert Logical value which determines if an error should be thrown if any error is captured.
+#' @param envir Parent testing environment in which to base the individual testing environments.
+#'
+#' @return A data frame classed with the supplemental class `"shiny_runtests"`.
+#'   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 |
+#'
+#' @details Historically, [shinytest](https://rstudio.github.io/shinytest/)
+#'   recommended placing tests at the top-level of the `tests/` directory.
+#'   This older folder structure is not supported by runTests.
+#'   Please see [shinyAppTemplate()] for more details.
+#' @export
+runTests <- function(
+  appDir = ".",
+  filter = NULL,
+  assert = TRUE,
+  envir = globalenv()
+) {
+  # similar to runApp()
+  # Allows shiny's functions to be available in the UI, server, and test code
+  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()))
+  }
+
+  if (!is.null(filter)) {
+    runners <- runners[grepl(filter, runners)]
+  }
+  if (length(runners) == 0) {
+    stop("No test runners matched the given filter: '", filter, "'")
+  }
+
+  # See the @details section of the runTests() docs above for why this branch exists.
+  if (is_legacy_shinytest_dir(testsDir)) {
+    stop(
+      "It appears that the .R files in ", testsDir, " are all shinytests.",
+      " This is not supported by `shiny::runTests()`.",
+      "\nPlease see `?shinytest::migrateShinytestDir` to migrate your shinytest file structure to the new format (requires shinytest 1.4.0 or above).",
+      "\nSee `?shiny::shinyAppTemplate` for an example of the new testing file structure."
+    )
+  }
+
+  renv <- new.env(parent = envir)
+
+  # Otherwise source all the runners -- each in their own environment.
+  ret <- do.call(rbind, lapply(runners, function(r) {
+    pass <- FALSE
+    result <-
+      tryCatch({
+        env <- new.env(parent = renv)
+        withr::with_dir(testsDir, {
+          ret <- sourceUTF8(r, envir = env)
+        })
+        pass <- TRUE
+        ret
+      }, error = function(err) {
+        message("Error in ", r, "\n", err)
+        err
+      })
+    result_row(file.path(testsDir, r), pass, list(result))
+  }))
+
+  if (isTRUE(assert)) {
+    if (!all(ret$pass)) {
+      stop("Shiny App Test Failures detected in\n", paste0("* ", runtest_pretty_file(ret$file[!ret$pass]), collapse = "\n"), call. = FALSE)
+    }
+  }
+
+  ret
+}
+
+
+runtest_pretty_file <- function(f) {
+  test_folder <- dirname(f)
+  app_folder <- dirname(test_folder)
+  file.path(
+    basename(app_folder),
+    basename(test_folder),
+    basename(f)
+  )
+}
+
+
+#' @export
+print.shiny_runtests <- function(x, ..., reporter = "summary") {
+
+  cat("Shiny App Test Results\n")
+
+
+  if (any(x$pass)) {
+    # TODO in future... use clisymbols::symbol$tick and crayon green
+    cat("* Success\n")
+    mapply(
+      x$file,
+      x$pass,
+      x$result,
+      FUN = function(file, pass, result) {
+        if (!pass) return()
+        # print(result)
+        cat("  - ", runtest_pretty_file(file), "\n", sep = "")
+      }
+    )
+  }
+  if (any(!x$pass)) {
+    # TODO in future... use clisymbols::symbol$cross and crayon red
+    cat("* Failure\n")
+    mapply(
+      x$file,
+      x$pass,
+      x$result,
+      FUN = function(file, pass, result) {
+        if (pass) return()
+        cat("  - ", runtest_pretty_file(file), "\n", sep = "")
+      }
+    )
+  }
+
+  invisible(x)
+}

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,
@@ -56,17 +57,17 @@ TimerCallbacks <- R6Class(
     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)
     },
@@ -86,6 +87,30 @@ 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) {
@@ -96,3 +121,27 @@ scheduleTask <- function(millis, callback) {
     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

@@ -1,10 +1,9 @@
 #' Change the value of a text input on the client
 #'
 #' @template update-input
-#' @param value The value to set for the input object.
-#' @param placeholder The placeholder to set for the input object.
+#' @inheritParams textInput
 #'
-#' @seealso \code{\link{textInput}}
+#' @seealso [textInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -35,7 +34,9 @@
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeholder = NULL) {
+updateTextInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL, placeholder = NULL) {
+  validate_session_object(session)
+
   message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
   session$sendInputMessage(inputId, message)
 }
@@ -45,7 +46,7 @@ updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeh
 #' @template update-input
 #' @inheritParams updateTextInput
 #'
-#' @seealso \code{\link{textAreaInput}}
+#' @seealso [textAreaInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -82,9 +83,9 @@ updateTextAreaInput <- updateTextInput
 #' Change the value of a checkbox input on the client
 #'
 #' @template update-input
-#' @param value The value to set for the input object.
+#' @inheritParams checkboxInput
 #'
-#' @seealso \code{\link{checkboxInput}}
+#' @seealso [checkboxInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -107,7 +108,9 @@ updateTextAreaInput <- updateTextInput
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
+updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL) {
+  validate_session_object(session)
+
   message <- dropNulls(list(label=label, value=value))
   session$sendInputMessage(inputId, message)
 }
@@ -116,23 +119,24 @@ updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
 #' 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)}.
+#' @inheritParams actionButton
 #'
-#' @seealso \code{\link{actionButton}}
+#' @seealso [actionButton()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
 #'
 #' ui <- fluidPage(
-#'   actionButton("update", "Update other buttons"),
+#'   actionButton("update", "Update other buttons and link"),
 #'   br(),
 #'   actionButton("goButton", "Go"),
 #'   br(),
 #'   actionButton("goButton2", "Go 2", icon = icon("area-chart")),
 #'   br(),
-#'   actionButton("goButton3", "Go 3")
+#'   actionButton("goButton3", "Go 3"),
+#'   br(),
+#'   actionLink("goLink", "Go Link")
 #' )
 #'
 #' server <- function(input, output, session) {
@@ -153,30 +157,36 @@ updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
 #'     # unchaged and changes its label
 #'     updateActionButton(session, "goButton3",
 #'       label = "New label 3")
+#'
+#'     # Updates goLink's label and icon
+#'     updateActionButton(session, "goLink",
+#'       label = "New link label",
+#'       icon = icon("link"))
 #'   })
 #' }
 #'
 #' shinyApp(ui, server)
 #' }
+#' @rdname updateActionButton
 #' @export
-updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
+updateActionButton <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL) {
+  validate_session_object(session)
+
   if (!is.null(icon)) icon <- as.character(validateIcon(icon))
   message <- dropNulls(list(label=label, icon=icon))
   session$sendInputMessage(inputId, message)
 }
+#' @rdname updateActionButton
+#' @export
+updateActionLink <- updateActionButton
 
 
 #' Change the value of a date input on the client
 #'
 #' @template update-input
-#' @param value The desired date value. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format. Supply \code{NA} to clear the date.
-#' @param min The minimum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
-#' @param max The maximum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#' @inheritParams dateInput
 #'
-#' @seealso \code{\link{dateInput}}
+#' @seealso [dateInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -202,21 +212,14 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateDateInput <- function(session, inputId, label = NULL, value = NULL,
-                            min = NULL, max = NULL) {
+updateDateInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL,
+                            min = NULL, max = NULL)
+{
+  validate_session_object(session)
 
-  # 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,16 +229,9 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #' Change the start and end values of a date range input on the client
 #'
 #' @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.
-#' @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.
-#' @param min The minimum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
-#' @param max The maximum allowed date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#' @inheritParams dateRangeInput
 #'
-#' @seealso \code{\link{dateRangeInput}}
+#' @seealso [dateRangeInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -263,15 +259,16 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateDateRangeInput <- function(session, inputId, label = NULL,
+updateDateRangeInput <- function(session = getDefaultReactiveDomain(), 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')
+                                 max = NULL)
+{
+  validate_session_object(session)
+
+  start <- dateYMD(start, "start")
+  end <- dateYMD(end, "end")
+  min <- dateYMD(min, "min")
+  max <- dateYMD(max, "max")
 
   message <- dropNulls(list(
     label = label,
@@ -285,14 +282,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 selected The name of the tab to make active.
+#' @param session The `session` object passed to function given to
+#'   `shinyServer`. Default is `getDefaultReactiveDomain()`.
+#' @param inputId The id of the `tabsetPanel`, `navlistPanel`,
+#' or `navbarPage` object.
+#' @inheritParams tabsetPanel
 #'
-#' @seealso \code{\link{tabsetPanel}}, \code{\link{navlistPanel}},
-#' \code{\link{navbarPage}}
+#' @seealso [tabsetPanel()], [navlistPanel()],
+#' [navbarPage()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -322,7 +319,9 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateTabsetPanel <- function(session, inputId, selected = NULL) {
+updateTabsetPanel <- function(session = getDefaultReactiveDomain(), inputId, selected = NULL) {
+  validate_session_object(session)
+
   message <- dropNulls(list(value = selected))
   session$sendInputMessage(inputId, message)
 }
@@ -338,12 +337,9 @@ updateNavlistPanel <- updateTabsetPanel
 #' Change the value of a number 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.
+#' @inheritParams numericInput
 #'
-#' @seealso \code{\link{numericInput}}
+#' @seealso [numericInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -373,9 +369,11 @@ updateNavlistPanel <- updateTabsetPanel
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
+updateNumericInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL,
     min = NULL, max = NULL, step = NULL) {
 
+  validate_session_object(session)
+
   message <- dropNulls(list(
     label = label, value = formatNoSci(value),
     min = formatNoSci(min), max = formatNoSci(max), step = formatNoSci(step)
@@ -388,14 +386,9 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #' 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.
+#' @inheritParams sliderInput
 #'
-#' @seealso \code{\link{sliderInput}}
+#' @seealso [sliderInput()]
 #'
 #' @examples
 #' ## Only run this example in interactive R sessions
@@ -425,16 +418,20 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #'   )
 #' }
 #' @export
-updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
+updateSliderInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL,
   min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
 {
+  validate_session_object(session)
+
+  # 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)
 
   if (is.null(timeFormat)) {
     timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if (dataType == "date" || dataType == "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)
@@ -458,6 +455,8 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
 updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
                                selected = NULL, inline = FALSE, type = NULL,
                                choiceNames = NULL, choiceValues = NULL) {
+  validate_session_object(session)
+
   if (is.null(type)) stop("Please specify the type ('checkbox' or 'radio')")
 
   args <- normalizeChoicesArgs(choices, choiceNames, choiceValues, mustExist = FALSE)
@@ -481,7 +480,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
@@ -515,9 +514,12 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateCheckboxGroupInput <- function(session, inputId, label = NULL,
+updateCheckboxGroupInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL,
   choices = NULL, selected = NULL, inline = FALSE,
-  choiceNames = NULL, choiceValues = NULL) {
+  choiceNames = NULL, choiceValues = NULL)
+{
+  validate_session_object(session)
+
   updateInputOptions(session, inputId, label, choices, selected,
                      inline, "checkbox", choiceNames, choiceValues)
 }
@@ -528,7 +530,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
@@ -558,9 +560,12 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
+updateRadioButtons <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, choices = NULL,
                                selected = NULL, inline = FALSE,
-                               choiceNames = NULL, choiceValues = NULL) {
+                               choiceNames = NULL, choiceValues = NULL)
+{
+  validate_session_object(session)
+
   # you must select at least one radio button
   if (is.null(selected)) {
     if (!is.null(choices)) selected <- choices[[1]]
@@ -576,7 +581,7 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @template update-input
 #' @inheritParams selectInput
 #'
-#' @seealso \code{\link{selectInput}} \code{\link{varSelectInput}}
+#' @seealso [selectInput()] [varSelectInput()]
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -610,25 +615,31 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
-                              selected = NULL) {
+updateSelectInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, choices = NULL,
+                              selected = NULL)
+{
+  validate_session_object(session)
+
   choices <- if (!is.null(choices)) choicesWithNames(choices)
   if (!is.null(selected)) selected <- as.character(selected)
-  options <- if (!is.null(choices)) selectOptions(choices, selected)
+  options <- if (!is.null(choices)) selectOptions(choices, selected, inputId, FALSE)
   message <- dropNulls(list(label = label, options = options, value = selected))
   session$sendInputMessage(inputId, message)
 }
 
 #' @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,
+updateSelectizeInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, choices = NULL,
                                  selected = NULL, options = list(),
-                                 server = FALSE) {
+                                 server = FALSE)
+{
+  validate_session_object(session)
+
   if (length(options)) {
     res <- checkAsIs(options)
     cfg <- tags$script(
@@ -741,12 +752,15 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
 #' @rdname updateSelectInput
 #' @inheritParams varSelectInput
 #' @export
-updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL) {
+updateVarSelectInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, data = NULL, selected = NULL) {
+  validate_session_object(session)
+
   if (is.null(data)) {
     choices <- NULL
   } else {
     choices <- colnames(data)
   }
+
   updateSelectInput(
     session = session,
     inputId = inputId,
@@ -757,7 +771,11 @@ updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, se
 }
 #' @rdname updateSelectInput
 #' @export
-updateVarSelectizeInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL, options = list(), server = FALSE) {
+updateVarSelectizeInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL,
+                                    data = NULL, selected = NULL, options = list(), server = FALSE)
+{
+  validate_session_object(session)
+
   if (is.null(data)) {
     choices <- NULL
   } else {

R/utils-lang.R

@@ -0,0 +1,110 @@
+# Given a list of quosures, return a function that will evaluate them and return
+# a list of resulting values. If the list contains a single expression, unwrap
+# it from the list.
+quos_to_func <- function(qs) {
+  if (length(qs) == 0) {
+    stop("Need at least one item in `...` to use as cache key or event.")
+  }
+
+  if (length(qs) == 1) {
+    # Special case for one quosure. This is needed for async to work -- that is,
+    # when the quosure returns a promise. It needs to not be wrapped into a list
+    # for the hybrid_chain stuff to detect that it's a promise. (Plus, it's not
+    # even clear what it would mean to mix promises and non-promises in the
+    # key.)
+    qs <- qs[[1]]
+    function() {
+      eval_tidy(qs)
+    }
+
+  } else {
+    function() {
+      lapply(qs, eval_tidy)
+    }
+  }
+}
+
+# Given a list of quosures, return a string representation of the expressions.
+#
+# qs <- list(quo(a+1), quo({ b+2; b + 3 }))
+# quos_to_label(qs)
+# #> [1] "a + 1, {\n    b + 2\n    b + 3\n}"
+quos_to_label <- function(qs) {
+  res <- lapply(qs, function(q) {
+    paste(deparse(get_expr(q)), collapse = "\n")
+  })
+
+  paste(res, collapse = ", ")
+}
+
+# Get the formals and body for a function, without source refs. This is used for
+# consistent hashing of the function.
+formalsAndBody <- function(x) {
+  if (is.null(x)) {
+    return(list())
+  }
+
+  list(
+    formals = formals(x),
+    body = body(zap_srcref(x))
+  )
+}
+
+
+# This function is to be called from functions like `reactive()`, `observe()`,
+# and the various render functions. It handles the following cases:
+# - The typical case where x is an unquoted expression, and `env` and `quoted`
+#   are not used.
+# - New-style metaprogramming cases, where rlang::inject() is used to inline a
+#   quosure into the AST, as in `inject(reactive(!!x))`.
+# - Old-style metaprogramming cases, where `env` and/or `quoted` are used.
+#
+# Much of the complexity is handling old-style metaprogramming cases. The code
+# in this function is more complicated because it needs to look at unevaluated
+# expressions in the _calling_ function. If this code were put directly in the
+# calling function, it would look like this:
+#
+# if (!missing(env) || !missing(quoted)) {
+#   deprecatedEnvQuotedMessage()
+#   if (!quoted) x <- substitute(x)
+#   x <- new_quosure(x, env)
+#
+# } else {
+#   x <- substitute(x)
+#   if (!is_quosure(x)) {
+#     x <- new_quosure(x, env = parent.frame())
+#   }
+# }
+#
+# In the future, the calling functions will not need to have the `env` and
+# `quoted` arguments -- `rlang::inject()` and quosures can be used instead.
+# Instead of using this function, `get_quosure()`, the caller can instead use
+# just the following code:
+#
+# x <- substitute(x)
+# if (!is_quosure(x)) {
+#   x <- new_quosure(x, env = parent.frame())
+# }
+#
+get_quosure <- function(x, env, quoted) {
+  if (!eval(substitute(missing(env)), parent.frame()) ||
+      !eval(substitute(missing(quoted)), parent.frame()))
+  {
+    deprecatedEnvQuotedMessage()
+    if (!quoted) {
+      x <- eval(substitute(substitute(x)), parent.frame())
+    }
+    x <- new_quosure(x, env)
+
+  } else {
+    x <- eval(substitute(substitute(x)), parent.frame())
+
+    # At this point, x can be a quosure if rlang::inject() is used, but the
+    # typical case is that x is not a quosure.
+    if (!is_quosure(x)) {
+      x <- new_quosure(x, env = parent.frame(2L))
+    }
+  }
+
+  x
+}

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)
@@ -113,24 +113,6 @@ isWholeNum <- function(x, tol = .Machine$double.eps^0.5) {
   abs(x - round(x)) < tol
 }
 
-`%OR%` <- function(x, y) {
-  if (is.null(x) || isTRUE(is.na(x)))
-    y
-  else
-    x
-}
-
-`%AND%` <- function(x, y) {
-  if (!is.null(x) && !isTRUE(is.na(x)))
-    if (!is.null(y) && !isTRUE(is.na(y)))
-      return(y)
-  return(NULL)
-}
-
-`%.%` <- function(x, y) {
-  paste(x, y, sep='')
-}
-
 # Given a vector or list, drop all the NULL items in it
 dropNulls <- function(x) {
   x[!vapply(x, is.null, FUN.VALUE=logical(1))]
@@ -173,15 +155,19 @@ anyUnnamed <- function(x) {
 }
 
 
-# Given a vector/list, returns a named vector (the labels will be blank).
-asNamedVector <- function(x) {
-  if (!is.null(names(x)))
-    return(x)
+# 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))
+  }
 
-  names(x) <- rep.int("", length(x))
   x
 }
 
+empty_named_list <- function() {
+  list(a = 1)[0]
+}
+
 # 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
@@ -210,6 +196,17 @@ sortByName <- function(x) {
   x[order(names(x))]
 }
 
+# Sort a vector. If a character vector, sort using C locale, which is consistent
+# across platforms. Note that radix sort uses C locale according to ?sort.
+sort_c <- function(x, ...) {
+  # Use UTF-8 encoding, because if encoding is "unknown" for non-ASCII
+  # characters, the sort() will throw an error.
+  if (is.character(x))
+    x <- enc2utf8(x)
+  sort(x, method = "radix", ...)
+}
+
+
 # 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.
@@ -316,6 +313,15 @@ resolve <- function(dir, relpath) {
   return(abs.path)
 }
 
+# Given a string, make sure it has a trailing slash.
+ensure_trailing_slash <- function(path) {
+  if (!grepl("/$", path)) {
+    path <- paste0(path, "/")
+  }
+  path
+}
+
+
 isWindows <- function() .Platform$OS.type == 'windows'
 
 # This is a wrapper for download.file and has the same interface.
@@ -408,7 +414,8 @@ makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
 #' Convert an expression to a function
 #'
 #' This is to be called from another function, because it will attempt to get
-#' an unquoted expression from two calls back.
+#' an unquoted expression from two calls back. Note: as of Shiny 1.6.0, it is
+#' recommended to use [quoToFunction()] instead.
 #'
 #' If expr is a quoted expression, then this just converts it to a function.
 #' If expr is a function, then this simply returns expr (and prints a
@@ -466,14 +473,15 @@ exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
 #' Install an expression as a function
 #'
 #' Installs an expression in the given environment as a function, and registers
-#' debug hooks so that breakpoints may be set in the function.
+#' debug hooks so that breakpoints may be set in the function. Note: as of
+#' Shiny 1.6.0, it is recommended to use [quoToFunction()] instead.
 #'
-#' 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
@@ -485,7 +493,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,
@@ -512,10 +520,53 @@ installExprFunction <- function(expr, name, eval.env = parent.frame(2),
   assign(name, func, envir = assign.env)
 }
 
+#' Convert a quosure to a function for a Shiny render function
+#'
+#' This takes a quosure and label, and wraps them into a function that should be
+#' passed to [createRenderFunction()] or [markRenderFunction()].
+#'
+#' This function was added in Shiny 1.6.0. Previously, it was recommended to use
+#' [installExprFunction()] or [exprToFunction()] in render functions, but now we
+#' recommend using [quoToFunction()], because it does not require `env` and
+#' `quoted` arguments -- that information is captured by quosures provided by
+#' \pkg{rlang}.
+#'
+#' @param q A quosure.
+#' @inheritParams installExprFunction
+#' @seealso [createRenderFunction()] for example usage.
+#'
+#' @export
+quoToFunction <- function(q, label, ..stacktraceon = FALSE) {
+  q <- as_quosure(q)
+  # Use new_function() instead of as_function(), because as_function() adds an
+  # extra parent environment. (This may not actually be a problem, though.)
+  func <- new_function(NULL, get_expr(q), get_env(q))
+  wrapFunctionLabel(func, label, ..stacktraceon = ..stacktraceon)
+}
+
+
+# Utility function for creating a debugging label, given an expression.
+# `expr` is a quoted expression.
+# `function_name` is the name of the calling function.
+# `label` is an optional user-provided label. If NULL, it will be inferred.
+exprToLabel <- function(expr, function_name, label = NULL) {
+  srcref <- attr(expr, "srcref", exact = TRUE)
+  if (is.null(label)) {
+    label <- rexprSrcrefToLabel(
+      srcref[[1]],
+      sprintf('%s(%s)', function_name, paste(deparse(expr), collapse = '\n'))
+    )
+  }
+  if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
+  attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
+  label
+}
+
 #' Parse a GET query string from a URL
 #'
 #' 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
@@ -611,37 +662,6 @@ shinyCallingHandlers <- function(expr) {
   )
 }
 
-#' Print message for deprecated functions in Shiny
-#'
-#' To disable these messages, use \code{options(shiny.deprecation.messages=FALSE)}.
-#'
-#' @param new Name of replacement function.
-#' @param msg Message to print. If used, this will override the default message.
-#' @param old Name of deprecated function.
-#' @param version The last version of Shiny before the item was deprecated.
-#' @keywords internal
-shinyDeprecated <- function(new=NULL, msg=NULL,
-                            old=as.character(sys.call(sys.parent()))[1L],
-                            version = NULL) {
-
-  if (getOption("shiny.deprecation.messages") %OR% TRUE == FALSE)
-    return(invisible())
-
-  if (is.null(msg)) {
-    msg <- paste(old, "is deprecated.")
-    if (!is.null(new)) {
-      msg <- paste(msg, "Please use", new, "instead.",
-        "To disable this message, run options(shiny.deprecation.messages=FALSE)")
-    }
-  }
-
-  if (!is.null(version)) {
-    msg <- paste0(msg, " (Last used in version ", version, ")")
-  }
-
-  # Similar to .Deprecated(), but print a message instead of warning
-  message(msg)
-}
 
 #' Register a function with the debugger (if one is active).
 #'
@@ -799,7 +819,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])
@@ -949,28 +976,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
@@ -1084,58 +1111,45 @@ reactiveStop <- function(message = "", class = NULL) {
 
 #' Validate input values and other conditions
 #'
-#' For an output rendering function (e.g. \code{\link{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
-#' doing so.
+#' @description
+#' `validate()` provides convenient mechanism for validating that an output
+#' has all the inputs necessary for successful rendering. It takes any number
+#' of (unnamed) arguments, each representing a condition to test. If any
+#' of condition fails (i.e. is not ["truthy"][isTruthy]), a special type of
+#' error is signaled to stop execution. If this error is not handled by
+#' application-specific code, it is displayed to the user by Shiny.
 #'
-#' The \code{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.
+#' If you use `validate()` in a [reactive()] validation failures will
+#' automatically propagate to outputs that use the reactive.
 #'
-#' An easy way to provide arguments to \code{validate} is to use the \code{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
-#' the following:
+#' @section `need()`:
+#' An easy way to provide arguments to `validate()` is to use `need()`, which
+#' takes an expression and a string. If the expression is not
+#' ["truthy"][isTruthy] then the string will be used as the error message.
 #'
-#' \itemize{
-#'   \item{\code{FALSE}}
-#'   \item{\code{NULL}}
-#'   \item{\code{""}}
-#'   \item{An empty atomic vector}
-#'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all \code{FALSE} or missing values}
-#'   \item{An object of class \code{"try-error"}}
-#'   \item{A value that represents an unclicked \code{\link{actionButton}}}
+#' If "truthiness" is flexible for your use case, you'll need to explicitly
+#' generate a logical values. For example, if you want allow `NA` but not
+#' `NULL`, you can `!is.null(input$foo)`.
+#'
+#' If you need validation logic that differs significantly from `need()`, you
+#' can create your own validation test functions. A passing test should return
+#' `NULL`. A failing test should return either a string providing the error
+#' to display to the user, or if the failure should happen silently, `FALSE`.
+#'
+#' Alternatively you can use `validate()` within an `if` statement, which is
+#' particularly useful for more complex conditions:
+#'
+#' ```
+#' if (input$x < 0 && input$choice == "positive") {
+#'   validate("If choice is positive then x must be greater than 0")
 #' }
+#' ```
 #'
-#' 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}.
-#'
-#' If you need validation logic that differs significantly from \code{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
-#' single-element character vector, or if the failure should happen silently,
-#' \code{FALSE}.
-#'
-#' Because validation failure is signaled as an error, you can use
-#' \code{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.
-#'
-#' @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
@@ -1187,10 +1201,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
@@ -1206,103 +1220,71 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 
 #' Check for required values
 #'
-#' Ensure that values are available ("truthy"--see Details) before proceeding
+#' Ensure that values are available (["truthy"][isTruthy]) before proceeding
 #' with a calculation or action. If any of the given values is not truthy, the
 #' operation is stopped by raising a "silent" exception (not logged by Shiny,
 #' nor displayed in the Shiny app's UI).
 #'
-#' The \code{req} function was designed to be used in one of two ways. The first
+#' 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:
 #'
-#' \preformatted{rv <- reactiveValues(state = FALSE)
+#' ```
+#' rv <- reactiveValues(state = FALSE)
 #' r <- reactive({
 #'   req(input$a, input$b, rv$state)
 #'   # Code that uses input$a, input$b, and/or rv$state...
-#' })}
+#' })
+#' ```
 #'
-#' In this example, if \code{r()} is called and any of \code{input$a},
-#' \code{input$b}, and \code{rv$state} are \code{NULL}, \code{FALSE}, \code{""},
-#' etc., then the \code{req} call will trigger an error that propagates all the
+#' 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:
 #'
-#' \preformatted{output$plot <- renderPlot({
+#' ```
+#' output$plot <- renderPlot({
 #'   if (req(input$plotType) == "histogram") {
 #'     hist(dataset())
 #'   } else if (input$plotType == "scatter") {
 #'     qplot(dataset(), aes(x = x, y = y))
 #'   }
-#' })}
+#' })
+#' ```
 #'
-#' In this example, \code{req(input$plotType)} first checks that
-#' \code{input$plotType} is truthy, and if so, returns it. This is a convenient
+#' 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}
+#' @section Using `req(FALSE)`:
 #'
-#' The terms "truthy" and "falsy" generally indicate whether a value, when
-#' coerced to a \code{\link[base]{logical}}, is \code{TRUE} or \code{FALSE}. We use
-#' the term a little loosely here; our usage tries to match the intuitive
-#' notions of "Is this value missing or available?", or "Has the user provided
-#' an answer?", or in the case of action buttons, "Has the button been
-#' clicked?".
-#'
-#' For example, a \code{textInput} that has not been filled out by the user has
-#' a value of \code{""}, so that is considered a falsy value.
-#'
-#' To be precise, \code{req} considers a value truthy \emph{unless} it is one
-#' of:
-#'
-#' \itemize{
-#'   \item{\code{FALSE}}
-#'   \item{\code{NULL}}
-#'   \item{\code{""}}
-#'   \item{An empty atomic vector}
-#'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all \code{FALSE} or missing values}
-#'   \item{An object of class \code{"try-error"}}
-#'   \item{A value that represents an unclicked \code{\link{actionButton}}}
-#' }
-#'
-#' Note in particular that the value \code{0} is considered truthy, even though
-#' \code{as.logical(0)} is \code{FALSE}.
-#'
-#' If the built-in rules for truthiness do not match your requirements, you can
-#' always work around them. Since \code{FALSE} is falsy, you can simply provide
-#' the results of your own checks to \code{req}:
-#'
-#' \code{req(input$a != 0)}
-#'
-#' \strong{Using \code{req(FALSE)}}
-#'
-#' You can use \code{req(FALSE)} (i.e. no condition) if you've already performed
+#' 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}}
+#' @section 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
 #' @return The first value that was passed in.
 #' @export
 #' @examples
@@ -1392,14 +1374,40 @@ cancelOutput <- function() {
 #
 # Can be used to facilitate short-circuit eval on dots.
 dotloop <- function(fun_, ...) {
-  for (i in 1:(nargs()-1)) {
+  for (i in seq_len(nargs() - 1)) {
     fun_(eval(as.symbol(paste0("..", i))))
   }
   invisible()
 }
 
+#' Truthy and falsy values
+#'
+#' The terms "truthy" and "falsy" generally indicate whether a value, when
+#' 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 `textInput` that has not been filled out by the user has
+#' a value of `""`, so that is considered a falsy value.
+#'
+#' To be precise, a value is truthy *unless* it is one of:
+#'
+#' * `FALSE`
+#' * `NULL`
+#' * `""`
+#' * An empty atomic vector
+#' * An atomic vector that contains only missing values
+#' * A logical vector that contains all `FALSE` or missing values
+#' * An object of class `"try-error"`
+#' * A value that represents an unclicked [actionButton()]
+#'
+#' Note in particular that the value `0` is considered truthy, even though
+#' `as.logical(0)` is `FALSE`.
+#'
+#' @param x An expression whose truthiness value we want to determine
 #' @export
-#' @rdname req
 isTruthy <- function(x) {
   if (inherits(x, 'try-error'))
     return(FALSE)
@@ -1438,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.
@@ -1476,7 +1484,7 @@ checkEncoding <- function(file) {
   if (identical(charToRaw(readChar(file, 3L, TRUE)), charToRaw('\UFEFF'))) {
     warning('You should not include the Byte Order Mark (BOM) in ', file, '. ',
             'Please re-save it in UTF-8 without BOM. See ',
-            'http://shiny.rstudio.com/articles/unicode.html for more info.')
+            'https://shiny.rstudio.com/articles/unicode.html for more info.')
     return('UTF-8-BOM')
   }
   x <- readChar(file, size, useBytes = TRUE)
@@ -1560,6 +1568,29 @@ URLencode <- function(value, reserved = FALSE) {
   if (reserved) encodeURIComponent(value) else encodeURI(value)
 }
 
+# Make sure 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". If any of the values result in error or NA, then the input
+# `date` is returned unchanged.
+dateYMD <- function(date = NULL, argName = "value") {
+  if (!length(date)) return(NULL)
+  tryCatch({
+      res <- format(as.Date(date), "%Y-%m-%d")
+      if (any(is.na(res))) stop()
+      date <- res
+    },
+    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
@@ -1572,18 +1603,17 @@ wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
   assign(name, func, environment())
   registerDebugHook(name, environment(), name)
 
-  relabelWrapper <- eval(substitute(
-    function(...) {
-      # This `f` gets renamed to the value of `name`. Note that it may not
-      # print as the new name, because of source refs stored in the function.
-      if (..stacktraceon)
-        ..stacktraceon..(f(...))
-      else
-        f(...)
-    },
-    list(f = as.name(name))
-  ))
+  if (..stacktraceon) {
+    # We need to wrap the `...` in `!!quote(...)` so that R CMD check won't
+    # complain about "... may be used in an incorrect context"
+    body <- expr({ ..stacktraceon..((!!name)(!!quote(...))) })
+  } else {
+    body <- expr({ (!!name)(!!quote(...)) })
+  }
+  relabelWrapper <- new_function(pairlist2(... =), body, environment())
 
+  # Preserve the original function that was passed in; is used for caching.
+  attr(relabelWrapper, "wrappedFunc") <- func
   relabelWrapper
 }
 
@@ -1643,19 +1673,23 @@ hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
           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)
+            p <- promise_chain(valueWithVisible(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)
+            result <- Reduce(
+              function(v, func) {
+                if (v$visible) {
+                  withVisible(func(v$value))
+                } else {
+                  withVisible(func(invisible(v$value)))
+                }
+              },
+              list(...),
+              result
+            )
 
-            setVisible(result)
+            valueWithVisible(result)
           }
         })
       },
@@ -1676,24 +1710,13 @@ hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
   }
 }
 
-# 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)
-  }
+# Given a list with items named `value` and `visible`, return `x$value` either
+# visibly, or invisibly, depending on the value of `x$visible`.
+valueWithVisible <- function(x) {
+  if (x$visible) x$value else invisible(x$value)
 }
 
+
 createVarPromiseDomain <- function(env, name, value) {
   force(env)
   force(name)
@@ -1728,19 +1751,6 @@ createVarPromiseDomain <- function(env, name, value) {
   )
 }
 
-getSliderType <- function(min, max, value) {
-  vals <- dropNulls(list(value, min, max))
-  type <- unique(lapply(vals, function(x) {
-    if      (inherits(x, "Date"))   "date"
-    else if (inherits(x, "POSIXt")) "datetime"
-    else                            "number"
-  }))
-  if (length(type) > 1) {
-    stop("Type mismatch for `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() {
@@ -1779,3 +1789,82 @@ constantTimeEquals <- function(raw1, raw2) {
 
   sum(as.integer(xor(raw1, raw2))) == 0
 }
+
+cat_line <- function(...) {
+  cat(paste(..., "\n", collapse = ""))
+}
+
+select_menu <- function(choices, title = NULL, msg = "Enter one or more numbers (with spaces), or an empty line to exit: \n")
+{
+  if (!is.null(title)) {
+    cat(title, "\n", sep = "")
+  }
+  nc <- length(choices)
+  op <- paste0(format(seq_len(nc)), ": ", choices)
+  fop <- format(op)
+  cat("", fop, "", sep = "\n")
+  repeat {
+    answer <- readline(msg)
+    answer <- strsplit(answer, "[ ,]+")[[1]]
+    if (all(answer %in% seq_along(choices))) {
+      return(choices[as.integer(answer)])
+    }
+  }
+}
+
+#' @noRd
+isAppDir <- function(path) {
+
+  if (file.exists(file.path.ci(path, "app.R")))
+    return(TRUE)
+
+  if (file.exists(file.path.ci(path, "server.R"))
+      && file.exists(file.path.ci(path, "ui.R")))
+    return(TRUE)
+
+  FALSE
+}
+
+# Borrowed from rprojroot which borrowed from devtools
+#' @noRd
+is_root <- function(path) {
+  identical(
+    normalizePath(path, winslash = "/"),
+    normalizePath(dirname(path), winslash = "/")
+  )
+}
+
+#' @noRd
+findEnclosingApp <- function(path = ".") {
+  orig_path <- path
+  path <- normalizePath(path, winslash = "/", mustWork = TRUE)
+  repeat {
+    if (isAppDir(path))
+      return(path)
+    if (is_root(path))
+      stop("Shiny app not found at ", orig_path, " or in any parent directory.")
+    path <- dirname(path)
+  }
+}
+
+# Check if a package is installed, and if version is specified,
+# that we have at least that version
+is_available <- function(package, version = NULL) {
+  installed <- nzchar(system.file(package = package))
+  if (is.null(version)) {
+    return(installed)
+  }
+  installed && isTRUE(utils::packageVersion(package) >= version)
+}
+
+
+# cached version of utils::packageVersion("shiny")
+shinyPackageVersion <- local({
+  version <- NULL
+  function() {
+    if (is.null(version)) {
+      version <<- utils::packageVersion("shiny")
+    }
+    version
+  }
+})

R/version_jquery.R

@@ -0,0 +1,2 @@
+# Generated by tools/updatejQuery.R; do not edit by hand
+version_jquery <- "3.6.0"

R/viewer.R

@@ -0,0 +1,56 @@
+
+#' Viewer options
+#'
+#' Use these functions to control where the gadget is displayed in RStudio (or
+#' other R environments that emulate RStudio's viewer pane/dialog APIs). If
+#' viewer APIs are not available in the current R environment, then the gadget
+#' will be displayed in the system's default web browser (see
+#' [utils::browseURL()]).
+#'
+#' @return A function that takes a single `url` parameter, suitable for
+#'   passing as the `viewer` argument of [runGadget()].
+#'
+#' @rdname viewer
+#' @name viewer
+NULL
+
+#' @param minHeight The minimum height (in pixels) desired to show the gadget in
+#'   the viewer pane. If a positive number, resize the pane if necessary to show
+#'   at least that many pixels. If `NULL`, use the existing viewer pane
+#'   size. If `"maximize"`, use the maximum available vertical space.
+#' @rdname viewer
+#' @export
+paneViewer <- function(minHeight = NULL) {
+  viewer <- getOption("viewer")
+  if (is.null(viewer)) {
+    utils::browseURL
+  } else {
+    function(url) {
+      viewer(url, minHeight)
+    }
+  }
+}
+
+#' @param dialogName The window title to display for the dialog.
+#' @param width,height The desired dialog width/height, in pixels.
+#' @rdname viewer
+#' @export
+dialogViewer <- function(dialogName, width = 600, height = 600) {
+  viewer <- getOption("shinygadgets.showdialog")
+  if (is.null(viewer)) {
+    utils::browseURL
+  } else {
+    function(url) {
+      viewer(dialogName, url, width = width, height = height)
+    }
+  }
+}
+
+#' @param browser See [utils::browseURL()].
+#' @rdname viewer
+#' @export
+browserViewer <- function(browser = getOption("browser")) {
+  function(url) {
+    utils::browseURL(url, browser = browser)
+  }
+}

README.md

@@ -1,67 +1,59 @@
-# Shiny
+# shiny <img src="man/figures/logo.png" align="right" width=120 height=139 alt="" />
 
-*Travis:* [![Travis Build Status](https://travis-ci.org/rstudio/shiny.svg?branch=master)](https://travis-ci.org/rstudio/shiny)
+<!-- badges: start -->
+[![CRAN](https://www.r-pkg.org/badges/version/shiny)](https://CRAN.R-project.org/package=shiny)
+[![R build status](https://github.com/rstudio/shiny/workflows/R-CMD-check/badge.svg)](https://github.com/rstudio/shiny/actions)
+[![RStudio community](https://img.shields.io/badge/community-shiny-blue?style=social&logo=rstudio&logoColor=75AADB)](https://community.rstudio.com/new-topic?category=shiny&tags=shiny)
 
-*AppVeyor:* [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/rstudio/shiny?branch=master&svg=true)](https://ci.appveyor.com/project/rstudio/shiny)
+<!-- badges: end -->
 
-Shiny is a new package from RStudio that makes it incredibly easy to build interactive web applications with R.
-
-For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstudio.com/).
-
-If you have general questions about using Shiny, please use the [RStudio Community website](https://community.rstudio.com). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
+Easily build rich and productive interactive web apps in R &mdash; no HTML/CSS/JavaScript required.
 
 ## Features
 
-* Build useful web applications with only a few lines of code&mdash;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/).
-* A highly customizable slider widget with built-in support for animation.
-* 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!).
+* An intuitive and extensible [reactive programming](https://en.wikipedia.org/wiki/Reactive_programming) model which makes it easy to transform existing R code into a "live app" where outputs automatically react to new user input.
+  * Compared to event-based programming, reactivity allows Shiny to do the minimum amount of work when input(s) change, and allows humans to more easily reason about complex [MVC logic](https://en.wikipedia.org/wiki/Model%E2%80%93view%E2%80%93controller).
+* A prebuilt set of highly sophisticated, customizable, and easy-to-use widgets (e.g., plots, tables, sliders, dropdowns, date pickers, and more).
+* An attractive default look based on [Bootstrap](https://getbootstrap.com/) which can also be easily customized with the [bslib](https://github.com/rstudio/bslib) package or avoided entirely with more direct R bindings to HTML/CSS/JavaScript.
+* Seamless integration with [R Markdown](https://shiny.rstudio.com/articles/interactive-docs.html), making it easy to embed numerous applications natively within a larger dynamic document.
+* Tools for improving and monitoring performance, including native support for [async programming](https://blog.rstudio.com/2018/06/26/shiny-1-1-0/), [caching](https://talks.cpsievert.me/20201117), [load testing](https://rstudio.github.io/shinyloadtest/), and [more](https://support.rstudio.com/hc/en-us/articles/231874748-Scaling-and-Performance-Tuning-in-RStudio-Connect).
+* [Modules](https://shiny.rstudio.com/articles/modules.html): a framework for reducing code duplication and complexity.
+* An ability to [bookmark application state](https://shiny.rstudio.com/articles/bookmarking-state.html) and/or [generate code to reproduce output(s)](https://github.com/rstudio/shinymeta).
+* A rich ecosystem of extension packages for more [custom widgets](http://www.htmlwidgets.org/), [input validation](https://github.com/rstudio/shinyvalidate), [unit testing](https://github.com/rstudio/shinytest), and more.
 
 ## Installation
 
-To install the stable version from CRAN, simply run the following from an R console:
+To install the stable version from CRAN:
 
 ```r
 install.packages("shiny")
 ```
 
-To install the latest development builds directly from GitHub, run this instead:
-
-```r
-if (!require("devtools"))
-  install.packages("devtools")
-devtools::install_github("rstudio/shiny")
-```
-
 ## Getting Started
 
-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.
+Once installed, load the library and run an example:
 
-## 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.
-
-If you do not wish to update your code at this time, you can use the [shinybootstrap2](https://github.com/rstudio/shinybootstrap2) package for backward compatibility.
-
-If you prefer to install an older version of Shiny, you can do it using the devtools package:
-
-```R
-devtools::install_version("shiny", version = "0.10.2.2")
+```r
+library(shiny)
+# Launches an app, with the app's source code included
+runExample("06_tabsets")
+# Lists more prepackaged examples
+runExample()
 ```
 
-## Development notes
+For more examples and inspiration, check out the [Shiny User Gallery](https://shiny.rstudio.com/gallery/).
 
-The Javascript code in Shiny is minified using tools that run on Node.js. See the tools/ directory for more information.
+For help with learning fundamental Shiny programming concepts, check out the [Mastering Shiny](https://mastering-shiny.org/) book and the [Shiny Tutorial](https://shiny.rstudio.com/tutorial/). The former is currently more up-to-date with modern Shiny features, whereas the latter takes a deeper, more visual, dive into fundamental concepts.
 
-## Guidelines for contributing
+## Getting Help
 
-We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.md](CONTRIBUTING.md) file for detailed guidelines of how to contribute.
+To ask a question about Shiny, please use the [RStudio Community website](https://community.rstudio.com/new-topic?category=shiny&tags=shiny). 
+
+For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues) and also keep in mind that by [writing a good bug report](https://github.com/rstudio/shiny/wiki/Writing-Good-Bug-Reports), you're more likely to get help with your problem. 
+
+## 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
 

appveyor.yml

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

inst/app_template/R/example-module.R

@@ -0,0 +1,27 @@
+exampleModuleUI <- function(id, label = "Counter") {
+  # All uses of Shiny input/output IDs in the UI must be namespaced,
+  # as in ns("x").
+  ns <- NS(id)
+  tagList(
+    actionButton(ns("button"), label = label),
+    verbatimTextOutput(ns("out"))
+  )
+}
+
+exampleModuleServer <- function(id) {
+  # moduleServer() wraps a function to create the server component of a
+  # module.
+  moduleServer(
+    id,
+    function(input, output, session) {
+      count <- reactiveVal(0)
+      observeEvent(input$button, {
+        count(count() + 1)
+      })
+      output$out <- renderText({
+        count()
+      })
+      count
+    }
+  )
+}

inst/app_template/R/example.R

@@ -0,0 +1,5 @@
+# Given a numeric vector, convert to strings, sort, and convert back to
+# numeric.
+lexical_sort <- function(x) {
+  as.numeric(sort(as.character(x)))
+}

inst/app_template/app.R

@@ -0,0 +1,56 @@
+ui <- fluidPage(
+{{
+# These blocks of code are processed with htmlTemplate()
+if (isTRUE(module)) {
+'  # ======== Modules ========
+  # exampleModuleUI is defined in R/example-module.R
+  wellPanel(
+    h2("Modules example"),
+    exampleModuleUI("examplemodule1", "Click counter #1"),
+    exampleModuleUI("examplemodule2", "Click counter #2")
+  ),
+  # =========================
+'
+}
+}}
+  wellPanel(
+    h2("Sorting example"),
+    sliderInput("size", "Data size", min = 5, max = 20, value = 10),
+{{
+if (isTRUE(rdir)) {
+  '    div("Lexically sorted sequence:"),'
+} else {
+  '    div("Sorted sequence:"),'
+}
+}}
+    verbatimTextOutput("sequence")
+  )
+)
+
+server <- function(input, output, session) {
+{{
+if (isTRUE(module)) {
+'  # ======== Modules ========
+  # exampleModuleServer is defined in R/example-module.R
+  exampleModuleServer("examplemodule1")
+  exampleModuleServer("examplemodule2")
+  # =========================
+'
+}
+}}
+  data <- reactive({
+{{
+if (isTRUE(rdir)) {
+'    # lexical_sort from R/example.R
+    lexical_sort(seq_len(input$size))'
+} else {
+'    sort(seq_len(input$size))'
+}
+}}
+  })
+  output$sequence <- renderText({
+    paste(data(), collapse = " ")
+  })
+}
+
+shinyApp(ui, server)

inst/app_template/tests/shinytest.R

@@ -0,0 +1,2 @@
+library(shinytest)
+expect_pass(testApp("../", suffix = osName()))

inst/app_template/tests/shinytest/mytest.R

@@ -0,0 +1,12 @@
+app <- ShinyDriver$new("../../")
+app$snapshotInit("mytest")
+
+app$snapshot()
+{{
+if (isTRUE(module)) {
+'
+app$setInputs(`examplemodule1-button` = "click")
+app$setInputs(`examplemodule1-button` = "click")
+app$snapshot()'
+}
+}}