yarn build (GitHub Actions)

* Check that socket exists before sending message

* `yarn build` (GitHub Actions)

---------

Co-authored-by: wch <wch@users.noreply.github.com>

.Rbuildignore

@@ -12,7 +12,7 @@
 ^\.travis\.yml$
 ^staticdocs$
 ^tools$
-^srcjs$
+^srcts$
 ^CONTRIBUTING.md$
 ^cran-comments.md$
 ^.*\.o$
@@ -21,3 +21,19 @@
 ^TODO-promises.md$
 ^manualtests$
 ^\.github$
+
+^\.yarn$
+^\.vscode$
+^\.madgerc$
+^\.prettierrc\.yml$
+^babel\.config\.json$
+^jest\.config\.js$
+^package\.json$
+^tsconfig\.json$
+^yarn\.lock$
+^node_modules$
+^coverage$
+^.ignore$
+^\.browserslistrc$
+^\.eslintrc\.yml$
+^\.yarnrc\.yml$

.browserslistrc

@@ -0,0 +1,8 @@
+# Browsers that we support
+last 2 versions
+not dead
+> 0.2%
+# > 1%
+Firefox ESR
+phantomjs 2.1
+IE 11 # sorry

.eslintrc.yml

@@ -0,0 +1,114 @@
+root: true
+env:
+  browser: true
+  es6: true
+extends:
+  - 'eslint:recommended'
+  - 'plugin:@typescript-eslint/recommended'
+  - 'plugin:jest/recommended'
+  - 'plugin:prettier/recommended'
+  - 'plugin:jest-dom/recommended'
+globals:
+  Atomics: readonly
+  SharedArrayBuffer: readonly
+parser: '@typescript-eslint/parser'
+parserOptions:
+  ecmaVersion: 2018
+  sourceType: module
+  project:
+    - './tsconfig.json'
+ignorePatterns: # mirrors tsconfig.json's exclude
+    - '**/__tests__'
+    - '**/*.d.ts'
+plugins:
+  - '@typescript-eslint'
+  - prettier
+  - jest-dom
+  - unicorn
+rules:
+  "@typescript-eslint/explicit-function-return-type":
+    - off
+  "@typescript-eslint/no-explicit-any":
+    - off
+  "@typescript-eslint/explicit-module-boundary-types":
+    - error
+
+  default-case:
+    - error
+  indent:
+    - error
+    - 2
+    - SwitchCase: 1
+  linebreak-style:
+    - error
+    - unix
+  quotes:
+    - error
+    - double
+    - avoid-escape
+  semi:
+    - error
+    - always
+  dot-location:
+    - error
+    - property
+
+  camelcase:
+    # - error
+    - "off"
+
+  unicorn/filename-case:
+    - error
+    - case: camelCase
+
+  "@typescript-eslint/array-type":
+    - error
+    - default: array-simple
+      readonly: array-simple
+
+  "@typescript-eslint/consistent-indexed-object-style":
+    - error
+    - index-signature
+
+  "@typescript-eslint/sort-type-union-intersection-members":
+    - error
+
+  "@typescript-eslint/consistent-type-imports":
+    - error
+
+  "@typescript-eslint/no-floating-promises":
+    - error
+
+  "@typescript-eslint/naming-convention":
+    - error
+
+    - selector: default
+      format: [camelCase]
+
+    - selector: method
+      modifiers: [private]
+      format: [camelCase]
+      leadingUnderscore: require
+    - selector: method
+      modifiers: [protected]
+      format: [camelCase]
+      leadingUnderscore: require
+
+    - selector: variable
+      format: [camelCase]
+      trailingUnderscore: forbid
+      leadingUnderscore: forbid
+
+    - selector: parameter
+      format: [camelCase]
+      trailingUnderscore: allow
+      leadingUnderscore: forbid
+
+    - selector: [enum, enumMember]
+      format: [PascalCase]
+
+    - selector: typeLike
+      format: [PascalCase]
+      custom:
+        regex: "(t|T)ype$"
+        match: false

.gitattributes

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

.github/shiny-workflows/routine.sh

@@ -0,0 +1,12 @@
+#!/bin/bash -e
+. ./tools/documentation/checkDocsCurrent.sh
+
+echo "Updating package.json version to match DESCRIPTION Version"
+Rscript ./tools/updatePackageJsonVersion.R
+if [ -n "$(git status --porcelain package.json)" ]
+then
+  yarn build
+  git add ./inst package.json && git commit -m 'Sync package version (GitHub Actions)' || echo "No package version to commit"
+else
+  echo "No package version difference detected; package.json is current."
+fi

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

@@ -1,198 +1,23 @@
-name: R-CMD-check
+# Workflow derived from https://github.com/rstudio/shiny-workflows
+#
+# NOTE: This Shiny team GHA workflow is overkill for most R packages.
+# For most R packages it is better to use https://github.com/r-lib/actions
 on:
   push:
-    branches:
-      - master
+    branches: [main, rc-**]
   pull_request:
-    branches:
-      - master
+    branches: [main]
+  schedule:
+    - cron: '0 5 * * 1' # every monday
 
+name: Package checks
 
 jobs:
-
+  website:
+    uses: rstudio/shiny-workflows/.github/workflows/website.yaml@v1
+  routine:
+    uses: rstudio/shiny-workflows/.github/workflows/routine.yaml@v1
+    with:
+      node-version: "14.x"
   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
-        with:
-          r-version: ${{ matrix.config.r }}
-
-      - uses: r-lib/actions/setup-pandoc@master
-
-      - name: Query dependencies
-        run: |
-          install.packages('remotes')
-          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
-        shell: Rscript {0}
-
-      - name: Cache R packages
-        if: runner.os != 'Windows'
-        uses: actions/cache@v1
-        with:
-          path: ${{ env.R_LIBS_USER }}
-          key: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-1-${{ hashFiles('.github/depends.Rds') }}
-          restore-keys: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-1-
-
-      - name: Install system dependencies
-        if: runner.os == 'Linux'
-        env:
-          RHUB_PLATFORM: linux-x86_64-ubuntu-gcc
-        run: |
-          Rscript -e "remotes::install_github('r-hub/sysreqs')"
-          sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))")
-          sudo -s eval "$sysreqs"
-
-      - name: Install dependencies
-        run: |
-          remotes::install_deps(dependencies = TRUE)
-          remotes::install_cran("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@v1
-        with:
-          path: ${{ steps.phantomjs.outputs.path }}
-          key: ${{ runner.os }}-phantomjs
-          restore-keys: ${{ runner.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: ${{ runner.os }}-r${{ matrix.config.r }}-results
-          path: check
-
-
-  documentation:
-    runs-on: ${{ matrix.config.os }}
-    name: documentation
-
-    strategy:
-      fail-fast: false
-      matrix:
-        config:
-          - {os: macOS-latest, r: '4.0'}
-
-    env:
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
-
-    steps:
-      - uses: actions/checkout@v2
-
-      - uses: r-lib/actions/setup-r@master
-        with:
-          r-version: ${{ matrix.config.r }}
-
-      - name: Query dependencies
-        run: |
-          install.packages('remotes')
-          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
-        shell: Rscript {0}
-      - name: Cache R packages
-        uses: actions/cache@v1
-        with:
-          path: ${{ env.R_LIBS_USER }}
-          key: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-2-${{ hashFiles('.github/depends.Rds') }}
-          restore-keys: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-2-
-      - name: Remove dependencies file
-        run: |
-          rm .github/depends.Rds
-
-      - name: Install dependencies
-        run: |
-          install.packages(c("remotes"))
-          remotes::install_deps(dependencies = TRUE)
-          remotes::install_cran("devtools")
-          remotes::install_cran("rprojroot")
-        shell: Rscript {0}
-
-      - name: Check documentation
-        run: |
-          ./tools/documentation/checkDocsCurrent.sh
-
-
-  node_js:
-    runs-on: macOS-latest
-    name: node_js
-
-    steps:
-      - uses: actions/checkout@v2
-
-      - uses: actions/setup-node@v1
-        with:
-          node-version: '12.x'
-
-      # 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@v1
-        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: ${{ runner.os }}-yarn-${{ hashFiles('**/yarn.lock') }}
-          restore-keys: |
-            ${{ runner.os }}-yarn-
-
-      - name: Check node build
-        run: |
-          ./tools/checkJSCurrent.sh
+    uses: rstudio/shiny-workflows/.github/workflows/R-CMD-check.yaml@v1

.github/workflows/pr-commands.yaml

@@ -1,35 +0,0 @@
-on:
-  issue_comment:
-    types: [created]
-name: Commands
-jobs:
-  document:
-    if: startsWith(github.event.comment.body, '/document')
-    name: document
-    runs-on: macOS-latest
-    env:
-      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
-    steps:
-      - uses: actions/checkout@v2
-      - uses: r-lib/actions/pr-fetch@master
-        with:
-          repo-token: ${{ secrets.GITHUB_TOKEN }}
-      - uses: r-lib/actions/setup-r@master
-      - name: Install dependencies
-        run: Rscript -e 'install.packages(c("remotes", "roxygen2"))' -e 'remotes::install_deps(dependencies = TRUE)'
-      - name: Document
-        run: Rscript -e 'roxygen2::roxygenise()'
-      - name: commit
-        run: |
-          git add man/\* NAMESPACE
-          git commit -m 'Document'
-      - uses: r-lib/actions/pr-push@master
-        with:
-          repo-token: ${{ secrets.GITHUB_TOKEN }}
-
-  # added so that the workflow doesn't fail.
-  always_runner:
-    runs-on: ubuntu-latest
-    steps:
-      - name: Always run
-        run: echo "This job is used to prevent the workflow status from showing as failed when all other jobs are skipped"

.gitignore

@@ -10,3 +10,19 @@ shinyapps/
 README.html
 .*.Rnb.cached
 tools/yarn-error.log
+
+# TypeScript / yarn
+/node_modules/
+.cache
+.yarn/*
+!.yarn/releases
+!.yarn/plugins
+!.yarn/sdks
+!.yarn/versions
+.pnp.*
+coverage/
+madge.svg
+
+
+# GHA remotes installation
+.github/r-depends.rds

.madgerc

@@ -0,0 +1,7 @@
+{
+  "detectiveOptions": {
+    "ts": {
+      "skipTypeImports": true
+    }
+  }
+}

.vscode/extensions.json

@@ -0,0 +1,7 @@
+{
+  "recommendations": [
+    "arcanis.vscode-zipfs",
+    "dbaeumer.vscode-eslint",
+    "esbenp.prettier-vscode"
+  ]
+}

.vscode/settings.json

@@ -0,0 +1,18 @@
+{
+  "search.exclude": {
+    "**/.yarn": true,
+    "**/.pnp.*": true
+  },
+  "prettier.prettierPath": "./node_modules/prettier",
+  "typescript.enablePromptUseWorkspaceTsdk": true,
+  "[r]": {
+    "files.trimTrailingWhitespace": true,
+    "files.insertFinalNewline": true,
+  },
+  "[typescript]": {
+    "editor.defaultFormatter": "esbenp.prettier-vscode",
+    "editor.formatOnSave": true,
+    "files.trimTrailingWhitespace": true,
+    "files.insertFinalNewline": true,
+  },
+}

.yarnrc.yml

@@ -0,0 +1,10 @@
+nodeLinker: node-modules
+
+plugins:
+  - path: .yarn/plugins/@yarnpkg/plugin-outdated.cjs
+    spec: "https://github.com/mskelton/yarn-plugin-outdated/raw/main/bundles/@yarnpkg/plugin-outdated.js"
+  - path: .yarn/plugins/@yarnpkg/plugin-interactive-tools.cjs
+    spec: "@yarnpkg/plugin-interactive-tools"
+
+yarnPath: .yarn/releases/yarn-3.2.3.cjs
+checksumBehavior: update

DESCRIPTION

@@ -1,14 +1,19 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.5.0
+Version: 1.8.1.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("Yihui", "Xie", role = "aut", email = "yihui@rstudio.com"),
-    person("Jonathan", "McPherson", role = "aut", email = "jonathan@rstudio.com"),
-    person(family = "RStudio", role = "cph"),
+    person("Winston", "Chang", role = c("aut", "cre"), email = "winston@posit.co", comment = c(ORCID = "0000-0002-1576-2126")),
+    person("Joe", "Cheng", role = "aut", email = "joe@posit.co"),
+    person("JJ", "Allaire", role = "aut", email = "jj@posit.co"),
+    person("Carson", "Sievert", role = "aut", email = "carson@posit.co", comment = c(ORCID = "0000-0002-4958-2844")),
+    person("Barret", "Schloerke", role = "aut", email = "barret@posit.co", comment = c(ORCID = "0000-0001-9986-114X")),
+    person("Yihui", "Xie", role = "aut", email = "yihui@posit.co"),
+    person("Jeff", "Allen", role = "aut"),
+    person("Jonathan", "McPherson", role = "aut", email = "jonathan@posit.co"),
+    person("Alan", "Dipert", role = "aut"),
+    person("Barbara", "Borges", role = "aut"),
+    person("Posit Software, PBC", role = c("cph", "fnd")),
     person(family = "jQuery Foundation", role = "cph",
     comment = "jQuery library and jQuery UI library"),
     person(family = "jQuery contributors", role = c("ctb", "cph"),
@@ -23,22 +28,26 @@ 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"),
     comment = "Bootstrap-datepicker library"),
-    person("Dave", "Gandy", role = c("ctb", "cph"),
-    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"),
@@ -69,64 +78,68 @@ Imports:
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
-    digest,
-    htmltools (>= 0.4.0.9003),
+    fontawesome (>= 0.4.0),
+    htmltools (>= 0.5.4),
     R6 (>= 2.0),
     sourcetools,
     later (>= 1.0.0),
     promises (>= 1.1.0),
     tools,
     crayon,
-    rlang (>= 0.4.0),
-    fastmap (>= 1.0.0),
+    rlang (>= 0.4.10),
+    fastmap (>= 1.1.1),
     withr,
     commonmark (>= 1.7),
-    glue (>= 1.3.2)
+    glue (>= 1.3.2),
+    bslib (>= 0.3.0),
+    cachem,
+    lifecycle (>= 0.2.0)
 Suggests:
     datasets,
+    DT,
     Cairo (>= 1.5-5),
-    testthat (>= 2.1.1),
+    testthat (>= 3.0.0),
     knitr (>= 1.6),
     markdown,
     rmarkdown,
     ggplot2,
     reactlog (>= 1.0.0),
     magrittr,
-    shinytest,
     yaml,
     future,
     dygraphs,
     ragg,
-    showtext
-URL: http://shiny.rstudio.com
+    showtext,
+    sass
+URL: https://shiny.posit.co/,
+    https://github.com/rstudio/shiny
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
-    'app.R'
+    'globals.R'
+    'app-state.R'
     'app_template.R'
+    'bind-cache.R'
+    'bind-event.R'
     'bookmark-state-local.R'
-    'stack.R'
     'bookmark-state.R'
     'bootstrap-deprecated.R'
     'bootstrap-layout.R'
-    'globals.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'
+    'extended-task.R'
     'fileupload.R'
-    'font-awesome.R'
     'graph.R'
     'reactives.R'
     'reactive-domains.R'
     'history.R'
     'hooks.R'
     'html-deps.R'
-    'htmltools.R'
     'image-interact-opts.R'
     'image-interact.R'
     'imageutils.R'
@@ -148,6 +161,7 @@ Collate:
     'insert-tab.R'
     'insert-ui.R'
     'jqueryui.R'
+    'knitr.R'
     'middleware-shiny.R'
     'middleware.R'
     'timer.R'
@@ -164,19 +178,36 @@ Collate:
     '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-package.R'
+    'shinyapp.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
     'snapshot.R'
+    'staticimports.R'
     'tar.R'
     'test-export.R'
     'test-server.R'
     'test.R'
     'update-input.R'
-RoxygenNote: 7.1.0.9000
+    'utils-lang.R'
+    'version_bs_date_picker.R'
+    'version_ion_range_slider.R'
+    'version_jquery.R'
+    'version_jqueryui.R'
+    'version_selectize.R'
+    'version_strftime.R'
+    'viewer.R'
+RoxygenNote: 7.3.1
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
+RdMacros: lifecycle
+Config/testthat/edition: 3
+Config/Needs/check:
+  shinytest2

LICENSE

@@ -8,12 +8,10 @@ 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
@@ -72,399 +70,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
@@ -673,449 +307,6 @@ bootstrap-datepicker
    limitations under the License.
 
 
-Font Awesome (CSS files are MIT licensed; fonts have SIL Open Font License 1.1, svgs have CC BY 4.0 License)
-----------------------------------------------------------------------
-
-The MIT License (MIT)
-
-Copyright (c) 2014 Dave Gandy
-
-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, Dave Gandy http://fontawesome.io/,
-with Reserved Font Name Font Awesome.
-
-This Font Software is licensed under the SIL Open Font License, Version 1.1.
-This license is copied below, and is also available with a FAQ at:
-http://scripts.sil.org/OFL
-
-
------------------------------------------------------------
-SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
------------------------------------------------------------
-
-PREAMBLE
-The goals of the Open Font License (OFL) are to stimulate worldwide
-development of collaborative font projects, to support the font creation
-efforts of academic and linguistic communities, and to provide a free and
-open framework in which fonts may be shared and improved in partnership
-with others.
-
-The OFL allows the licensed fonts to be used, studied, modified and
-redistributed freely as long as they are not sold by themselves. The
-fonts, including any derivative works, can be bundled, embedded,
-redistributed and/or sold with any software provided that any reserved
-names are not used by derivative works. The fonts and derivatives,
-however, cannot be released under any other type of license. The
-requirement for fonts to remain under this license does not apply
-to any document created using the fonts or their derivatives.
-
-DEFINITIONS
-"Font Software" refers to the set of files released by the Copyright
-Holder(s) under this license and clearly marked as such. This may
-include source files, build scripts and documentation.
-
-"Reserved Font Name" refers to any names specified as such after the
-copyright statement(s).
-
-"Original Version" refers to the collection of Font Software components as
-distributed by the Copyright Holder(s).
-
-"Modified Version" refers to any derivative made by adding to, deleting,
-or substituting -- in part or in whole -- any of the components of the
-Original Version, by changing formats or by porting the Font Software to a
-new environment.
-
-"Author" refers to any designer, engineer, programmer, technical
-writer or other person who contributed to the Font Software.
-
-PERMISSION & CONDITIONS
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of the Font Software, to use, study, copy, merge, embed, modify,
-redistribute, and sell modified and unmodified copies of the Font
-Software, subject to the following conditions:
-
-1) Neither the Font Software nor any of its individual components,
-in Original or Modified Versions, may be sold by itself.
-
-2) Original or Modified Versions of the Font Software may be bundled,
-redistributed and/or sold with any software, provided that each copy
-contains the above copyright notice and this license. These can be
-included either as stand-alone text files, human-readable headers or
-in the appropriate machine-readable metadata fields within text or
-binary files as long as those fields can be easily viewed by the user.
-
-3) No Modified Version of the Font Software may use the Reserved Font
-Name(s) unless explicit written permission is granted by the corresponding
-Copyright Holder. This restriction only applies to the primary font name as
-presented to the users.
-
-4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
-Software shall not be used to promote, endorse or advertise any
-Modified Version, except to acknowledge the contribution(s) of the
-Copyright Holder(s) and the Author(s) or with their explicit written
-permission.
-
-5) The Font Software, modified or unmodified, in part or in whole,
-must be distributed entirely under this license, and must not be
-distributed under any other license. The requirement for fonts to
-remain under this license does not apply to any document created
-using the Font Software.
-
-TERMINATION
-This license becomes null and void if any of the above conditions are
-not met.
-
-DISCLAIMER
-THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
-OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
-COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
-DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
-OTHER DEALINGS IN THE FONT SOFTWARE.
-
-=======================================================================
-
-Creative Commons Attribution 4.0 International Public License
-
-By exercising the Licensed Rights (defined below), You accept and agree
-to be bound by the terms and conditions of this Creative Commons
-Attribution 4.0 International Public License ("Public License"). To the
-extent this Public License may be interpreted as a contract, You are
-granted the Licensed Rights in consideration of Your acceptance of
-these terms and conditions, and the Licensor grants You such rights in
-consideration of benefits the Licensor receives from making the
-Licensed Material available under these terms and conditions.
-
-
-Section 1 -- Definitions.
-
-  a. Adapted Material means material subject to Copyright and Similar
-     Rights that is derived from or based upon the Licensed Material
-     and in which the Licensed Material is translated, altered,
-     arranged, transformed, or otherwise modified in a manner requiring
-     permission under the Copyright and Similar Rights held by the
-     Licensor. For purposes of this Public License, where the Licensed
-     Material is a musical work, performance, or sound recording,
-     Adapted Material is always produced where the Licensed Material is
-     synched in timed relation with a moving image.
-
-  b. Adapter's License means the license You apply to Your Copyright
-     and Similar Rights in Your contributions to Adapted Material in
-     accordance with the terms and conditions of this Public License.
-
-  c. Copyright and Similar Rights means copyright and/or similar rights
-     closely related to copyright including, without limitation,
-     performance, broadcast, sound recording, and Sui Generis Database
-     Rights, without regard to how the rights are labeled or
-     categorized. For purposes of this Public License, the rights
-     specified in Section 2(b)(1)-(2) are not Copyright and Similar
-     Rights.
-
-  d. Effective Technological Measures means those measures that, in the
-     absence of proper authority, may not be circumvented under laws
-     fulfilling obligations under Article 11 of the WIPO Copyright
-     Treaty adopted on December 20, 1996, and/or similar international
-     agreements.
-
-  e. Exceptions and Limitations means fair use, fair dealing, and/or
-     any other exception or limitation to Copyright and Similar Rights
-     that applies to Your use of the Licensed Material.
-
-  f. Licensed Material means the artistic or literary work, database,
-     or other material to which the Licensor applied this Public
-     License.
-
-  g. Licensed Rights means the rights granted to You subject to the
-     terms and conditions of this Public License, which are limited to
-     all Copyright and Similar Rights that apply to Your use of the
-     Licensed Material and that the Licensor has authority to license.
-
-  h. Licensor means the individual(s) or entity(ies) granting rights
-     under this Public License.
-
-  i. Share means to provide material to the public by any means or
-     process that requires permission under the Licensed Rights, such
-     as reproduction, public display, public performance, distribution,
-     dissemination, communication, or importation, and to make material
-     available to the public including in ways that members of the
-     public may access the material from a place and at a time
-     individually chosen by them.
-
-  j. Sui Generis Database Rights means rights other than copyright
-     resulting from Directive 96/9/EC of the European Parliament and of
-     the Council of 11 March 1996 on the legal protection of databases,
-     as amended and/or succeeded, as well as other essentially
-     equivalent rights anywhere in the world.
-
-  k. You means the individual or entity exercising the Licensed Rights
-     under this Public License. Your has a corresponding meaning.
-
-
-Section 2 -- Scope.
-
-  a. License grant.
-
-       1. Subject to the terms and conditions of this Public License,
-          the Licensor hereby grants You a worldwide, royalty-free,
-          non-sublicensable, non-exclusive, irrevocable license to
-          exercise the Licensed Rights in the Licensed Material to:
-
-            a. reproduce and Share the Licensed Material, in whole or
-               in part; and
-
-            b. produce, reproduce, and Share Adapted Material.
-
-       2. Exceptions and Limitations. For the avoidance of doubt, where
-          Exceptions and Limitations apply to Your use, this Public
-          License does not apply, and You do not need to comply with
-          its terms and conditions.
-
-       3. Term. The term of this Public License is specified in Section
-          6(a).
-
-       4. Media and formats; technical modifications allowed. The
-          Licensor authorizes You to exercise the Licensed Rights in
-          all media and formats whether now known or hereafter created,
-          and to make technical modifications necessary to do so. The
-          Licensor waives and/or agrees not to assert any right or
-          authority to forbid You from making technical modifications
-          necessary to exercise the Licensed Rights, including
-          technical modifications necessary to circumvent Effective
-          Technological Measures. For purposes of this Public License,
-          simply making modifications authorized by this Section 2(a)
-          (4) never produces Adapted Material.
-
-       5. Downstream recipients.
-
-            a. Offer from the Licensor -- Licensed Material. Every
-               recipient of the Licensed Material automatically
-               receives an offer from the Licensor to exercise the
-               Licensed Rights under the terms and conditions of this
-               Public License.
-
-            b. No downstream restrictions. You may not offer or impose
-               any additional or different terms or conditions on, or
-               apply any Effective Technological Measures to, the
-               Licensed Material if doing so restricts exercise of the
-               Licensed Rights by any recipient of the Licensed
-               Material.
-
-       6. No endorsement. Nothing in this Public License constitutes or
-          may be construed as permission to assert or imply that You
-          are, or that Your use of the Licensed Material is, connected
-          with, or sponsored, endorsed, or granted official status by,
-          the Licensor or others designated to receive attribution as
-          provided in Section 3(a)(1)(A)(i).
-
-  b. Other rights.
-
-       1. Moral rights, such as the right of integrity, are not
-          licensed under this Public License, nor are publicity,
-          privacy, and/or other similar personality rights; however, to
-          the extent possible, the Licensor waives and/or agrees not to
-          assert any such rights held by the Licensor to the limited
-          extent necessary to allow You to exercise the Licensed
-          Rights, but not otherwise.
-
-       2. Patent and trademark rights are not licensed under this
-          Public License.
-
-       3. To the extent possible, the Licensor waives any right to
-          collect royalties from You for the exercise of the Licensed
-          Rights, whether directly or through a collecting society
-          under any voluntary or waivable statutory or compulsory
-          licensing scheme. In all other cases the Licensor expressly
-          reserves any right to collect such royalties.
-
-
-Section 3 -- License Conditions.
-
-Your exercise of the Licensed Rights is expressly made subject to the
-following conditions.
-
-  a. Attribution.
-
-       1. If You Share the Licensed Material (including in modified
-          form), You must:
-
-            a. retain the following if it is supplied by the Licensor
-               with the Licensed Material:
-
-                 i. identification of the creator(s) of the Licensed
-                    Material and any others designated to receive
-                    attribution, in any reasonable manner requested by
-                    the Licensor (including by pseudonym if
-                    designated);
-
-                ii. a copyright notice;
-
-               iii. a notice that refers to this Public License;
-
-                iv. a notice that refers to the disclaimer of
-                    warranties;
-
-                 v. a URI or hyperlink to the Licensed Material to the
-                    extent reasonably practicable;
-
-            b. indicate if You modified the Licensed Material and
-               retain an indication of any previous modifications; and
-
-            c. indicate the Licensed Material is licensed under this
-               Public License, and include the text of, or the URI or
-               hyperlink to, this Public License.
-
-       2. You may satisfy the conditions in Section 3(a)(1) in any
-          reasonable manner based on the medium, means, and context in
-          which You Share the Licensed Material. For example, it may be
-          reasonable to satisfy the conditions by providing a URI or
-          hyperlink to a resource that includes the required
-          information.
-
-       3. If requested by the Licensor, You must remove any of the
-          information required by Section 3(a)(1)(A) to the extent
-          reasonably practicable.
-
-       4. If You Share Adapted Material You produce, the Adapter's
-          License You apply must not prevent recipients of the Adapted
-          Material from complying with this Public License.
-
-
-Section 4 -- Sui Generis Database Rights.
-
-Where the Licensed Rights include Sui Generis Database Rights that
-apply to Your use of the Licensed Material:
-
-  a. for the avoidance of doubt, Section 2(a)(1) grants You the right
-     to extract, reuse, reproduce, and Share all or a substantial
-     portion of the contents of the database;
-
-  b. if You include all or a substantial portion of the database
-     contents in a database in which You have Sui Generis Database
-     Rights, then the database in which You have Sui Generis Database
-     Rights (but not its individual contents) is Adapted Material; and
-
-  c. You must comply with the conditions in Section 3(a) if You Share
-     all or a substantial portion of the contents of the database.
-
-For the avoidance of doubt, this Section 4 supplements and does not
-replace Your obligations under this Public License where the Licensed
-Rights include other Copyright and Similar Rights.
-
-
-Section 5 -- Disclaimer of Warranties and Limitation of Liability.
-
-  a. UNLESS OTHERWISE SEPARATELY UNDERTAKEN BY THE LICENSOR, TO THE
-     EXTENT POSSIBLE, THE LICENSOR OFFERS THE LICENSED MATERIAL AS-IS
-     AND AS-AVAILABLE, AND MAKES NO REPRESENTATIONS OR WARRANTIES OF
-     ANY KIND CONCERNING THE LICENSED MATERIAL, WHETHER EXPRESS,
-     IMPLIED, STATUTORY, OR OTHER. THIS INCLUDES, WITHOUT LIMITATION,
-     WARRANTIES OF TITLE, MERCHANTABILITY, FITNESS FOR A PARTICULAR
-     PURPOSE, NON-INFRINGEMENT, ABSENCE OF LATENT OR OTHER DEFECTS,
-     ACCURACY, OR THE PRESENCE OR ABSENCE OF ERRORS, WHETHER OR NOT
-     KNOWN OR DISCOVERABLE. WHERE DISCLAIMERS OF WARRANTIES ARE NOT
-     ALLOWED IN FULL OR IN PART, THIS DISCLAIMER MAY NOT APPLY TO YOU.
-
-  b. TO THE EXTENT POSSIBLE, IN NO EVENT WILL THE LICENSOR BE LIABLE
-     TO YOU ON ANY LEGAL THEORY (INCLUDING, WITHOUT LIMITATION,
-     NEGLIGENCE) OR OTHERWISE FOR ANY DIRECT, SPECIAL, INDIRECT,
-     INCIDENTAL, CONSEQUENTIAL, PUNITIVE, EXEMPLARY, OR OTHER LOSSES,
-     COSTS, EXPENSES, OR DAMAGES ARISING OUT OF THIS PUBLIC LICENSE OR
-     USE OF THE LICENSED MATERIAL, EVEN IF THE LICENSOR HAS BEEN
-     ADVISED OF THE POSSIBILITY OF SUCH LOSSES, COSTS, EXPENSES, OR
-     DAMAGES. WHERE A LIMITATION OF LIABILITY IS NOT ALLOWED IN FULL OR
-     IN PART, THIS LIMITATION MAY NOT APPLY TO YOU.
-
-  c. The disclaimer of warranties and limitation of liability provided
-     above shall be interpreted in a manner that, to the extent
-     possible, most closely approximates an absolute disclaimer and
-     waiver of all liability.
-
-
-Section 6 -- Term and Termination.
-
-  a. This Public License applies for the term of the Copyright and
-     Similar Rights licensed here. However, if You fail to comply with
-     this Public License, then Your rights under this Public License
-     terminate automatically.
-
-  b. Where Your right to use the Licensed Material has terminated under
-     Section 6(a), it reinstates:
-
-       1. automatically as of the date the violation is cured, provided
-          it is cured within 30 days of Your discovery of the
-          violation; or
-
-       2. upon express reinstatement by the Licensor.
-
-     For the avoidance of doubt, this Section 6(b) does not affect any
-     right the Licensor may have to seek remedies for Your violations
-     of this Public License.
-
-  c. For the avoidance of doubt, the Licensor may also offer the
-     Licensed Material under separate terms or conditions or stop
-     distributing the Licensed Material at any time; however, doing so
-     will not terminate this Public License.
-
-  d. Sections 1, 5, 6, 7, and 8 survive termination of this Public
-     License.
-
-
-Section 7 -- Other Terms and Conditions.
-
-  a. The Licensor shall not be bound by any additional or different
-     terms or conditions communicated by You unless expressly agreed.
-
-  b. Any arrangements, understandings, or agreements regarding the
-     Licensed Material not stated herein are separate from and
-     independent of the terms and conditions of this Public License.
-
-
-Section 8 -- Interpretation.
-
-  a. For the avoidance of doubt, this Public License does not, and
-     shall not be interpreted to, reduce, limit, restrict, or impose
-     conditions on any use of the Licensed Material that could lawfully
-     be made without permission under this Public License.
-
-  b. To the extent possible, if any provision of this Public License is
-     deemed unenforceable, it shall be automatically reformed to the
-     minimum extent necessary to make it enforceable. If the provision
-     cannot be reformed, it shall be severed from this Public License
-     without affecting the enforceability of the remaining terms and
-     conditions.
-
-  c. No term or condition of this Public License will be waived and no
-     failure to comply consented to unless expressly agreed to by the
-     Licensor.
-
-  d. Nothing in this Public License constitutes or may be interpreted
-     as a limitation upon, or waiver of, any privileges and immunities
-     that apply to the Licensor or You, including from the legal
-     processes of any jurisdiction or authority.
-
-
 selectize.js
 ----------------------------------------------------------------------
 
@@ -1322,30 +513,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

@@ -19,14 +19,32 @@ S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
 S3method("[[<-",shinyoutput)
 S3method("names<-",reactivevalues)
+S3method(as.list,Map)
 S3method(as.list,reactivevalues)
 S3method(as.shiny.appobj,character)
 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(length,Map)
 S3method(names,reactivevalues)
 S3method(print,reactive)
 S3method(print,reactivevalues)
@@ -37,6 +55,7 @@ S3method(str,reactivevalues)
 export("conditionStackTrace<-")
 export(..stacktraceoff..)
 export(..stacktraceon..)
+export(ExtendedTask)
 export(HTML)
 export(MockShinySession)
 export(NS)
@@ -50,6 +69,8 @@ export(animationOptions)
 export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
+export(bindCache)
+export(bindEvent)
 export(bookmarkButton)
 export(bootstrapLib)
 export(bootstrapPage)
@@ -73,6 +94,7 @@ export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
 export(debounce)
+export(devmode)
 export(dialogViewer)
 export(diskCache)
 export(div)
@@ -84,7 +106,6 @@ export(enableBookmarking)
 export(eventReactive)
 export(exportTestValues)
 export(exprToFunction)
-export(extractStackTrace)
 export(fileInput)
 export(fillCol)
 export(fillPage)
@@ -95,14 +116,15 @@ export(fixedRow)
 export(flowLayout)
 export(fluidPage)
 export(fluidRow)
-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)
@@ -116,9 +138,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)
@@ -167,6 +191,7 @@ export(onRestore)
 export(onRestored)
 export(onSessionEnded)
 export(onStop)
+export(onUnhandledError)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -179,16 +204,13 @@ export(pre)
 export(prependTab)
 export(printError)
 export(printStackTrace)
+export(quoToFunction)
 export(radioButtons)
 export(reactive)
+export(reactiveConsole)
 export(reactiveFileReader)
-export(reactivePlot)
 export(reactivePoll)
-export(reactivePrint)
-export(reactiveTable)
-export(reactiveText)
 export(reactiveTimer)
-export(reactiveUI)
 export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
@@ -196,6 +218,8 @@ export(reactlog)
 export(reactlogReset)
 export(reactlogShow)
 export(registerInputHandler)
+export(registerThemeDependency)
+export(register_devmode_option)
 export(removeInputHandler)
 export(removeModal)
 export(removeNotification)
@@ -238,7 +262,6 @@ export(shinyUI)
 export(showBookmarkUrlModal)
 export(showModal)
 export(showNotification)
-export(showReactLog)
 export(showTab)
 export(sidebarLayout)
 export(sidebarPanel)
@@ -306,8 +329,8 @@ export(withMathJax)
 export(withProgress)
 export(withReactiveDomain)
 export(withTags)
+export(with_devmode)
 import(R6)
-import(digest)
 import(htmltools)
 import(httpuv)
 import(methods)
@@ -356,5 +379,46 @@ importFrom(htmltools,tagSetChildren)
 importFrom(htmltools,tags)
 importFrom(htmltools,validateCssUnit)
 importFrom(htmltools,withTags)
+importFrom(lifecycle,deprecated)
+importFrom(lifecycle,is_present)
 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,"fn_body<-")
+importFrom(rlang,"fn_fmls<-")
+importFrom(rlang,as_function)
+importFrom(rlang,as_quosure)
+importFrom(rlang,check_dots_empty)
+importFrom(rlang,check_dots_unnamed)
+importFrom(rlang,enexpr)
+importFrom(rlang,enquo)
+importFrom(rlang,enquo0)
+importFrom(rlang,enquos)
+importFrom(rlang,enquos0)
+importFrom(rlang,eval_tidy)
+importFrom(rlang,expr)
+importFrom(rlang,fn_body)
+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,list2)
+importFrom(rlang,maybe_missing)
+importFrom(rlang,missing_arg)
+importFrom(rlang,new_function)
+importFrom(rlang,new_quosure)
+importFrom(rlang,pairlist2)
+importFrom(rlang,quo)
+importFrom(rlang,quo_get_expr)
+importFrom(rlang,quo_is_missing)
+importFrom(rlang,quo_set_env)
+importFrom(rlang,quo_set_expr)
+importFrom(rlang,zap_srcref)

NEWS.md

@@ -1,5 +1,359 @@
-shiny 1.5.0
-===========
+# shiny (development version)
+
+## Bug fixes
+
+* Fixed a recent issue with `uiOutput()` and `conditionalPanel()` not properly lower opacity when recalculation (in a Bootstrap 5 context). (#4027)
+
+# shiny 1.8.1.1
+
+* In v1.8.1, shiny.js starting throwing an error when input/output bindings have duplicate IDs. This error is now only thrown when `shiny::devmode(TRUE)` is enabled, so the issue is still made discoverable through the JS error console, but avoids unnecessarily breaking apps that happen to work with duplicate IDs. (#4019)
+
+# shiny 1.8.1
+
+## New features and improvements
+
+* Added `ExtendedTask`, a new simple way to launch long-running asynchronous tasks that are truly non-blocking. That is, even _within_ a session, an `ExtendedTask` won't block the main thread from flushing the reactive graph (i.e., UI updates won't be blocked). `ExtendedTask` pairs nicely with new `bslib::input_task_button()` and `bslib::bind_task_button()` functions, which help give user feedback and prevent extra button clicks. (#3958)
+
+* Added a JavaScript error dialog, reporting errors that previously were only discoverable by opening the browser's devtools open. Since this dialog is mainly useful for debugging and development, it must be enabled with `shiny::devmode()`. (#3931)
+
+* `runExamples()` now uses the `{bslib}` package to generate a better looking result. It also gains a `package` argument so that other packages can leverage this same function to run Shiny app examples. For more, see `?runExamples`. (#3963, #4005)
+
+* Added `onUnhandledError()` to register a function that will be called when an unhandled error occurs in a Shiny app. Note that this handler doesn't stop the error or prevent the session from closing, but it can be used to log the error or to clean up session-specific resources. (thanks @JohnCoene, #3993)
+
+## Changes
+
+* `renderDataTable()`/`dataTableOutput()` are officially deprecated in favor of [their `{DT}` equivalents](https://rstudio.github.io/DT/shiny.html). Migrating to `{DT}`, in most cases, just requires changing `renderDataTable()` to `DT::renderDT()` and `dataTableOutput()` to `DT::DTOutput()`. Also, to promote migration, when a recent version of `{DT}` is available, `renderDataTable()`/`dataTableOutput()` now automatically use their `{DT}` equivalent (and provide a message that they are doing so). If this happens to degrade an existing app, set `options(shiny.legacy.datatable = TRUE)` to get the old (i.e., non-`{DT}`) implementation. (#3998)
+
+* Both `conditionalPanel()` and `uiOutput()` are now styled with `display: contents` by default in Shiny apps that use Bootstrap 5. This means that the elements they contain are positioned as if they were direct children of the parent container holding the `conditionalPanel()` or `uiOutput()`. This is probably what most users intend when they use these functions, but it may break apps that applied styles directly to the container elements created by these two functions. In that case, you may include CSS rules to set `display: block` for the `.shiny-panel-conditional` or `.shiny-html-output` classes. (#3957, #3960)
+
+## Bug fixes
+
+* Notifications are now constrained to the width of the viewport for window widths smaller the default notification panel size. (#3949)
+
+* Fixed #2392: `downloadButton()` now visibly returns its HTML tag so that it renders correctly in R Markdown and Quarto output. (Thanks to @fennovj, #2672)
+
+* Calling `updateSelectizeInput()` with `choices` and `selected` now clears the current selection before updating the choices and selected value. (#3967)
+
+* Loading a Shiny app in a package-like directory will no longer warn if autoloading is disabled by the presence of an `R/_disable_autoload.R` file. (Thanks to @krlmlr and @tanho63, #3513)
+
+# shiny 1.8.0
+
+## Breaking changes
+
+* Closed #3899: The JS function `Shiny.bindAll()` is now asynchronous. This change is driven by the recent push toward making dynamic UI rendering asynchronous, which is necessary for [shinylive](https://shinylive.io/r) (and should've happened when it was first introduced in Shiny v1.7.5). The vast majority of existing `Shiny.bindAll()` uses should continue to work as before, but some cases may break if downstream code relies on it being synchronous (i.e., blocking the main thread). In this case, consider placing any downstream code in a `.then()` callback (or `await` the result in a `async` function). (#3929)
+  * Since `renderContent()` calls `bindAll()` (after it inserts content), it now returns a `Promise<void>` instead of `void`, which can be useful if downstream code needs to wait for the binding to complete.
+
+## New features and improvements
+
+* Updated `selectizeInput()`'s selectize.js dependency from v0.12.4 to v0.15.2. In addition to many bug fixes and improvements, this update also adds several new [plugin options](https://selectize.dev/docs/demos/plugins). (#3875)
+
+* Shiny's CSS styling (for things like `showNotification()`, `withProgress()`, `inputPanel()`, etc.), has been updated with `{bslib}`'s upcoming CSS-only dark mode feature in mind. (#3882, #3914)
+
+* Default styles for `showNotification()` were tweaked slightly to improve accessibility, sizing, and padding. (#3913)
+
+* Shiny inputs and `{htmlwidgets}` are no longer treated as draggable inside of `absolutePanel()`/`fixedPanel()` with `draggable = TRUE`. As a result, interactions like zooming and panning now work as expected with widgets like `{plotly}` and `{leaflet}` when they appear in a draggable panel. (#3752, #3933)
+
+* For `InputBinding`s, the `.receiveMessage()` method can now be asynchronous or synchronous (previously it could only be synchronous). (#3930)
+
+## Bug fixes
+
+* `fileInput()` no longer has unwanted round corners applied to the `buttonLabel`. (#3879)
+
+* Fixed #3898: `wrapFunctionLabel()` no longer throws an error if the `name` is longer than 10000 bytes. (#3903)
+
+# shiny 1.7.5.1
+
+## Bug fixes
+
+* On r-devel (R > 4.3.1), `isTruthy(NULL)` now returns `FALSE` (as it does with older versions of R). (#3906)
+
+# shiny 1.7.5
+
+## Possibly breaking changes
+
+* For `reactiveValues()` objects, whenever the `$names()` or `$values()` methods are called, the keys are now returned in the order that they were inserted. (#3774)
+
+* The value provided to `options(shiny.json.digits)` is now interpreted as number of _digits after the decimal_ instead of _significant digits_. To treat the value as significant digits, wrap it in `I()` (e.g., `options(shiny.json.digits = I(4))`). This new default behavior not only helps with reducing digits in testing snapshots, but is also more consistent with `{jsonlite}`'s default behavior. (#3819)
+
+## New features and improvements
+
+* Closed #789: Dynamic UI is now rendered asynchronously, thanks in part to the newly exported `Shiny.renderDependenciesAsync()`, `Shiny.renderHtmlAsync()`, and `Shiny.renderContentAsync()`. Importantly, this means `<script>` tags are now loaded asynchronously (the old way used `XMLHttpRequest`, which is synchronous). In addition, `Shiny` now manages a queue of async tasks (exposed via `Shiny.shinyapp.taskQueue`) so that order of execution is preserved. (#3666)
+
+* Fixes #3840: `updateSliderInput()` now warns when attempting to set invalid `min`, `max`, or `value` values. Sending an invalid update message to an input no longer causes other update messages to fail. (#3843)
+
+* `sliderInput()` now has a larger target area for clicking or tapping on the slider handle or range. (#3859)
+
+* Closed #2956: Component authors can now prevent Shiny from creating an input binding on specific elements by adding the `data-shiny-no-bind-input` attribute to the element. The attribute may have any or no value; its presence will prevent binding. This feature is primarily useful for input component authors who want to use standard HTML input elements without causing Shiny to create an input binding for them. Additionally, Shiny now adds custom classes to its inputs. For example, `checkboxInput()` now has a `shiny-input-checkbox` class. These custom classes may be utilized in future updates to Shiny's input binding logic. (#3861)
+
+* `Map` objects are now initialized at load time instead of build time. This avoids potential problems that could arise from storing `fastmap` objects into the built Shiny package. (#3775)
+
+## Bug fixes
+
+* Fixed #3771: Sometimes the error `ion.rangeSlider.min.js: i.stopPropagation is not a function` would appear in the JavaScript console. (#3772)
+
+* Fixed #3833: When `width` is provided to `textAreaInput()`, we now correctly set the width of the `<textarea>` element. (#3838)
+
+
+# shiny 1.7.4.1
+
+## Full changelog
+
+* Closed #3849: In R-devel, a warning was raised when Shiny was loaded because `as.numeric_version()` was called with a number instead of a string. (#3850)
+
+
+# shiny 1.7.4
+
+## Full changelog
+
+### Breaking changes
+
+* Closed #3719: Output container sizes, which are available via [`session$clientData` and `getCurrentOutputInfo()`](https://shiny.rstudio.com/articles/client-data.html), no longer round to the nearest pixel (i.e., they are now more exact, possibly fractional values). (#3720)
+
+* Closed #3704, #3735, and #3740: `renderPlot()` no longer generates an error (or segfault) when it executes before the output is visible. Instead, it'll now use the graphics device's default size for it's initial size. Relatedly, `plotPNG()` now ignores `NULL` values for `width`/`height` (and uses the device's default `width`/`height` instead). (#3739)
+
+### New features and improvements
+
+* `plotOutput()`, `imageOutput()`, and `uiOutput()` gain a `fill` argument. If `TRUE` (the default for `plotOutput()`), the output container is allowed to grow/shrink to fit a fill container (created via `htmltools::bindFillRole()`) with an opinionated height. This means `plotOutput()` will grow/shrink by default [inside of `bslib::card_body_fill()`](https://rstudio.github.io/bslib/articles/cards.html#responsive-sizing), but `imageOutput()` and `uiOutput()` will have to opt-in to similar behavior with `fill = TRUE`. (#3715)
+
+* Closed #3687: Updated jQuery-UI to v1.13.2. (#3697)
+
+* Internal: Added clearer and strict TypeScript type definitions (#3644)
+
+
+# shiny 1.7.3
+
+### Bug fixes
+
+* Shiny 1.7.0 changed the `icon(lib="fontawesome")` implementation from a bundled copy of fontawesome, to the {fontawesome} package. This led to issue #3688, where icons that were previously working, were now breaking. That's because {fontawesome} 0.3.0 and earlier did not have support for icon names used in Font Awesome 5 and earlier, only the newest icon names used in Font Awesome 6. Now, {fontawesome} 0.4.0 has restored support for those older icon names, and Shiny 1.7.2.1 has updated its {fontawesome} requirement to >=0.4.0.
+
+
+# shiny 1.7.2
+
+## Full changelog
+
+### Breaking changes
+
+* Closed #3626: `renderPlot()` (and `plotPNG()`) now uses `ragg::agg_png()` by default when the [`{ragg}` package](https://github.com/r-lib/ragg) is installed. To restore the previous behavior, set `options(shiny.useragg = FALSE)`. (#3654)
+
+### New features and improvements
+
+* Closed #1545: `insertUI()` now executes `<script>` tags. (#3630)
+
+* `fileInput()` can set the `capture` attribute to facilitates user access to a device's media capture mechanism, such as a camera, or microphone, from within a file upload control ([W3C HTML Media Capture](https://www.w3.org/TR/html-media-capture/)). (Thanks to khaled-alshamaa, #3481)
+
+* Closed tidyverse/dplyr#5552: Compatibility of dplyr 1.0 (and rlang chained errors in general) with `req()`, `validate()`, and friends.
+
+* Closed tidyverse/dplyr#6154: Values from an `actionButton()` had S3 classes in the incorrect order.
+
+* Closed #3346: Default for `ref` input in `runGithub()` changed from `"master"` to `"HEAD"`. (#3564)
+
+* Closed #3619: In R 4.2, `splitLayout()` no longer raises warnings about incorrect length in an `if` statement. (Thanks to @dmenne, #3625)
+
+### Bug fixes
+
+* Closed #3250:`{rlang}`/`{tidyeval}` conditions (i.e., warnings and errors) are no longer filtered from stack traces. (#3602)
+
+* Closed #3581: Errors in throttled/debounced reactive expressions no longer cause the session to exit. (#3624)
+
+* Closed #3657: `throttle.ts` and the `Throttler` typescript objects it provides now function as intended. (Thanks gto @dvg-p4, #3659)
+
+* The auto-reload feature (`options(shiny.autoreload=TRUE)`) was not being activated by `devmode(TRUE)`, despite a console message asserting that it was. (#3620)
+
+* Closed #2297: If an error occurred in parsing a value in a bookmark query string, an error would be thrown and nothing would be restored. Now a message is displayed and that value is ignored. (Thanks to @daattali, #3385)
+
+* Restored the previous behavior of automatically guessing the `Content-Type` header for `downloadHandler` functions when no explicit `contentType` argument is supplied. (#3393)
+
+* Previously, updating an input value without a corresponding Input binding element did not trigger a JavaScript `shiny:inputchanged` event. Now, if no Input binding element is found, the `shiny:inputchanged` event is triggered on `window.document`. (#3584)
+
+* Closed #2955: Input and output bindings previously attempted to use `el['data-input-id']`, but that never worked. They now use `el.getAttribute('data-input-id')` instead. (#3538)
+
+### Minor improvements
+
+* When taking a test snapshot, the sort order of the json keys of the `input`, `output`, and `export` fields is currently sorted using the locale of the machine. This can lead to inconsistent test snapshot results. To opt-in to a consistent ordering of snapshot fields with `{shinytest}`, please set the global option `options(shiny.snapshotsortc = TRUE)`. `{shinytest2}` users do not need to set this value. (#3515)
+
+* Closed rstudio/shinytest2#222: When restoring a context (i.e., bookmarking) from a URL, Shiny now better handles a trailing `=` after `_inputs_` and `_values_`. (#3648)
+
+* Shiny's internal HTML dependencies are now mounted dynamically instead of statically. (#3537)
+
+* HTML dependencies that are sent to dynamic UI now have better type checking, and no longer require a `dep.src.href` field. (#3537)
+
+
+# shiny 1.7.1
+
+## Bug Fixes
+
+* Closed #3516: Fix regression in repeated calls to `appendTab()` when `navbarMenu()` is already present within a `tabsetPanel()`/`navbarPage()`. (#3518)
+
+* Re-arranged conditions for testthat 1.0.0 compatibility. (#3512)
+
+
+# shiny 1.7.0
+
+## Full changelog
+
+### Breaking changes
+
+* The `format` and `locale` arguments to `sliderInput()` have been removed. They have been deprecated since 0.10.2.2 (released on 2014-12-08).
+
+* Closed #3403: `insertTab()`'s `position` parameter now defaults to `"after"` instead of `"before"`. This has the benefit of allowing us to fix a bug in positioning when `target = NULL`, but has the drawback of changing the default behavior when `target` is not `NULL`. (#3404)
+
+### New features and improvements
+
+* Bootstrap 5 support. (#3410 and rstudio/bslib#304)
+  * As explained [here](https://rstudio.github.io/bslib/index.html#basic-usage), to opt-in to Bootstrap 5, provide `bslib::bs_theme(version = 5)` to a page layout function with a `theme` argument (e.g., `fluidPage()`, `navbarPage()`, etc).
+
+* Closed #3322, #3313, #1823, #3321, #3320, #1928, and #2310: Various improvements to `navbarPage()`, `tabsetPanel()`, `tabPanel()`, `navbarMenu()`, etc. Also, these functions are now powered by the `{bslib}` package's new `nav()` API (consider using `{bslib}`'s API to create better looking and more fully featured navs). (#3388)
+
+* All uses of `list(...)` have been replaced with `rlang::list2(...)`. This means that you can use trailing `,` without error and use rlang's `!!!` operator to "splice" a list of argument values into `...`. We think this'll be particularly useful for passing a list of `tabPanel()` to their consumers (i.e., `tabsetPanel()`, `navbarPage()`, etc). For example, `tabs <- list(tabPanel("A", "a"), tabPanel("B", "b")); navbarPage(!!!tabs)`. (#3315 and #3328)
+
+* `installExprFunction()` and `exprToFunction()` are now able to handle quosures when `quoted = TRUE`. So `render`-functions which call these functions (such as with `htmlwidgets`) can now understand quosures. Users can also use `rlang::inject()` to unquote a quosure for evaluation.  This also means that `render` function no longer need `env` and `quoted` parameters; that information can be embedded into a quosure which is then passed to the `render` function. Better documentation was added for how to create `render` functions. (#3472)
+
+* `icon(lib="fontawesome")` is now powered by the `{fontawesome}` package, which will make it easier to use the latest FA icons in the future (by updating the `{fontawesome}` package). (#3302)
+
+* Closed #3397: `renderPlot()` new uses `ggplot2::get_alt_text()` to inform an `alt` text default (for `{ggplot2}` plots). (#3398)
+
+* `modalDialog()` gains support for `size = "xl"`. (#3410)
+
+* Addressed #2521: Updated the list of TCP ports that will be rejected by default in runapp.R, adding 5060, 5061 and 6566. Added documentation describing the port range (3000:8000) and which ports are rejected. (#3456)
+
+### Other improvements
+
+* Shiny's core JavaScript code was converted to TypeScript. For the latest development information, please see the [README.md in `./srcts`](https://github.com/rstudio/shiny/tree/v1.7.0/srcts). (#3296)
+
+* Switched from `digest::digest()` to `rlang::hash()` for hashing. (#3264)
+
+* Switched from internal `Stack` class to `fastmap::faststack()`, and used `fastmap::fastqueue()`. (#3176)
+
+* Some long-deprecated functions and function parameters were removed. (#3137)
+
+### Bug fixes
+
+* Closed #3345: Shiny now correctly renders `htmltools::htmlDependency()`(s) with a `list()` of `script` attributes when used in a dynamic UI context. This fairly new `htmlDependency()` feature was added in `{htmltools}` v0.5.1. (#3395)
+
+* Fixed [#2666](https://github.com/rstudio/shiny/issues/2666) and [#2670](https://github.com/rstudio/shiny/issues/2670): `nearPoints()` and `brushedPoints()` weren't properly account for missing values (#2666 was introduced in v1.4.0). ([#2668](https://github.com/rstudio/shiny/pull/2668))
+
+* Closed #3374: `quoToFunction()` now works correctly with nested quosures; and as a result, quasi-quotation with rendering function (e.g., `renderPrint()`, `renderPlot()`, etc) now works as expected with nested quosures. (#3373)
+
+* Exported `register_devmode_option()`. This method was described in the documentation for `devmode()` but was never exported. See `?devmode()` for more details on how to register Shiny Developer options using `register_devmode_option()`. (#3364)
+
+* Closed #3484: In the RStudio IDE on Mac 11.5, selected checkboxes and radio buttons were not visible. (#3485)
+
+### Library updates
+
+* Closed #3286: Updated to Font-Awesome 5.15.2. (#3288)
+
+* Updated to jQuery 3.6.0. (#3311)
+
+# shiny 1.6.0
+
+This release focuses on improvements in three main areas:
+
+1. Better theming (and Bootstrap 4) support:
+  * The `theme` argument of `fluidPage()`, `navbarPage()`, and `bootstrapPage()` all now understand `bslib::bs_theme()` objects, which can be used to opt-into Bootstrap 4, use any Bootswatch theme, and/or implement custom themes without writing any CSS.
+  * The `session` object now includes `$setCurrentTheme()` and `$getCurrentTheme()` methods to dynamically update (or obtain) the page's `theme` after initial load, which is useful for things such as [adding a dark mode switch to an app](https://rstudio.github.io/bslib/articles/theming.html#dynamic) or some other "real-time" theming tool like `bslib::bs_themer()`.
+  * For more details, see [`{bslib}`'s website](https://rstudio.github.io/bslib/)
+
+2. Caching of `reactive()` and `render*()` (e.g. `renderText()`, `renderTable()`, etc) expressions.
+  * Such expressions automatically cache their _most recent value_, which helps to avoid redundant computation within a single "flush" of reactivity. The new `bindCache()` function can be used to cache _all previous values_ (as long as they fit in the cache). This cache may be optionally scoped within and/or across user sessions, possibly leading to huge performance gains, especially when deployed at scale across user sessions.
+  * For more details, see `help(bindCache, package = "shiny")`
+
+3. Various improvements to accessibility for screen-reader and keyboard users.
+  * For more details, see the accessibility section below.
+
+## Full changelog
+
+### Breaking changes
+
+* Closed #3074: Shiny no longer supports file uploads for Internet Explorer 8 or 9. (#3075)
+
+* Subtle changes, and some soft-deprecations, have come to `freezeReactiveValue` and `freezeReactiveVal` (#3055). These functions have been fragile at best in previous releases (issues #1791, #2463, #2946). In this release, we've solved all the problems we know about with `freezeReactiveValue(input, "x")`, by 1) invalidating `input$x` and set it to `NULL` whenever we freeze, and 2) ensuring that, after a freeze, even if the effect of `renderUI` or `updateXXXInput` is to set `input$x` to the same value it already has, this will result in an invalidation (whereas by default, Shiny filters out such spurious assignments).
+
+  Similar problems may exist when using `freezeReactiveVal`, and when using `freezeReactiveValue` with non-`input` reactive values objects. But support for those was added mostly for symmetry with `freezeReactiveValue(input)`, and given the above issues, it's not clear to us how you could have used these successfully in the past, or why you would even want to. For this release, we're soft-deprecating both of those uses, but we're more than willing to un-deprecate if it turns out people are using these; if that includes you, please join the conversation at https://github.com/rstudio/shiny/issues/3063. In the meantime, you can squelch the deprecation messages for these functions specifically, by setting `options(shiny.deprecation.messages.freeze = FALSE)`.
+
+### Accessibility
+
+* Added [bootstrap accessibility plugin](https://github.com/paypal/bootstrap-accessibility-plugin) under the hood to improve accessibility of shiny apps for screen-reader and keyboard users: the enhancements include better navigations for alert, tooltip, popover, modal dialog, dropdown, tab Panel, collapse, and carousel elements. (#2911)
+
+* Closed #2987: Improved accessibility of "live regions" -- namely, `*Output()` bindings and `update*Input()`. (#3042)
+
+* Added appropriate labels to `icon()` element to provide screen-reader users with alternative descriptions for the `fontawesome` and `glyphicon`: `aria-label` is automatically applied based on the fontawesome name. For example, `icon("calendar")` will be announced as "calendar icon" to screen readers. "presentation" aria role has also been attached to `icon()` to remove redundant semantic info for screen readers. (#2917)
+
+* Closed #2929: Fixed keyboard accessibility for file picker button: keyboard users can now tab to focus on `fileInput()` widget. (#2937)
+
+* Fixed #2951: screen readers correctly announce labels and date formats for `dateInput()` and `dateRangeInput()` widgets. (#2978)
+
+* Closed #2847: `selectInput()` is reasonably accessible for screen readers even when `selectize` option is set to TRUE. To improve `selectize.js` accessibility, we have added [selectize-plugin-a11y](https://github.com/SLMNBJ/selectize-plugin-a11y) by default. (#2993)
+
+* Closed #612: Added `alt` argument to `renderPlot()` and `renderCachedPlot()` to specify descriptive texts for `plotOutput()` objects, which is essential for screen readers. By default, alt text is set to the static text, "Plot object," but even dynamic text can be made with reactive function. (#3006, thanks @trafficonese and @leonawicz for the original PR and discussion via #2494)
+
+* Added semantic landmarks for `mainPanel()` and `sidebarPanel()` so that assistive technologies can recognize them as "main" and "complementary" region respectively. (#3009)
+
+* Closed #2844: Added `lang` argument to ui `*Page()` functions (e.g., `fluidPage`, `bootstrapPage`) that specifies document-level language within the app for the accessibility of screen readers and search-engine parsers. By default, it is set to empty string which is commonly recognized as a browser's default locale. (#2920)
+
+* Improved accessibility for `radioButtons()` and `checkboxGroupInput()`: All options are now grouped together semantically for assistive technologies. (thanks @jooyoungseo, #3187).
+
+### Minor new features and improvements
+
+* Added support for Shiny Developer Mode. 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. See `?devmode()` for more details. (#3174)
+
+* New `reactiveConsole()` makes it easier to interactively experiment with reactivity at the console (#2518).
+
+* When UI is specified as a function (e.g. `ui <- function(req) { ... }`), the response can now be an HTTP response as returned from the (newly exported) `httpResponse()` function. (#2970)
+
+* `selectInput` and `selectizeInput` now warn about performance implications when thousands of choices are used, and recommend [server-side selectize](https://shiny.rstudio.com/articles/selectize.html) be used instead. (#2959)
+
+* Closed #2980: `addResourcePath()` now allows paths with a leading `.` (thanks to @ColinFay). (#2981)
+
+* Closed #2972: `runExample()` now supports the `shiny.port` option (thanks to @ColinFay). (#2982)
+
+* Closed #2692: `downloadButton()` icon can now be changed via the `icon` parameter (thanks to @ColinFay). (#3010)
+
+* Closed #2984: improved documentation for `renderCachedPlot()` (thanks to @aalucaci). (#3016)
+
+* `reactiveValuesToList()` will save its `reactlog` label as `reactiveValuesToList(<ID>)` vs `as.list(<ID>)` (#3017)
+
+* Removed unused (and non-exported) `cacheContext` class.
+
+* `testServer()` can accept a single server function as input (#2965).
+
+* `shinyOptions()` now has session-level scoping, in addition to global and application-level scoping. (#3080)
+
+* `runApp()` now warns when running an application in an R package directory. (#3114)
+
+* Shiny now uses `cache_mem` from the cachem package, instead of `memoryCache` and `diskCache`. (#3118)
+
+* Closed #3140: Added support for `...` argument in `icon()`. (#3143)
+
+* Closed #629: All `update*` functions now have a default value for `session`, and issue an informative warning if it is missing. (#3195, #3199)
+
+* Improved error messages when reading reactive values outside of a reactive domain (e.g., `reactiveVal()()`). (#3007)
+
+### Bug fixes
+
+* Fixed #1942: Calling `runApp("app.R")` no longer ignores options passed into `shinyApp()`. This makes it possible for Shiny apps to specify what port/host should be used by default. (#2969)
+
+* Fixed #3033: When a `DiskCache` was created with both `max_n` and `max_size`, too many items could get pruned when `prune()` was called. (#3034)
+
+* Fixed #2703: Fixed numerous issues with some combinations of `min`/`value`/`max` causing issues with `date[Range]Input()` and `updateDate[Range]Input()`. (#3038, #3201)
+
+* Fixed #2936: `dateYMD` was giving a warning when passed a vector of dates from `dateInput` which was greater than length 1. The length check was removed because it was not needed. (#3061)
+
+* Fixed #2266, #2688: `radioButtons` and `updateRadioButtons` now accept `character(0)` to indicate that none of the options should be selected (thanks to @ColinFay). (#3043)
+
+* Fixed a bug that `textAreaInput()` doesn't work as expected for relative `width` (thanks to @shrektan). (#2049)
+
+* Fixed #2859: `renderPlot()` wasn't correctly setting `showtext::showtext_opts()`'s `dpi` setting with the correct resolution on high resolution displays; which means, if the font was rendered by showtext, font sizes would look smaller than they should on such displays. (#2941)
+
+* Closed #2910, #2909, #1552: `sliderInput()` warns if the `value` is outside of `min` and `max`, and errors if `value` is `NULL` or `NA`. (#3194)
+
+### Library updates
+
+* Removed html5shiv and respond.js, which were used for IE 8 and IE 9 compatibility. (#2973)
+
+* Removed es5-shim library, which was internally used within `selectInput()` for ECMAScript 5 compatibility. (#2993)
+
+
+# shiny 1.5.0
 
 ## Full changelog
 
@@ -17,7 +371,7 @@ shiny 1.5.0
 
 * The new `moduleServer` function provides a simpler interface for creating and using modules. (#2773)
 
-* Resolved #2732: `markdown()` is a new function for writing Markdown with Github extensions directly in Shiny UIs. Markdown rendering is performed by the [commonmark](https://github.com/jeroen/commonmark) package. (#2737)
+* Resolved #2732: `markdown()` is a new function for writing Markdown with Github extensions directly in Shiny UIs. Markdown rendering is performed by the [commonmark](https://github.com/r-lib/commonmark) package. (#2737)
 
 * The `getCurrentOutputInfo()` function can now return the background color (`bg`), foreground color (`fg`), `accent` (i.e., hyperlink) color, and `font` information of the output's HTML container. This information is reported by `plotOutput()`, `imageOutput()`, and any other output bindings containing a class of `.shiny-report-theme`. This feature allows developers to style an output's contents based on the container's CSS styling.  (#2740)
 
@@ -52,20 +406,17 @@ shiny 1.5.0
 * Updated from Font-Awesome 5.3.1 to 5.13.0, which includes icons related to COVID-19. For upgrade notes, see https://github.com/FortAwesome/Font-Awesome/blob/master/UPGRADING.md. (#2891)
 
 
-shiny 1.4.0.2
-===========
+# shiny 1.4.0.2
 
 Minor patch release: fixed some timing-dependent tests failed intermittently on CRAN build machines.
 
 
-shiny 1.4.0.1
-===========
+# shiny 1.4.0.1
 
 Minor patch release to account for changes to the grid package that will be upcoming in the R 4.0 release (#2776).
 
 
-shiny 1.4.0
-===========
+# shiny 1.4.0
 
 ## Full changelog
 
@@ -128,8 +479,7 @@ shiny 1.4.0
 * Fixed #2329, #1817: These bugs were reported as fixed in Shiny 1.3.0 but were not actually fixed because some JavaScript changes were accidentally not included in the release. The fix resolves issues that occur when `withProgressBar()` or bookmarking are combined with the [networkD3](https://christophergandrud.github.io/networkD3/) package's Sankey plot.
 
 
-shiny 1.3.2
-===========
+# shiny 1.3.2
 
 ### Bug fixes
 
@@ -138,8 +488,7 @@ shiny 1.3.2
 * Fixed #2280: Shiny applications that used a www/index.html file did not serve up the index file. (#2382)
 
 
-shiny 1.3.1
-===========
+# shiny 1.3.1
 
 ## Full changelog
 
@@ -148,8 +497,7 @@ shiny 1.3.1
 * Fixed a performance issue introduced in v1.3.0 when using large nested lists within Shiny. (#2377)
 
 
-shiny 1.3.0
-===========
+# shiny 1.3.0
 
 ## Full changelog
 
@@ -180,10 +528,9 @@ shiny 1.3.0
 * Fixed #2247: `renderCachedPlot` now supports using promises for either `expr` or `cacheKeyExpr`. (Shiny v1.2.0 supported async `expr`, but only if `cacheKeyExpr` was async as well; now you can use any combination of sync/async for `expr` and `cacheKeyExpr`.) #2261
 
 
-shiny 1.2.0
-===========
+# shiny 1.2.0
 
-This release features plot caching, an important new tool for improving performance and scalability. Using `renderCachedPlot` in place of `renderPlot` can greatly improve responsiveness for apps that show the same plot many times (for example, a dashboard or report where all users view the same data). Shiny gives you a fair amount of control in where the cache is stored and how cached plots are invalidated, so be sure to read [this article](http://shiny.rstudio.com/articles/plot-caching.html) to get the most out of this feature.
+This release features plot caching, an important new tool for improving performance and scalability. Using `renderCachedPlot` in place of `renderPlot` can greatly improve responsiveness for apps that show the same plot many times (for example, a dashboard or report where all users view the same data). Shiny gives you a fair amount of control in where the cache is stored and how cached plots are invalidated, so be sure to read [this article](https://shiny.rstudio.com/articles/plot-caching.html) to get the most out of this feature.
 
 ## Full changelog
 
@@ -246,8 +593,7 @@ This release features plot caching, an important new tool for improving performa
 * Addressed #1864 by changing `optgroup` documentation to use `list` instead of `c`. (#2084)
 
 
-shiny 1.1.0
-===========
+# shiny 1.1.0
 
 This is a significant release for Shiny, with a major new feature that was nearly a year in the making: support for asynchronous operations! Until now, R's single-threaded nature meant that performing long-running calculations or tasks from Shiny would bring your app to a halt for other users of that process. This release of Shiny deeply integrates the [promises](https://rstudio.github.io/promises/) package to allow you to execute some tasks asynchronously, including as part of reactive expressions and outputs. See the [promises](https://rstudio.github.io/promises/) documentation to learn more.
 
@@ -283,7 +629,7 @@ This is a significant release for Shiny, with a major new feature that was nearl
 
 * Removed the (ridiculously outdated) "experimental feature" tag from the reference documentation for `renderUI`. (#2036)
 
-* Addressed #1907: the `ignoreInit` argument was first added only to `observeEvent`. Later, we also added it to `eventReactive`, but forgot to update the documentation. Now done, thanks [@flo12392](https://github.com/flo12392)! (#2036)
+* Addressed #1907: the `ignoreInit` argument was first added only to `observeEvent`. Later, we also added it to `eventReactive`, but forgot to update the documentation. Now done, thanks @flo12392! (#2036)
 
 ### Bug fixes
 
@@ -297,7 +643,7 @@ This is a significant release for Shiny, with a major new feature that was nearl
 
 * Fixed #1600: URL-encoded bookmarking did not work with sliders that had dates or date-times. (#1961)
 
-* Fixed #1962: [File dragging and dropping](https://blog.rstudio.com/2017/08/15/shiny-1-0-4/) broke in the presence of jQuery version 3.0 as introduced by the [rhandsontable](https://jrowen.github.io/rhandsontable/) [htmlwidget](https://www.htmlwidgets.org/). (#2005)
+* Fixed #1962: [File dragging and dropping](https://posit.co/blog/shiny-1-0-4/) broke in the presence of jQuery version 3.0 as introduced by the [rhandsontable](https://jrowen.github.io/rhandsontable/) [htmlwidget](https://www.htmlwidgets.org/). (#2005)
 
 * Improved the error handling inside the `addResourcePath()` function, to give end users more informative error messages when the `directoryPath` argument cannot be normalized. This is especially useful for `runtime: shiny_prerendered` Rmd documents, like `learnr` tutorials. (#1968)
 
@@ -309,6 +655,7 @@ This is a significant release for Shiny, with a major new feature that was nearl
 
 * Fixed #2021: Memory leak with `reactiveTimer` and `invalidateLater`. (#2022)
 
+
 ### Library updates
 
 * Updated to ion.rangeSlider 2.2.0. (#1955)
@@ -319,8 +666,7 @@ This is a significant release for Shiny, with a major new feature that was nearl
 In some rare cases, interrupting an application (by pressing Ctrl-C or Esc) may result in the message `Error in execCallbacks(timeoutSecs) : c++ exception (unknown reason)`. Although this message sounds alarming, it is harmless, and will go away in a future version of the later package (more information [here](https://github.com/r-lib/later/issues/55)).
 
 
-shiny 1.0.5
-===========
+# shiny 1.0.5
 
 ## Full changelog
 
@@ -333,8 +679,7 @@ shiny 1.0.5
 * Fixed #1824: HTTP HEAD requests on static files caused the application to stop. (#1825)
 
 
-shiny 1.0.4
-===========
+# shiny 1.0.4
 
 There are three headlining features in this release of Shiny. It is now possible to add and remove tabs from a `tabPanel`; there is a new function, `onStop()`, which registers callbacks that execute when an application exits; and `fileInput`s now can have files dragged and dropped on them. In addition to these features, this release has a number of minor features and bug fixes. See the full changelog below for more details.
 
@@ -395,8 +740,7 @@ There are three headlining features in this release of Shiny. It is now possible
 * Fixed #1474: A `browser()` call in an observer could cause an error in the RStudio IDE on Windows. (#1802)
 
 
-shiny 1.0.3
-================
+# shiny 1.0.3
 
 This is a hotfix release of Shiny. With previous versions of Shiny, when running an application on the newly-released version of R, 3.4.0, it would print a message: `Warning in body(fun) : argument is not a function`. This has no effect on the application, but because the message could be alarming to users, we are releasing a new version of Shiny that fixes this issue.
 
@@ -409,8 +753,7 @@ This is a hotfix release of Shiny. With previous versions of Shiny, when running
 * Fixed #1676: On R 3.4.0, running a Shiny application gave a warning: `Warning in body(fun) : argument is not a function`. (#1677)
 
 
-shiny 1.0.2
-================
+# shiny 1.0.2
 
 This is a hotfix release of Shiny. The primary reason for this release is because the web host for MathJax JavaScript library is scheduled to be shut down in the next few weeks. After it is shut down, Shiny applications that use MathJax will no longer be able to load the MathJax library if they are run with Shiny 1.0.1 and below. (If you don't know whether your application uses MathJax, it probably does not.) For more information about why the MathJax CDN is shutting down, see https://www.mathjax.org/cdn-shutting-down/.
 
@@ -429,8 +772,7 @@ This is a hotfix release of Shiny. The primary reason for this release is becaus
 * Fixed #1653: wrong code example in documentation. (#1658)
 
 
-shiny 1.0.1
-================
+# shiny 1.0.1
 
 This is a maintenance release of Shiny, mostly aimed at fixing bugs and introducing minor features. The most notable additions in this version of Shiny are the introduction of the `reactiveVal()` function (it's like `reactiveValues()`, but it only stores a single value), and that the choices of `radioButtons()` and `checkboxGroupInput()` can now contain HTML content instead of just plain text.
 
@@ -500,8 +842,7 @@ in shiny apps. For more info, see the documentation (`?updateQueryString` and `?
 * Closed #1500: Updated ion.rangeSlider to 2.1.6. (#1540)
 
 
-shiny 1.0.0
-===========
+# shiny 1.0.0
 
 Shiny has reached a milestone: version 1.0.0! In the last year, we've added two major features that we considered essential for a 1.0.0 release: bookmarking, and support for testing Shiny applications. As usual, this version of Shiny also includes many minor features and bug fixes.
 
@@ -566,8 +907,7 @@ Now there's an official way to slow down reactive values and expressions that in
 * Updated to Font Awesome 4.7.0.
 
 
-shiny 0.14.2
-============
+# shiny 0.14.2
 
 This is a maintenance release of Shiny, with some bug fixes and minor new features.
 
@@ -595,8 +935,7 @@ This is a maintenance release of Shiny, with some bug fixes and minor new featur
 
 * Fixed a bug where, in versions of R before 3.2, Shiny applications could crash due to a bug in R's implementation of `list2env()`. (#1446)
 
-shiny 0.14.1
-============
+# shiny 0.14.1
 
 This is a maintenance release of Shiny, with some bug fixes and minor new features.
 
@@ -606,7 +945,7 @@ This is a maintenance release of Shiny, with some bug fixes and minor new featur
 
 * Restored file inputs are now copied on restore, so that the restored application can't modify the bookmarked file. (#1370)
 
-* Added support for plot interaction in the development version of ggplot2, 2.1.0.9000. Also added support for ggplot2 plots with `coord_flip()` (in the development version of ggplot2). ([hadley/ggplot2#1781](https://github.com/hadley/ggplot2/issues/1781), #1392)
+* Added support for plot interaction in the development version of ggplot2, 2.1.0.9000. Also added support for ggplot2 plots with `coord_flip()` (in the development version of ggplot2). ([hadley/ggplot2#1781](https://github.com/tidyverse/ggplot2/issues/1781), #1392)
 
 
 ### Bug fixes
@@ -626,8 +965,7 @@ This is a maintenance release of Shiny, with some bug fixes and minor new featur
 * Updated to jQuery UI 1.12.1. Previously, Shiny included a build of 1.11.4 which was missing the datepicker component due to a conflict with the bootstrap-datepicker used by Shiny's `dateInput()` and `dateRangeInput()`. (#1374)
 
 
-shiny 0.14
-==========
+# shiny 0.14
 
 A new Shiny release is upon us! There are many new exciting features, bug fixes, and library updates. We'll just highlight the most important changes here, but you can browse through the full changelog below for details. This will likely be the last release before shiny 1.0, so get out your party hats!
 
@@ -638,7 +976,7 @@ Shiny now supports bookmarkable state: users can save the state of an applicatio
 **_Important note_:**
 > Saved-to-server bookmarking currently works with Shiny Server Open Source. Support on Shiny Server Pro, RStudio Connect, and shinyapps.io is under development and testing. However, URL-encoded bookmarking works on all hosting platforms.
 
-See [this article](http://shiny.rstudio.com/articles/bookmarking-state.html) to get started with bookmarkable state. There is also an [advanced-level article](http://shiny.rstudio.com/articles/advanced-bookmarking.html) (for apps that have a complex state), and [a modules article](http://shiny.rstudio.com/articles/bookmarking-modules.html) that details how to use bookmarking in conjunction with modules.
+See [this article](https://shiny.rstudio.com/articles/bookmarking-state.html) to get started with bookmarkable state. There is also an [advanced-level article](https://shiny.rstudio.com/articles/advanced-bookmarking.html) (for apps that have a complex state), and [a modules article](https://shiny.rstudio.com/articles/bookmarking-modules.html) that details how to use bookmarking in conjunction with modules.
 
 ## Notifications
 
@@ -648,7 +986,7 @@ Shiny can now display notifications on the client browser by using the `showNoti
 <img src="http://shiny.rstudio.com/images/notification.png" alt="notification" width="50%"/>
 </p>
 
-[Here](http://shiny.rstudio.com/articles/notifications.html)'s our article about it, and the [reference documentation](http://shiny.rstudio.com/reference/shiny/latest/showNotification.html).
+[Here](https://shiny.rstudio.com/articles/notifications.html)'s our article about it, and the [reference documentation](https://shiny.rstudio.com/reference/shiny/latest/showNotification.html).
 
 ## Progress indicators
 
@@ -657,7 +995,7 @@ If your Shiny app contains computations that take a long time to complete, a pro
 **_Important note_:**
 > If you were already using progress bars and had customized them with your own CSS, you can add the `style = "old"` argument to your `withProgress()` call (or `Progress$new()`). This will result in the same appearance as before. You can also call `shinyOptions(progress.style = "old")` in your app's server function to make all progress indicators use the old styling.
 
-To see new progress bars in action, see [this app](https://gallery.shinyapps.io/085-progress/) in the gallery. You can also learn more about this in [our article](http://shiny.rstudio.com/articles/progress.html) and in the reference documentation (either for the easier [`withProgress` functional API](http://shiny.rstudio.com/reference/shiny/latest/withProgress.html) or the more complicated, but more powerful, [`Progress` object-oriented API](http://shiny.rstudio.com/reference/shiny/latest/Progress.html).
+To see new progress bars in action, see [this app](https://gallery.shinyapps.io/085-progress/) in the gallery. You can also learn more about this in [our article](https://shiny.rstudio.com/articles/progress.html) and in the reference documentation (either for the easier [`withProgress` functional API](https://shiny.rstudio.com/reference/shiny/latest/withProgress.html) or the more complicated, but more powerful, [`Progress` object-oriented API](https://shiny.rstudio.com/reference/shiny/latest/Progress.html).
 
 ## Reconnection
 
@@ -671,7 +1009,7 @@ Shiny has now built-in support for displaying modal dialogs like the one below (
 <img src="http://shiny.rstudio.com/images/modal-dialog.png" alt="modal-dialog" width="50%"/>
 </p>
 
-To learn more about this, read [our article](http://shiny.rstudio.com/articles/modal-dialogs.html) and the [reference documentation](http://shiny.rstudio.com/reference/shiny/latest/modalDialog.html).
+To learn more about this, read [our article](https://shiny.rstudio.com/articles/modal-dialogs.html) and the [reference documentation](https://shiny.rstudio.com/reference/shiny/latest/modalDialog.html).
 
 ## `insertUI` and `removeUI`
 
@@ -679,13 +1017,13 @@ Sometimes in a Shiny app, arbitrary HTML UI may need to be created on-the-fly in
 
 See [this simple demo app](https://gallery.shinyapps.io/111-insert-ui/) of how one could use `insertUI` and `removeUI` to insert and remove text elements using a queue. Also see [this other app](https://gallery.shinyapps.io/insertUI/) that demonstrates how to insert and remove a few common Shiny input objects. Finally, [this app](https://gallery.shinyapps.io/insertUI-modules/) shows how to dynamically insert modules using `insertUI`.
 
-For more, read [our article](http://shiny.rstudio.com/articles/dynamic-ui.html) about dynamic UI generation and the reference documentation about [`insertUI`](http://shiny.rstudio.com/reference/shiny/latest/insertUI.html) and [`removeUI`](http://shiny.rstudio.com/reference/shiny/latest/removeUI.html).
+For more, read [our article](https://shiny.rstudio.com/articles/dynamic-ui.html) about dynamic UI generation and the reference documentation about [`insertUI`](https://shiny.rstudio.com/reference/shiny/latest/insertUI.html) and [`removeUI`](https://shiny.rstudio.com/reference/shiny/latest/insertUI.html).
 
 ## Documentation for connecting to an external database
 
-Many Shiny users have asked about best practices for accessing external databases from their Shiny applications. Although database access has long been possible using various database connector packages in R, it can be challenging to use them robustly in the dynamic environment that Shiny provides. So far, it has been mostly up to application authors to find the appropriate database drivers and to discover how to manage the database connections within an application. In order to demystify this process, we wrote a series of articles ([first one here](http://shiny.rstudio.com/articles/overview.html)) that covers the basics of connecting to an external database, as well as some security precautions to keep in mind (e.g. [how to avoid SQL injection attacks](http://shiny.rstudio.com/articles/sql-injections.html)).
+Many Shiny users have asked about best practices for accessing external databases from their Shiny applications. Although database access has long been possible using various database connector packages in R, it can be challenging to use them robustly in the dynamic environment that Shiny provides. So far, it has been mostly up to application authors to find the appropriate database drivers and to discover how to manage the database connections within an application. In order to demystify this process, we wrote a series of articles ([first one here](https://shiny.rstudio.com/articles/overview.html)) that covers the basics of connecting to an external database, as well as some security precautions to keep in mind (e.g. [how to avoid SQL injection attacks](https://shiny.rstudio.com/articles/sql-injections.html)).
 
-There are a few packages that you should look at if you're using a relational database in a Shiny app: the `dplyr` and `DBI` packages (both featured in the article linked to above), and the brand new `pool` package, which provides a further layer of abstraction to make it easier and safer to use either `DBI` or `dplyr`. `pool` is not yet on CRAN. In particular, `pool` will take care of managing connections, preventing memory leaks, and ensuring the best performance. See this [`pool` basics article](http://shiny.rstudio.com/articles/pool-basics.html) and the [more advanced-level article](http://shiny.rstudio.com/articles/pool-advanced.html) if you're feeling adventurous! (Both of these articles contain Shiny app examples that use `DBI` to connect to an external MySQL database.) If you are more comfortable with `dplyr` than `DBI`, don't miss the article about the [integration of `pool` and `dplyr`](http://shiny.rstudio.com/articles/pool-dplyr.html).
+There are a few packages that you should look at if you're using a relational database in a Shiny app: the `dplyr` and `DBI` packages (both featured in the article linked to above), and the brand new `pool` package, which provides a further layer of abstraction to make it easier and safer to use either `DBI` or `dplyr`. `pool` is not yet on CRAN. In particular, `pool` will take care of managing connections, preventing memory leaks, and ensuring the best performance. See this [`pool` basics article](https://shiny.rstudio.com/articles/pool-basics.html) and the [more advanced-level article](https://shiny.rstudio.com/articles/pool-advanced.html) if you're feeling adventurous! (Both of these articles contain Shiny app examples that use `DBI` to connect to an external MySQL database.) If you are more comfortable with `dplyr` than `DBI`, don't miss the article about the [integration of `pool` and `dplyr`](https://shiny.rstudio.com/articles/pool-dplyr.html).
 
 If you're new to databases in the Shiny world, we recommend using `dplyr` and `pool` if possible. If you need greater control than `dplyr` offers (for example, if you need to modify data in the database or use transactions), then use `DBI` and `pool`. The `pool` package was introduced to make your life easier, but in no way constrains you, so we don't envision any situation in which you'd be better off *not* using it. The only caveat is that `pool` is not yet on CRAN, so you may prefer to wait for that.
 
@@ -693,11 +1031,11 @@ If you're new to databases in the Shiny world, we recommend using `dplyr` and `p
 
 There are many more minor features, small improvements, and bug fixes than we can cover here, so we'll just mention a few of the more noteworthy ones (the full changelog, with links to all the relevant issues and pull requests, is right below this section):
 
-*    **Error Sanitization**: you now have the option to sanitize error messages; in other words, the content of the original error message can be suppressed so that it doesn't leak any sensitive information. To sanitize errors everywhere in your app, just add `options(shiny.sanitize.errors = TRUE)` somewhere in your app. Read [this article](http://shiny.rstudio.com/articles/sanitize-errors.html) for more, or play with the [demo app](https://gallery.shinyapps.io/110-error-sanitization/).
+*    **Error Sanitization**: you now have the option to sanitize error messages; in other words, the content of the original error message can be suppressed so that it doesn't leak any sensitive information. To sanitize errors everywhere in your app, just add `options(shiny.sanitize.errors = TRUE)` somewhere in your app. Read [this article](https://shiny.rstudio.com/articles/sanitize-errors.html) for more, or play with the [demo app](https://gallery.shinyapps.io/110-error-sanitization/).
 
 *    **Code Diagnostics**: if there is an error parsing `ui.R`, `server.R`, `app.R`, or `global.R`, Shiny will search the code for missing commas, extra commas, and unmatched braces, parens, and brackets, and will print out messages pointing out those problems. (#1126)
 
-*    **Reactlog visualization**: by default, the [`showReactLog()` function](http://shiny.rstudio.com/reference/shiny/latest/reactlog.html) (which brings up the reactive graph) also displays the time that each reactive and observer were active for:
+*    **Reactlog visualization**: by default, the [`showReactLog()` function](https://shiny.rstudio.com/reference/shiny/latest/reactlog.html) (which brings up the reactive graph) also displays the time that each reactive and observer were active for:
 
       <p align="center">
       <img src="http://shiny.rstudio.com/images/reactlog.png" alt="modal-dialog" width="75%"/>
@@ -713,7 +1051,7 @@ There are many more minor features, small improvements, and bug fixes than we ca
       <img src="http://shiny.rstudio.com/images/render-table.png" alt="render-table" width="75%"/>
       </p>
 
-      For more, read our [short article](http://shiny.rstudio.com/articles/render-table.html) about this update, experiment with all the new features in this [demo app](https://gallery.shinyapps.io/109-render-table/), or check out the [reference documentation](http://shiny.rstudio.com/reference/shiny/latest/renderTable.html).
+      For more, read our [short article](https://shiny.rstudio.com/articles/render-table.html) about this update, experiment with all the new features in this [demo app](https://gallery.shinyapps.io/109-render-table/), or check out the [reference documentation](https://shiny.rstudio.com/reference/shiny/latest/renderTable.html).
 
 ## Full changelog
 
@@ -826,14 +1164,12 @@ There are many more minor features, small improvements, and bug fixes than we ca
 * Updated to jQuery 1.12.4.
 
 
-shiny 0.13.2
-============
+# shiny 0.13.2
 
 * Updated documentation for `htmlTemplate`.
 
 
-shiny 0.13.1
-============
+# shiny 0.13.1
 
 * `flexCol` did not work on RStudio for Windows or Linux.
 
@@ -842,8 +1178,7 @@ shiny 0.13.1
 * BREAKING CHANGE: The long-deprecated ability to pass functions (rather than expressions) to reactive() and observe() has finally been removed.
 
 
-shiny 0.13.0
-============
+# shiny 0.13.0
 
 * Fixed #962: plot interactions did not work with the development version of ggplot2 (after ggplot2 1.0.1).
 
@@ -894,8 +1229,7 @@ shiny 0.13.0
 * Added support for the new htmltools 0.3 feature `htmlTemplate`. It's now possible to use regular HTML markup to design your UI, but still use R expressions to define inputs, outputs, and HTML widgets.
 
 
-shiny 0.12.2
-============
+# shiny 0.12.2
 
 * GitHub changed URLs for gists from .tar.gz to .zip, so `runGist` was updated to work with the new URLs.
 
@@ -918,16 +1252,14 @@ shiny 0.12.2
 * Shiny now correctly handles HTTP HEAD requests. (#876)
 
 
-shiny 0.12.1
-============
+# shiny 0.12.1
 
 * Fixed an issue where unbindAll() causes subsequent bindAll() to be ignored for previously bound outputs. (#856)
 
 * Undeprecate `dataTableOutput` and `renderDataTable`, which had been deprecated in favor of the new DT package. The DT package is a bit too new and has a slightly different API, we were too hasty in deprecating the existing Shiny functions.
 
 
-shiny 0.12.0
-============
+# shiny 0.12.0
 
 In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps.
 
@@ -983,8 +1315,7 @@ Shiny 0.12.0 deprecated Shiny's dataTableOutput and renderDataTable functions an
 * renderDataTable() and dataTableOutput() have been deprecated in shiny and will be removed in future versions of shiny. Please use the DT package instead: http://rstudio.github.io/DT/ (#807)
 
 
-shiny 0.11.1
-============
+# shiny 0.11.1
 
 * Major client-side performance improvements for pages that have many conditionalPanels, tabPanels, and plotOutputs. (#693, #717, #723)
 
@@ -1011,8 +1342,7 @@ shiny 0.11.1
 * downloadHandler content callback functions are now invoked with a temp file name that has the same extension as the final filename that will be used by the download. This is to deal with the fact that some file writing functions in R will auto-append the extension for their file type (pdf, zip).
 
 
-shiny 0.11
-==========
+# shiny 0.11
 
 Shiny 0.11 switches away from the Bootstrap 2 web framework to the next version, Bootstrap 3. This is in part because Bootstrap 2 is no longer being developed, and in part because it allows us to tap into the ecosystem of Bootstrap 3 themes.
 
@@ -1040,7 +1370,7 @@ Shiny 0.11 switches away from the Bootstrap 2 web framework to the next version,
   * `updateSliderInput()` can now control the min, max, value, and step size of a slider. Previously, only the value could be controlled this way, and if you wanted to change other values, you needed to use Shiny's dynamic UI.
 
 
-*    If in your HTML you are using custom CSS classes that are specific to Bootstrap, you may need to update them for Bootstrap 3. See the Bootstrap [migration guide](http://getbootstrap.com/migration/).
+*    If in your HTML you are using custom CSS classes that are specific to Bootstrap, you may need to update them for Bootstrap 3. See the Bootstrap [migration guide](https://getbootstrap.com/migration/).
 
 
 If you encounter other migration issues, please let us know on the [shiny-discuss](https://groups.google.com/forum/#!forum/shiny-discuss) mailing list, or on the Shiny [issue tracker](https://github.com/rstudio/shiny/issues).
@@ -1090,20 +1420,17 @@ Along with the release of Shiny 0.11, we've packaged up some Bootstrap 3 themes
 * Password input fields can now be used, with `passwordInput()`. (#672)
 
 
-shiny 0.10.2.2
-==============
+# shiny 0.10.2.2
 
 * Remove use of `rstudio::viewer` in a code example, for R CMD check.
 
 
-shiny 0.10.2.1
-==============
+# shiny 0.10.2.1
 
 * Changed some examples to use \donttest instead of \dontrun.
 
 
-shiny 0.10.2
-============
+# shiny 0.10.2
 
 * The minimal version of R required for the shiny package is 3.0.0 now.
 
@@ -1136,8 +1463,7 @@ shiny 0.10.2
 * Added `position` parameter to `navbarPage`.
 
 
-shiny 0.10.1
-============
+# shiny 0.10.1
 
 * Added Unicode support for Windows. Shiny apps running on Windows must use the UTF-8 encoding for ui.R and server.R (also the optional global.R) if they contain non-ASCII characters. See this article for details and examples: http://shiny.rstudio.com/gallery/unicode-characters.html (#516)
 
@@ -1150,8 +1476,7 @@ shiny 0.10.1
 * Added support for option groups in the select/selectize inputs. When the `choices` argument for `selectInput()`/`selectizeInput()` is a list of sub-lists and any sub-list is of length greater than 1, the HTML tag `<optgroup>` will be used. See an example at http://shiny.rstudio.com/gallery/option-groups-for-selectize-input.html (#542)
 
 
-shiny 0.10.0
-============
+# shiny 0.10.0
 
 * BREAKING CHANGE: By default, observers now terminate themselves if they were created during a session and that session ends. See ?domains for more details.
 
@@ -1188,14 +1513,12 @@ shiny 0.10.0
 * `runGitHub()` can also take a value of the form "username/repo" in its first argument, e.g. both runGitHub("shiny_example", "rstudio") and runGitHub("rstudio/shiny_example") are valid ways to run the GitHub repo.
 
 
-shiny 0.9.1
-===========
+# shiny 0.9.1
 
 * Fixed warning 'Error in Context$new : could not find function "loadMethod"' that was happening to dependent packages on "R CMD check".
 
 
-shiny 0.9.0
-===========
+# shiny 0.9.0
 
 * BREAKING CHANGE: Added a `host` parameter to runApp() and runExample(), which defaults to the shiny.host option if it is non-NULL, or "127.0.0.1" otherwise. This means that by default, Shiny applications can only be accessed on the same machine from which they are served. To allow other clients to connect, as in previous versions of Shiny, use "0.0.0.0" (or the IP address of one of your network interfaces, if you care to be explicit about it).
 
@@ -1233,7 +1556,7 @@ shiny 0.9.0
 
 * Added `theme` parameter to page building functions for specifying alternate bootstrap css styles.
 
-* Added `icon()` function for embedding icons from the [font awesome](http://fontawesome.io/) icon library
+* Added `icon()` function for embedding icons from the [font awesome](https://fontawesome.com) icon library
 
 * Added `makeReactiveBinding` function to turn a "regular" variable into a reactive one (i.e. reading the variable makes the current reactive context dependent on it, and setting the variable is a source of reactivity).
 
@@ -1268,8 +1591,7 @@ shiny 0.9.0
 * Dots are now legal characters for inputId/outputId. (Thanks, Kevin Lindquist. #358)
 
 
-shiny 0.8.0
-===========
+# shiny 0.8.0
 
 * Debug hooks are registered on all user-provided functions and (reactive) expressions (e.g., in renderPlot()), which makes it possible to set breakpoints in these functions using the latest version of the RStudio IDE, and the RStudio visual debugging tools can be used to debug Shiny apps. Internally, the registration is done via installExprFunction(), which is a new function introduced in this version to replace exprToFunction() so that the registration can be automatically done.
 
@@ -1288,8 +1610,7 @@ shiny 0.8.0
 * The minimal required version for the httpuv package was increased to 1.2 (on CRAN now).
 
 
-shiny 0.7.0
-===========
+# shiny 0.7.0
 
 * Stopped sending websocket subprotocol. This fixes a compatibility issue with Google Chrome 30.
 
@@ -1318,8 +1639,7 @@ shiny 0.7.0
 * Add shiny.sharedSecret option, to require the HTTP header Shiny-Shared-Secret to be set to the given value.
 
 
-shiny 0.6.0
-===========
+# shiny 0.6.0
 
 * `tabsetPanel()` can be directed to start with a specific tab selected.
 
@@ -1350,8 +1670,7 @@ shiny 0.6.0
 * Shiny apps can be run without a server.r and ui.r file.
 
 
-shiny 0.5.0
-===========
+# shiny 0.5.0
 
 * Switch from websockets package for handling websocket connections to httpuv.
 
@@ -1368,16 +1687,14 @@ shiny 0.5.0
 * Fix bug #55, where `renderTable()` would throw error with an empty data frame.
 
 
-shiny 0.4.1
-===========
+# shiny 0.4.1
 
 * Fix bug where width and height weren't passed along properly from `reactivePlot` to `renderPlot`.
 
 * Fix bug where infinite recursion would happen when `reactivePlot` was passed a function for width or height.
 
 
-shiny 0.4.0
-===========
+# shiny 0.4.0
 
 * Added suspend/resume capability to observers.
 
@@ -1392,8 +1709,7 @@ shiny 0.4.0
 * Fixed a bug where empty values in a numericInput were sent to the R process as 0. They are now sent as NA.
 
 
-shiny 0.3.1
-===========
+# shiny 0.3.1
 
 * Fix issue #91: bug where downloading files did not work.
 
@@ -1402,8 +1718,7 @@ shiny 0.3.1
 * Reactive functions now preserve the visible/invisible state of their returned values.
 
 
-shiny 0.3.0
-===========
+# shiny 0.3.0
 
 * Reactive functions are now evaluated lazily.
 
@@ -1428,52 +1743,44 @@ shiny 0.3.0
 * Fix issue #64, where pressing Enter in a textbox would cause a form to submit.
 
 
-shiny 0.2.4
-===========
+# shiny 0.2.4
 
 * `runGist` has been updated to use the new download URLs from https://gist.github.com.
 
 * Shiny now uses `CairoPNG()` for output, when the Cairo package is available. This provides better-looking output on Linux and Windows.
 
 
-shiny 0.2.3
-===========
+# shiny 0.2.3
 
 * Ignore request variables for routing purposes
 
 
-shiny 0.2.2
-===========
+# shiny 0.2.2
 
 * Fix CRAN warning (assigning to global environment)
 
 
-shiny 0.2.1
-===========
+# shiny 0.2.1
 
 * [BREAKING] Modify API of `downloadHandler`: The `content` function now takes a file path, not writable connection, as an argument. This makes it much easier to work with APIs that only write to file paths, not connections.
 
 
-shiny 0.2.0
-===========
+# shiny 0.2.0
 
 * Fix subtle name resolution bug--the usual symptom being S4 methods not being invoked correctly when called from inside of ui.R or server.R
 
 
-shiny 0.1.14
-===========
+# shiny 0.1.14
 
 * Fix slider animator, which broke in 0.1.10
 
 
-shiny 0.1.13
-===========
+# shiny 0.1.13
 
 * Fix temp file leak in reactivePlot
 
 
-shiny 0.1.12
-===========
+# shiny 0.1.12
 
 * Fix problems with runGist on Windows
 
@@ -1482,8 +1789,7 @@ shiny 0.1.12
 * Add CSS hooks for app-wide busy indicators
 
 
-shiny 0.1.11
-===========
+# shiny 0.1.11
 
 * Fix input binding with IE8 on Shiny Server
 
@@ -1492,8 +1798,7 @@ shiny 0.1.11
 * Allow dynamic sizing of reactivePlot (i.e. using a function instead of a fixed value)
 
 
-shiny 0.1.10
-===========
+# shiny 0.1.10
 
 * Support more MIME types when serving out of www
 
@@ -1506,8 +1811,7 @@ shiny 0.1.10
 * Fix plot rendering with IE8 on Shiny Server
 
 
-shiny 0.1.9
-===========
+# shiny 0.1.9
 
 * Much less flicker when updating plots
 
@@ -1516,8 +1820,7 @@ shiny 0.1.9
 * Add `includeText`, `includeHTML`, and `includeMarkdown` functions for putting text, HTML, and Markdown content from external files in the application's UI.
 
 
-shiny 0.1.8
-===========
+# shiny 0.1.8
 
 * Add `runGist` function for conveniently running a Shiny app that is published on gist.github.com.
 
@@ -1530,8 +1833,7 @@ shiny 0.1.8
 * Add `bootstrapPage` function for creating new Bootstrap based layouts from scratch.
 
 
-shiny 0.1.7
-===========
+# shiny 0.1.7
 
 * Fix issue #26: Shiny.OutputBindings not correctly exported.
 
@@ -1540,8 +1842,7 @@ shiny 0.1.7
 * Transcode JSON into UTF-8 (prevents non-ASCII reactivePrint values from causing errors on Windows).
 
 
-shiny 0.1.6
-===========
+# shiny 0.1.6
 
 * Import package dependencies, instead of attaching them (with the exception of websockets, which doesn't currently work unless attached).
 
@@ -1550,8 +1851,7 @@ shiny 0.1.6
 * bindAll was not correctly sending initial values to the server; fixed.
 
 
-shiny 0.1.5
-===========
+# shiny 0.1.5
 
 * BREAKING CHANGE: JS APIs Shiny.bindInput and Shiny.bindOutput removed and replaced with Shiny.bindAll; Shiny.unbindInput and Shiny.unbindOutput removed and replaced with Shiny.unbindAll.
 
@@ -1566,8 +1866,7 @@ shiny 0.1.5
 * htmlOutput (CSS class `shiny-html-output`) can contain inputs and outputs.
 
 
-shiny 0.1.4
-===========
+# shiny 0.1.4
 
 * Allow Bootstrap tabsets to act as reactive inputs; their value indicates which tab is active
 
@@ -1580,8 +1879,7 @@ shiny 0.1.4
 * Add Shiny.bindInputs(scope), .unbindInputs(scope), .bindOutputs(scope), and .unbindOutputs(scope) JS API calls to allow dynamic binding/unbinding of HTML elements
 
 
-shiny 0.1.3
-===========
+# shiny 0.1.3
 
 * Introduce Shiny.inputBindings.register JS API and InputBinding class, for creating custom input controls
 
@@ -1594,7 +1892,6 @@ shiny 0.1.3
 * Fix issue #10: Plots in tabsets not rendered
 
 
-shiny 0.1.2
-===========
+# shiny 0.1.2
 
 * Initial private beta release!

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

@@ -10,8 +10,7 @@
 #' 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
+#' 5: tests/testthat/    : Tests using the testthat and shinytest2 package
 #' ```
 #'
 #' If option 1 is selected, the full example application including the
@@ -24,13 +23,12 @@
 #' |   |- example-module.R
 #' |   `- example.R
 #' `- tests
-#'     |- shinytest.R
-#'     |- shinytest
-#'     |   `- mytest.R
 #'     |- testthat.R
 #'     `- testthat
+#'         |- setup-shinytest2.R
 #'         |- test-examplemodule.R
 #'         |- test-server.R
+#'         |- test-shinytest2.R
 #'         `- test-sort.R
 #' ```
 #'
@@ -45,20 +43,21 @@
 #' * `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/` directory using the
+#'   [shinytest2](https://rstudio.github.io/shinytest2/reference/test_app.html)
+#'   package.
+#' * `tests/testthat/setup-shinytest2.R` is setup file to source your `./R` folder into the testing environment.
 #' * `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-shinytest2.R` is a test that uses the
+#'   [shinytest2](https://rstudio.github.io/shinytest2/) package to do
+#'   snapshot-based testing.
 #' * `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
+#'   "app", "rdir", "module", and "tests". 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
@@ -79,15 +78,19 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
   # =======================================================
 
   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"
+    app    = "app.R              : Main application file",
+    rdir   = "R/example.R        : Helper file with R code",
+    module = "R/example-module.R : Example module",
+    tests  = "tests/testthat/    : Tests using {testthat} and {shinytest2}"
   )
 
+  # Support legacy value
+  examples[examples == "shinytest"] <- "tests"
+  examples[examples == "testthat"] <- "tests"
+  examples <- unique(examples)
+
   if (identical(examples, "default")) {
-    if (interactive()) {
+    if (rlang::is_interactive()) {
       examples <- "ask"
     } else {
       examples <- "all"
@@ -124,18 +127,8 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
     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.")
-      }
-
-    }
+  if ("tests" %in% examples) {
+    rlang::check_installed("shinytest2", "for {testthat} tests to work as expected", version = "0.2.0")
   }
 
   # =======================================================
@@ -152,7 +145,7 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
 
   # Helper to resolve paths relative to our template
   template_path <- function(...) {
-    system.file("app_template", ..., package = "shiny")
+    system_file("app_template", ..., package = "shiny")
   }
 
   # Resolve path relative to destination
@@ -208,16 +201,13 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
   }
 
   # Copy the files for a tests/ subdirectory
-  copy_test_dir <- function(name) {
+  copy_test_dir <- function() {
     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")
+      is_r_folder_file <- !grepl("module|server|shinytest2|testthat", basename(files))
       files <- files[!is_r_folder_file]
     }
 
@@ -282,12 +272,10 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
     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")
+  # tests/testthat dir
+  if ("tests" %in% examples) {
+    copy_test_dir()
   }
+
   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
+#'   `session$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 [createRenderFunction()]
+#'   (instead of [createRenderFunction()]). Because the user code is wrapped in
+#'   another function, `createRenderFunction()` is not able to automatically
+#'   extract the user-provided code and use it in the cache key. Instead,
+#'   `renderPrint` calls `createRenderFunction()`, 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) {
+#'     q <- rlang::enquo0(expr)
+#'
+#'     htmlwidgets::shinyRenderWidget(
+#'       q,
+#'       myWidgetOutput,
+#'       quoted = TRUE,
+#'       cacheHint = list(label = "myWidget", userQuo = q)
+#'     )
+#'   }
+#'   ```
+#'
+#'   If your `render` function sets any internal state, you may find it useful
+#'   in your call to [createRenderFunction()] 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 dependency 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()) {
@@ -308,34 +321,38 @@ RestoreContext <- R6Class("RestoreContext",
       if (substr(queryString, 1, 1) == '?')
         queryString <- substr(queryString, 2, nchar(queryString))
 
+      # The "=" after "_inputs_" is optional. Shiny doesn't generate URLs with
+      # "=", but httr always adds "=".
+      inputs_reg <- "(^|&)_inputs_=?(&|$)"
+      values_reg <- "(^|&)_values_=?(&|$)"
 
       # Error if multiple '_inputs_' or '_values_'. This is needed because
       # strsplit won't add an entry if the search pattern is at the end of a
       # string.
-      if (length(gregexpr("(^|&)_inputs_(&|$)", queryString)[[1]]) > 1)
+      if (length(gregexpr(inputs_reg, queryString)[[1]]) > 1)
         stop("Invalid state string: more than one '_inputs_' found")
-      if (length(gregexpr("(^|&)_values_(&|$)", queryString)[[1]]) > 1)
+      if (length(gregexpr(values_reg, queryString)[[1]]) > 1)
         stop("Invalid state string: more than one '_values_' found")
 
       # Look for _inputs_ and store following content in inputStr
-      splitStr <- strsplit(queryString, "(^|&)_inputs_(&|$)")[[1]]
+      splitStr <- strsplit(queryString, inputs_reg)[[1]]
       if (length(splitStr) == 2) {
         inputStr <- splitStr[2]
         # Remove any _values_ (and content after _values_) that may come after
         # _inputs_
-        inputStr <- strsplit(inputStr, "(^|&)_values_(&|$)")[[1]][1]
+        inputStr <- strsplit(inputStr, values_reg)[[1]][1]
 
       } else {
         inputStr <- ""
       }
 
       # Look for _values_ and store following content in valueStr
-      splitStr <- strsplit(queryString, "(^|&)_values_(&|$)")[[1]]
+      splitStr <- strsplit(queryString, values_reg)[[1]]
       if (length(splitStr) == 2) {
         valueStr <- splitStr[2]
         # Remove any _inputs_ (and content after _inputs_) that may come after
         # _values_
-        valueStr <- strsplit(valueStr, "(^|&)_inputs_(&|$)")[[1]][1]
+        valueStr <- strsplit(valueStr, inputs_reg)[[1]][1]
 
       } else {
         valueStr <- ""
@@ -346,16 +363,20 @@ RestoreContext <- R6Class("RestoreContext",
       values <- parseQueryString(valueStr, nested = TRUE)
 
       valuesFromJSON <- function(vals) {
-        mapply(names(vals), vals, SIMPLIFY = FALSE,
+        varsUnparsed <- c()
+        valsParsed <- mapply(names(vals), vals, SIMPLIFY = FALSE,
           FUN = function(name, value) {
             tryCatch(
               safeFromJSON(value),
               error = function(e) {
-                stop("Failed to parse URL parameter \"", name, "\"")
+                varsUnparsed <<- c(varsUnparsed, name)
+                warning("Failed to parse URL parameter \"", name, "\"")
               }
             )
           }
         )
+        valsParsed[varsUnparsed] <- NULL
+        valsParsed
       }
 
       inputs <- valuesFromJSON(inputs)
@@ -431,8 +452,10 @@ RestoreInputSet <- R6Class("RestoreInputSet",
   )
 )
 
-
-restoreCtxStack <- Stack$new()
+restoreCtxStack <- NULL
+on_load({
+    restoreCtxStack <- fastmap::faststack()
+})
 
 withRestoreContext <- function(ctx, expr) {
   restoreCtxStack$push(ctx)
@@ -453,7 +476,7 @@ hasCurrentRestoreContext <- function() {
   domain <- getDefaultReactiveDomain()
   if (!is.null(domain) && !is.null(domain$restoreContext))
     return(TRUE)
-  
+
   return(FALSE)
 }
 
@@ -528,7 +551,7 @@ restoreInput <- function(id, default) {
 #' `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
+#' @param mode When the query string is updated, should the current history
 #'   entry be replaced (default), or should a new history entry be pushed onto
 #'   the history stack? The former should only be used in a live bookmarking
 #'   context. The latter is useful if you want to navigate between states using
@@ -1144,10 +1167,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 +1193,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

@@ -6,7 +6,7 @@
 #' @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
+#' @return A UI definition that can be passed to the [shinyUI] function
 #' @export
 pageWithSidebar <- function(headerPanel,
                             sidebarPanel,

R/bootstrap-layout.R

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

R/cache-memory.R

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

R/cache-utils.R

@@ -1,9 +1,25 @@
-
-validate_key <- function(key) {
-  if (!is.character(key) || length(key) != 1 || nchar(key) == 0) {
-    stop("Invalid key: key must be single non-empty string.")
-  }
-  if (grepl("[^a-z0-9]", key)) {
-    stop("Invalid key: ", key, ". Only lowercase letters and numbers are allowed.")
-  }
+# 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
+  )
+}
+
+# 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)
+
+  } else if (identical(cache, "session")) {
+    cache <- session$cache
+  }
+
+  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

@@ -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)
@@ -217,7 +217,7 @@ doCaptureStack <- function(e) {
 #' @rdname stacktrace
 #' @export
 withLogErrors <- function(expr,
-  full = getOption("shiny.fullstacktrace", FALSE),
+  full = get_devmode_option("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   withCallingHandlers(
@@ -228,7 +228,9 @@ withLogErrors <- function(expr,
       if (promises::is.promise(result)) {
         result <- promises::catch(result, function(cond) {
           # Don't print shiny.silent.error (i.e. validation errors)
-          if (inherits(cond, "shiny.silent.error")) return()
+          if (cnd_inherits(cond, "shiny.silent.error")) {
+            return()
+          }
           if (isTRUE(getOption("show.error.messages"))) {
             printError(cond, full = full, offset = offset)
           }
@@ -239,7 +241,7 @@ withLogErrors <- function(expr,
     },
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
-      if (inherits(cond, "shiny.silent.error")) return()
+      if (cnd_inherits(cond, "shiny.silent.error")) return()
       if (isTRUE(getOption("show.error.messages"))) {
         printError(cond, full = full, offset = offset)
       }
@@ -264,34 +266,34 @@ withLogErrors <- function(expr,
 #' @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 +303,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 +312,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 +322,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 +331,7 @@ printStackTrace <- function(cond,
       category = rev(getCallCategories(calls[index])),
       stringsAsFactors = FALSE
     )
-    
+
     if (i != 1) {
       message("From earlier call:")
     }
@@ -357,85 +359,10 @@ printStackTrace <- function(cond,
 
     st
   }, SIMPLIFY = FALSE)
-  
+
   invisible()
 }
 
-#' @details `extractStackTrace` takes a list of calls (e.g. as returned
-#'   from `conditionStackTrace(cond)`) and returns a data frame with one
-#'   row for each stack frame and the columns `num` (stack frame number),
-#'   `call` (a function name or similar), and `loc` (source file path
-#'   and line number, if available). It was deprecated after shiny 1.0.5 because
-#'   it doesn't support deep stack traces.
-#' @rdname stacktrace
-#' @export
-extractStackTrace <- function(calls,
-  full = getOption("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-  
-  shinyDeprecated(NULL,
-    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
-    version = "1.0.5")
-
-  srcrefs <- getSrcRefs(calls)
-  if (offset) {
-    # Offset calls vs. srcrefs by 1 to make them more intuitive.
-    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
-    # the definition of foo().
-    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
-  }
-  calls <- setSrcRefs(calls, srcrefs)
-
-  callnames <- getCallNames(calls)
-
-  # Hide and show parts of the callstack based on ..stacktrace(on|off)..
-  if (full) {
-    toShow <- rep.int(TRUE, length(calls))
-  } else {
-    # Remove stop(), .handleSimpleError(), and h() calls from the end of
-    # the calls--they don't add any helpful information. But only remove
-    # the last *contiguous* block of them, and then, only if they are the
-    # last thing in the calls list.
-    hideable <- callnames %in% c("stop", ".handleSimpleError", "h")
-    # What's the last that *didn't* match stop/.handleSimpleError/h?
-    lastGoodCall <- max(which(!hideable))
-    toRemove <- length(calls) - lastGoodCall
-    # But don't remove more than 5 levels--that's an indication we might
-    # have gotten it wrong, I guess
-    if (toRemove > 0 && toRemove < 5) {
-      calls <- utils::head(calls, -toRemove)
-      callnames <- utils::head(callnames, -toRemove)
-    }
-
-    # This uses a ref-counting scheme. It might make sense to switch this
-    # to a toggling scheme, so the most recent ..stacktrace(on|off)..
-    # directive wins, regardless of what came before it.
-    # Also explicitly remove ..stacktraceon.. because it can appear with
-    # score > 0 but still should never be shown.
-    score <- rep.int(0, length(callnames))
-    score[callnames == "..stacktraceoff.."] <- -1
-    score[callnames == "..stacktraceon.."] <- 1
-    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
-
-    # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're
-    # just internals for tryCatch
-    toShow <- toShow & !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList"))
-  }
-  calls <- calls[toShow]
-
-  calls <- rev(calls) # Show in traceback() order
-  index <- rev(which(toShow))
-  width <- floor(log10(max(index))) + 1
-
-  data.frame(
-    num = index,
-    call = getCallNames(calls),
-    loc = getLocs(calls),
-    category = getCallCategories(calls),
-    stringsAsFactors = FALSE
-  )
-}
-
 stripStackTraces <- function(stackTraces, values = FALSE) {
   score <- 1L  # >=1: show, <=0: hide
   lapply(seq_along(stackTraces), function(i) {
@@ -459,19 +386,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,23 +413,32 @@ 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.
+  #
+  # jcheng 2022-03-18: Two more reasons a node can be kept:
+  #   1. parent is 0
+  #   2. parent is i
+  # Not sure why either of these situations happen, but they're common when
+  # interacting with rlang/dplyr errors. See issue rstudio/shiny#3250 for repro
+  # cases.
   include <- vapply(seq_along(parents), function(i) {
-    if (!is_dupe[[i]] && parents[[i]] == current_node) {
+    if ((!is_dupe[[i]] && parents[[i]] == current_node) ||
+        parents[[i]] == 0 ||
+        parents[[i]] == i) {
       current_node <<- i
       TRUE
     } else {
       FALSE
     }
   }, FUN.VALUE = logical(1))
-  
+
   include
 }
 
@@ -515,7 +451,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,48 +466,12 @@ 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 `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),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  shinyDeprecated(NULL,
-    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
-    version = "1.0.5")
-  
-  st <- extractStackTrace(calls, full = full, offset = offset)
-  if (nrow(st) == 0) {
-    return(character(0))
-  }
-
-  width <- floor(log10(max(st$num))) + 1
-  paste0(
-    indent,
-    formatC(st$num, width = width),
-    ": ",
-    mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
-      if (category == "pkg")
-        crayon::silver(name)
-      else if (category == "user")
-        crayon::blue$bold(name)
-      else
-        crayon::white(name)
-    })
-  )
-}
-
 getSrcRefs <- function(calls) {
   lapply(calls, function(call) {
     attr(call, "srcref", exact = TRUE)

R/deprecated.R

@@ -0,0 +1,121 @@
+
+#' 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,
+  type = c("deprecated", "superseded")
+) {
+  if (is_false(getOption("shiny.deprecation.messages"))) {
+    return(invisible())
+  }
+
+  type <- match.arg(type)
+
+  msg <- paste0("`", what, "` is ", type, " 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())
+
+  # Capture calling function
+  grandparent_call <- sys.call(-2)
+  # Turn language into user friendly string
+  grandparent_txt <- paste0(utils::capture.output({grandparent_call}), collapse = "\n")
+
+  msg <- paste0(
+    "The `env` and `quoted` arguments are deprecated as of shiny 1.7.0.",
+    " Please use quosures from `rlang` instead.\n",
+    "See <https://github.com/rstudio/shiny/issues/3108> for more information.\n",
+    "Function call:\n",
+    grandparent_txt
+  )
+  # Call less often as users do not have much control over this warning
+  rlang::inform(message = msg, .frequency = "regularly", .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 (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 (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,363 @@
+#' Shiny Developer Mode
+#'
+#' @description `r lifecycle::badge("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,
+    ...
+  )
+}
+
+
+
+
+registered_devmode_options <- NULL
+on_load({
+  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.
+#' @export
+#' @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
+      )
+    })
+  )
+}
+
+
+on_load({
+  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/extended-task.R

@@ -0,0 +1,206 @@
+#' Task or computation that proceeds in the background
+#'
+#' @description In normal Shiny reactive code, whenever an observer, calc, or
+#'   output is busy computing, it blocks the current session from receiving any
+#'   inputs or attempting to proceed with any other computation related to that
+#'   session.
+#'
+#'   The `ExtendedTask` class allows you to have an expensive operation that is
+#'   started by a reactive effect, and whose (eventual) results can be accessed
+#'   by a regular observer, calc, or output; but during the course of the
+#'   operation, the current session is completely unblocked, allowing the user
+#'   to continue using the rest of the app while the operation proceeds in the
+#'   background.
+#'
+#'   Note that each `ExtendedTask` object does not represent a _single
+#'   invocation_ of its long-running function. Rather, it's an object that is
+#'   used to invoke the function with different arguments, keeps track of
+#'   whether an invocation is in progress, and provides ways to get at the
+#'   current status or results of the operation. A single `ExtendedTask` object
+#'   does not permit overlapping invocations: if the `invoke()` method is called
+#'   before the previous `invoke()` is completed, the new invocation will not
+#'   begin until the previous invocation has completed.
+#'
+#' @section `ExtendedTask` versus asynchronous reactives:
+#'
+#'   Shiny has long supported [using
+#'   \{promises\}](https://rstudio.github.io/promises/articles/promises_06_shiny.html)
+#'   to write asynchronous observers, calcs, or outputs. You may be wondering
+#'   what the differences are between those techniques and this class.
+#'
+#'   Asynchronous observers, calcs, and outputs are not--and have never
+#'   been--designed to let a user start a long-running operation, while keeping
+#'   that very same (browser) session responsive to other interactions. Instead,
+#'   they unblock other sessions, so you can take a long-running operation that
+#'   would normally bring the entire R process to a halt and limit the blocking
+#'   to just the session that started the operation. (For more details, see the
+#'   section on ["The Flush
+#'   Cycle"](https://rstudio.github.io/promises/articles/promises_06_shiny.html#the-flush-cycle).)
+#'
+#'   `ExtendedTask`, on the other hand, invokes an asynchronous function (that
+#'   is, a function that quickly returns a promise) and allows even that very
+#'   session to immediately unblock and carry on with other user interactions.
+#'
+#' @export
+ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
+  public = list(
+    #' @description
+    #' Creates a new `ExtendedTask` object. `ExtendedTask` should generally be
+    #' created either at the top of a server function, or at the top of a module
+    #' server function.
+    #'
+    #' @param func The long-running operation to execute. This should be an
+    #'   asynchronous function, meaning, it should use the
+    #'   [\{promises\}](https://rstudio.github.io/promises/) package, most
+    #'   likely in conjuction with the
+    #'   [\{future\}](https://rstudio.github.io/promises/articles/promises_04_futures.html)
+    #'   package. (In short, the return value of `func` should be a
+    #'   [`Future`][future::future()] object, or a `promise`, or something else
+    #'   that [promises::as.promise()] understands.)
+    #'
+    #'   It's also important that this logic does not read from any
+    #'   reactive inputs/sources, as inputs may change after the function is
+    #'   invoked; instead, if the function needs to access reactive inputs, it
+    #'   should take parameters and the caller of the `invoke()` method should
+    #'   read reactive inputs and pass them as arguments.
+    initialize = function(func) {
+      private$func <- func
+      private$rv_status <- reactiveVal("initial")
+      private$rv_value <- reactiveVal(NULL)
+      private$rv_error <- reactiveVal(NULL)
+      private$invocation_queue <- fastmap::fastqueue()
+    },
+    #' @description
+    #' Starts executing the long-running operation. If this `ExtendedTask` is
+    #' already running (meaning, a previous call to `invoke()` is not yet
+    #' complete) then enqueues this invocation until after the current
+    #' invocation, and any already-enqueued invocation, completes.
+    #'
+    #' @param ... Parameters to use for this invocation of the underlying
+    #'   function. If reactive inputs are needed by the underlying function,
+    #'   they should be read by the caller of `invoke` and passed in as
+    #'   arguments.
+    invoke = function(...) {
+      args <- rlang::dots_list(..., .ignore_empty = "none")
+
+      if (
+        isolate(private$rv_status()) == "running" ||
+          private$invocation_queue$size() > 0
+      ) {
+        private$invocation_queue$add(args)
+      } else {
+        private$do_invoke(args)
+      }
+      invisible(NULL)
+    },
+    #' @description
+    #' This is a reactive read that invalidates the caller when the task's
+    #' status changes.
+    #'
+    #' Returns one of the following values:
+    #'
+    #' * `"initial"`: This `ExtendedTask` has not yet been invoked
+    #' * `"running"`: An invocation is currently running
+    #' * `"success"`: An invocation completed successfully, and a value can be
+    #'   retrieved via the `result()` method
+    #' * `"error"`: An invocation completed with an error, which will be
+    #'   re-thrown if you call the `result()` method
+    status = function() {
+      private$rv_status()
+    },
+    #' @description
+    #' Attempts to read the results of the most recent invocation. This is a
+    #' reactive read that invalidates as the task's status changes.
+    #'
+    #' The actual behavior differs greatly depending on the current status of
+    #' the task:
+    #'
+    #' * `"initial"`: Throws a silent error (like [`req(FALSE)`][req()]). If
+    #'   this happens during output rendering, the output will be blanked out.
+    #' * `"running"`: Throws a special silent error that, if it happens during
+    #'   output rendering, makes the output appear "in progress" until further
+    #'   notice.
+    #' * `"success"`: Returns the return value of the most recent invocation.
+    #' * `"error"`: Throws whatever error was thrown by the most recent
+    #'   invocation.
+    #'
+    #' This method is intended to be called fairly naively by any output or
+    #' reactive expression that cares about the output--you just have to be
+    #' aware that if the result isn't ready for whatever reason, processing will
+    #' stop in much the same way as `req(FALSE)` does, but when the result is
+    #' ready you'll get invalidated, and when you run again the result should be
+    #' there.
+    #'
+    #' Note that the `result()` method is generally not meant to be used with
+    #' [observeEvent()], [eventReactive()], [bindEvent()], or [isolate()] as the
+    #' invalidation will be ignored.
+    result = function() {
+      switch (private$rv_status(),
+        running = req(FALSE, cancelOutput="progress"),
+        success = if (private$rv_value()$visible) {
+          private$rv_value()$value
+        } else {
+          invisible(private$rv_value()$value)
+        },
+        error = stop(private$rv_error()),
+        # default case (initial, cancelled)
+        req(FALSE)
+      )
+    }
+  ),
+  private = list(
+    func = NULL,
+    # reactive value with "initial"|"running"|"success"|"error"
+    rv_status = NULL,
+    rv_value = NULL,
+    rv_error = NULL,
+    invocation_queue = NULL,
+
+    do_invoke = function(args) {
+      private$rv_status("running")
+      private$rv_value(NULL)
+      private$rv_error(NULL)
+
+      p <- NULL
+      tryCatch({
+        maskReactiveContext({
+          # TODO: Bounce the do.call off of a promise_resolve(), so that the
+          # call to invoke() always returns immediately?
+          result <- do.call(private$func, args)
+          p <- promises::as.promise(result)
+        })
+      }, error = function(e) {
+        private$on_error(e)
+      })
+
+      promises::finally(
+        promises::then(p,
+          onFulfilled = function(value, .visible) {
+            private$on_success(list(value=value, visible=.visible))
+          },
+          onRejected = function(error) {
+            private$on_error(error)
+          }
+        ),
+        onFinally = function() {
+          if (private$invocation_queue$size() > 0) {
+            private$do_invoke(private$invocation_queue$remove())
+          }
+        }
+      )
+
+
+      invisible(NULL)
+    },
+
+    on_error = function(err) {
+      private$rv_status("error")
+      private$rv_error(err)
+    },
+
+    on_success = function(value) {
+      private$rv_status("success")
+      private$rv_value(value)
+    }
+  )
+)

R/font-awesome.R

@@ -1,445 +0,0 @@
-font_awesome_brands <- c(
-  "500px",
-  "accessible-icon",
-  "accusoft",
-  "acquisitions-incorporated",
-  "adn",
-  "adobe",
-  "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",
-  "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",
-  "delicious",
-  "deploydog",
-  "deskpro",
-  "dev",
-  "deviantart",
-  "dhl",
-  "diaspora",
-  "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",
-  "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-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",
-  "ideal",
-  "imdb",
-  "instagram",
-  "instagram-square",
-  "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",
-  "odnoklassniki",
-  "odnoklassniki-square",
-  "old-republic",
-  "opencart",
-  "openid",
-  "opera",
-  "optin-monster",
-  "orcid",
-  "osi",
-  "page4",
-  "pagelines",
-  "palfed",
-  "patreon",
-  "paypal",
-  "penny-arcade",
-  "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",
-  "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",
-  "trade-federation",
-  "trello",
-  "tripadvisor",
-  "tumblr",
-  "tumblr-square",
-  "twitch",
-  "twitter",
-  "twitter-square",
-  "typo3",
-  "uber",
-  "ubuntu",
-  "uikit",
-  "umbraco",
-  "uniregistry",
-  "unity",
-  "untappd",
-  "ups",
-  "usb",
-  "usps",
-  "ussunnah",
-  "vaadin",
-  "viacoin",
-  "viadeo",
-  "viadeo-square",
-  "viber",
-  "vimeo",
-  "vimeo-square",
-  "vimeo-v",
-  "vine",
-  "vk",
-  "vnv",
-  "vuejs",
-  "waze",
-  "weebly",
-  "weibo",
-  "weixin",
-  "whatsapp",
-  "whatsapp-square",
-  "whmcs",
-  "wikipedia-w",
-  "windows",
-  "wix",
-  "wizards-of-the-coast",
-  "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,70 +1,27 @@
 # 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))
 
+  for (expr in on_load_exprs) {
+    eval(expr, envir = environment(.onLoad))
+  }
+
   # 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)
+  s3_register("knitr::knit_print", "reactive")
+  s3_register("knitr::knit_print", "shiny.appobj")
+  s3_register("knitr::knit_print", "shiny.render.function")
+}
+
+
+on_load_exprs <- list()
+# Register an expression to be evaluated when the package is loaded (in the
+# .onLoad function).
+on_load <- function(expr) {
+  on_load_exprs[[length(on_load_exprs) + 1]] <<- substitute(expr)
 }

R/graph.R

@@ -1,31 +1,3 @@
-# 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 = NULL) {
-
-  if (is_available(package, version)) {
-    return()
-  }
-
-  msg <- paste0(
-    sQuote(package),
-    if (is.na(version %OR% NA)) "" else paste0("(>= ", version, ")"),
-    " must be installed for this functionality."
-  )
-
-  if (interactive()) {
-    message(msg, "\nWould you like to install it?")
-    if (utils::menu(c("Yes", "No")) == 1) {
-      return(utils::install.packages(package))
-    }
-  }
-
-  stop(msg, call. = FALSE)
-}
-
-
-
 
 # domain is like session
 
@@ -87,19 +59,14 @@ reactlog <- function() {
 }
 
 #' @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 [reactlogShow()]
-#' @export
-# legacy purposes
-showReactLog <- function(time = TRUE) {
-  shinyDeprecated(new = "`reactlogShow`", version = "1.2.0")
-  reactlogShow(time = time)
-}
+
 #' @describeIn reactlog Resets the entire reactlog stack.  Useful for debugging and removing all prior reactive history.
 #' @export
 reactlogReset <- function() {
@@ -115,28 +82,15 @@ renderReactlog <- function(sessionToken = NULL, time = TRUE) {
     time = time
   )
 }
+
 check_reactlog <- function() {
-  check_suggested("reactlog", reactlog_version())
-}
-# read reactlog version from description file
-# prevents version mismatch in code and description file
-reactlog_version <- function() {
-  desc <- read.dcf(system.file("DESCRIPTION", package = "shiny", mustWork = TRUE))
-  suggests <- desc[1,"Suggests"][[1]]
-  suggests_pkgs <- strsplit(suggests, "\n")[[1]]
-
-  reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
-  if (length(reactlog_info) == 0) {
-    stop("reactlog can not be found in shiny DESCRIPTION file")
+  if (!is_installed("reactlog", reactlog_min_version)) {
+    rlang::check_installed("reactlog", reactlog_min_version)
   }
-
-  reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
-  reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
-  reactlog_info <- sub("^[>= ]*", "", reactlog_info)
-
-  package_version(reactlog_info)
 }
 
+# Should match the (suggested) version in DESCRIPTION file
+reactlog_min_version <- "1.0.0"
 
 RLog <- R6Class(
   "RLog",
@@ -179,10 +133,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)
@@ -210,7 +164,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
@@ -517,7 +471,7 @@ MessageLogger = R6Class(
       return(txt)
     },
     singleLine = function(txt) {
-      gsub("[^\\]\\n", "\\\\n", txt)
+      gsub("([^\\])\\n", "\\1\\\\n", txt)
     },
     valueStr = function(valueStr) {
       paste0(
@@ -558,5 +512,6 @@ MessageLogger = R6Class(
   )
 )
 
-#' @include stack.R
-rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")
+on_load({
+  rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")
+})

R/history.R

@@ -14,7 +14,7 @@ NULL
 #' depending on the values in the query string / hash (e.g. instead of basing
 #' the conditional on an input or a calculated reactive, you can base it on the
 #' query string). However, note that, if you're changing the query string / hash
-#' programatically from within the server code, you must use
+#' programmatically from within the server code, you must use
 #' `updateQueryString(_yourNewQueryString_, mode = "push")`. The default
 #' `mode` for `updateQueryString` is `"replace"`, which doesn't
 #' raise any events, so any observers or reactives that depend on it will

R/html-deps.R

@@ -40,11 +40,14 @@ createWebDependency <- function(dependency, scrubFile = TRUE) {
 
 # Given a Shiny tag object, process singletons and dependencies. Returns a list
 # with rendered HTML and dependency objects.
+# This implementation is very similar to renderTags(), but ignores
+# <head> handling (it should only be used after the user session has started)
 processDeps <- function(tags, session) {
-  ui <- takeSingletons(tags, session$singletons, desingleton=FALSE)$ui
+  tags <- utils::getFromNamespace("tagify", "htmltools")(tags)
+  ui <- takeSingletons(tags, session$singletons, desingleton = FALSE)$ui
   ui <- surroundSingletons(ui)
   dependencies <- lapply(
-    resolveDependencies(findDependencies(ui)),
+    resolveDependencies(findDependencies(ui, tagify = FALSE)),
     createWebDependency
   )
   names(dependencies) <- NULL

R/htmltools.R

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

R/image-interact-opts.R

@@ -1,14 +1,24 @@
-#' Create an object representing click options
+#' Control interactive plot point events
 #'
-#' This generates an object representing click options, to be passed as the
-#' `click` argument of [imageOutput()] or
-#' [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 `"plot_click"`,
-#'   then the click coordinates will be available as `input$plot_click`.
-#' @param clip Should the click area be clipped to the plotting area? If FALSE,
-#'   then the server will receive click events even when the mouse is outside
-#'   the plotting area, as long as it is still inside the image.
+#'   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, clip = TRUE) {
   if (is.null(id))
@@ -21,21 +31,8 @@ clickOpts <- function(id, clip = TRUE) {
 }
 
 
-#' Create an object representing double-click options
-#'
-#' This generates an object representing dobule-click options, to be passed as
-#' the `dblclick` argument of [imageOutput()] or
-#' [plotOutput()].
-#'
-#' @param id Input value name. For example, if the value is
-#'   `"plot_dblclick"`, then the click coordinates will be available as
-#'   `input$plot_dblclick`.
-#' @param clip Should the click area be clipped to the plotting area? If FALSE,
-#'   then the server will receive double-click events even when the mouse is
-#'   outside the plotting area, as long as it is still inside the image.
-#' @param delay Maximum delay (in ms) between a pair clicks for them to be
-#'   counted as a double-click.
 #' @export
+#' @rdname clickOpts
 dblclickOpts <- function(id, clip = TRUE, delay = 400) {
   if (is.null(id))
     stop("id must not be NULL")
@@ -47,28 +44,11 @@ dblclickOpts <- function(id, clip = TRUE, delay = 400) {
   )
 }
 
-#' Create an object representing hover options
-#'
-#' This generates an object representing hovering options, to be passed as the
-#' `hover` argument of [imageOutput()] or
-#' [plotOutput()].
-#'
-#' @param id Input value name. For example, if the value is `"plot_hover"`,
-#'   then the hover coordinates will be available as `input$plot_hover`.
-#' @param delay How long to delay (in milliseconds) when debouncing or
-#'   throttling, before sending the mouse location to the server.
-#' @param delayType The type of algorithm for limiting the number of hover
-#'   events. Use `"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.
-#' @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 `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
+#' @rdname clickOpts
 hoverOpts <- function(id, delay = 300,
                       delayType = c("debounce", "throttle"), clip = TRUE,
                       nullOutside = TRUE) {
@@ -95,8 +75,12 @@ hoverOpts <- function(id, delay = 300,
 #'   `imageOutput`/`plotOutput` calls may share the same `id`
 #'   value; brushing one image or plot will cause any other brushes with the
 #'   same `id` to disappear.
-#' @param fill Fill color of the brush.
-#' @param stroke Outline color of the brush.
+#' @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.
@@ -116,6 +100,7 @@ hoverOpts <- function(id, delay = 300,
 #'   `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, fill = "#9cf", stroke = "#036",
                       opacity = 0.25, delay = 300,
@@ -125,6 +110,13 @@ brushOpts <- function(id, 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 +129,13 @@ brushOpts <- function(id, 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

@@ -92,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))
@@ -172,8 +182,8 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ xmax     : num 3.78
 #  $ ymin     : num 17.1
 #  $ ymax     : num 20.4
-#  $ panelvar1: int 6
-#  $ panelvar2: int 0
+#  $ panelvar1: chr "6"
+#  $ panelvar2: chr "0
 #  $ coords_css:List of 4
 #   ..$ xmin: int 260
 #   ..$ xmax: int 298
@@ -230,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")
@@ -247,6 +267,7 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
     stop("nearPoints: `yvar` ('", yvar ,"')  not in names of input")
 
   # Extract data values from the data frame
+  coordinfo <- fortifyDiscreteLimits(coordinfo)
   x <- asNumber(df[[xvar]], coordinfo$domain$discrete_limits$x)
   y <- asNumber(df[[yvar]], coordinfo$domain$discrete_limits$y)
 
@@ -346,8 +367,8 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 #  $ img_css_ratio:List of 2
 #   ..$ x: num 1.25
 #   ..$ y: num 1.25
-#  $ panelvar1 : int 6
-#  $ panelvar2 : int 0
+#  $ panelvar1 : chr "6"
+#  $ panelvar2 : chr "0"
 #  $ mapping   :List of 4
 #   ..$ x        : chr "wt"
 #   ..$ y        : chr "mpg"
@@ -372,6 +393,7 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 # an input brush
 within_brush <- function(vals, brush, var = "x") {
   var <- match.arg(var, c("x", "y"))
+  brush <- fortifyDiscreteLimits(brush)
   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:
@@ -394,11 +416,43 @@ asNumber <- function(x, levels = NULL) {
   as.numeric(x)
 }
 
+# Ensure the discrete limits/levels of a coordmap received
+# from the client matches the data structure sent the client.
+#
+# When we construct the coordmap (in getGgplotCoordmap()),
+# we save a character vector which may contain missing values
+# (e.g., c("a", "b", NA)). When that same character is received
+# from the client, it runs through decodeMessage() which sets
+# simplifyVector=FALSE, which means NA are replaced by NULL
+# (because jsonlite::fromJSON('["a", "b", null]') -> list("a", "b", NULL))
+#
+# Thankfully, it doesn't seem like it's meaningful for limits to
+# contains a NULL in the 1st place, so we simply treat NULL like NA.
+# For more context, https://github.com/rstudio/shiny/issues/2666
+fortifyDiscreteLimits <- function(coord) {
+  # Note that discrete_limits$x/y are populated iff
+  # x/y are discrete mappings
+  coord$domain$discrete_limits <- lapply(
+    coord$domain$discrete_limits,
+    function(var) {
+      # if there is an 'explicit' NULL, then the limits are NA
+      if (is.null(var)) return(NA)
+      vapply(var, function(x) {
+        if (is.null(x) || isTRUE(is.na(x))) NA_character_ else x
+      }, character(1))
+    }
+  )
+  coord
+}
+
+
+
 # Given a panelvar value and a vector x, return logical vector indicating which
 # items match the panelvar value. Because the panelvar value is always a
 # string but the vector could be numeric, it might be necessary to coerce the
 # panelvar to a number before comparing to the vector.
 panelMatch <- function(search_value, x) {
+  if (is.null(search_value)) return(is.na(x))
   if (is.numeric(x)) search_value <- as.numeric(search_value)
   x == search_value
 }

R/imageutils.R

@@ -1,30 +1,30 @@
 startPNG <- function(filename, width, height, res, ...) {
-  # 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') %OR% FALSE) && is_available("ragg")) {
-    pngfun <- ragg::agg_png
+  pngfun <- if ((getOption('shiny.useragg') %||% TRUE) && is_installed("ragg")) {
+    ragg::agg_png
   } else if (capabilities("aqua")) {
     # i.e., png(type = 'quartz')
-    pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) && is_available("Cairo")) {
-    pngfun <- Cairo::CairoPNG
+    grDevices::png
+  } else if ((getOption('shiny.usecairo') %||% TRUE) && is_installed("Cairo")) {
+    Cairo::CairoPNG
   } else {
     # i.e., png(type = 'cairo')
-    pngfun <- grDevices::png
+    grDevices::png
   }
 
-  args <- rlang::list2(filename=filename, width=width, height=height, res=res, ...)
+  args <- list2(filename = filename, width = width, height = height, res = res, ...)
+
+  # It's possible for width/height to be NULL/numeric(0) (e.g., when using
+  # suspendWhenHidden=F w/ tabsetPanel(), see rstudio/shiny#1409), so when
+  # this happens let the device determine what the default size should be.
+  if (length(args$width) == 0) args$width <- NULL
+  if (length(args$height) == 0) args$height <- NULL
 
   # 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")) {
-    # TODO: use :: once thematic is on CRAN
-    args$bg <- utils::getFromNamespace("thematic_get_option", "thematic")("bg", "white")
+    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"]]()
@@ -58,33 +58,35 @@ startPNG <- function(filename, width, height, res, ...) {
   grDevices::dev.cur()
 }
 
-#' Run a plotting function and save the output as a PNG
+#' Capture a plot as a PNG file.
 #'
-#' This function returns the name of the PNG file that it generates. In
-#' essence, it calls `png()`, then `func()`, then `dev.off()`.
-#' So `func` must be a function that will generate a plot when used this
-#' way.
+#' The PNG graphics device used is determined in the following order:
+#'   * If the ragg package is installed (and the `shiny.useragg` is not
+#'    set to `FALSE`), then use [ragg::agg_png()].
+#'   * If a quartz device is available (i.e., `capabilities("aqua")` is
+#'    `TRUE`), then use `png(type = "quartz")`.
+#'   * If the Cairo package is installed (and the `shiny.usecairo` option
+#'    is not set to `FALSE`), then use [Cairo::CairoPNG()].
+#'   * Otherwise, use [grDevices::png()]. In this case, Linux and Windows
+#'    may not antialias some point shapes, resulting in poor quality output.
 #'
-#' For output, it will try to use the following devices, in this order:
-#' quartz (via [grDevices::png()]), then [Cairo::CairoPNG()],
-#' and finally [grDevices::png()]. This is in order of quality of
-#' output. Notably, plain `png` output on Linux and Windows may not
-#' antialias some point shapes, resulting in poor quality output.
-#'
-#' In some cases, `Cairo()` provides output that looks worse than
-#' `png()`. To disable Cairo output for an app, use
-#' `options(shiny.usecairo=FALSE)`.
+#' @details
+#'   A `NULL` value provided to `width` or `height` is ignored (i.e., the
+#'   default `width` or `height` of the graphics device is used).
 #'
 #' @param func A function that generates a plot.
 #' @param filename The name of the output file. Defaults to a temp file with
 #'   extension `.png`.
 #' @param width Width in pixels.
 #' @param height Height in pixels.
-#' @param res Resolution in pixels per inch. This value is passed to
-#'   [grDevices::png()]. Note that this affects the resolution of PNG rendering in
+#' @param res Resolution in pixels per inch. This value is passed to the
+#'   graphics device. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
-#' @param ... Arguments to be passed through to [grDevices::png()].
-#'   These can be used to set the width, height, background color, etc.
+#' @param ... Arguments to be passed through to the graphics device. These can
+#'   be used to set the width, height, background color, etc.
+#'
+#' @return A path to the newly generated PNG file.
+#'
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
@@ -95,7 +97,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

@@ -7,6 +7,8 @@
 #' @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 [icon()] to appear on the button.
+#' @param disabled If `TRUE`, the button will not be clickable. Use
+#'   [updateActionButton()] to dynamically enable/disable the button.
 #' @param ... Named attributes to be applied to the button or link.
 #'
 #' @family input elements
@@ -49,15 +51,17 @@
 #'   * 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, ...) {
+actionButton <- function(inputId, label, icon = NULL, width = NULL,
+  disabled = FALSE, ...) {
 
   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,
+    disabled = if (isTRUE(disabled)) NA else NULL,
     list(validateIcon(icon), label),
     ...
   )

R/input-checkbox.R

@@ -31,12 +31,12 @@ checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
 
   value <- restoreInput(id = inputId, default = value)
 
-  inputTag <- tags$input(id = inputId, type="checkbox")
+  inputTag <- tags$input(id = inputId, type="checkbox", class = "shiny-input-checkbox")
   if (!is.null(value) && value)
     inputTag$attribs$checked <- "checked"
 
   div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
     div(class = "checkbox",
       tags$label(inputTag, tags$span(label))
     )

R/input-checkboxgroup.R

@@ -94,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,
-    shinyInputLabel(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

@@ -105,11 +105,15 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
 
   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)),
 
     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>"
-)
+
+datePickerDependency <- function(theme) {
+  list(
+    htmlDependency(
+      name = "bootstrap-datepicker-js",
+      version = version_bs_date_picker,
+      src = "www/shared/datepicker",
+      package = "shiny",
+      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 = version_bs_date_picker,
+      src = "www/shared/datepicker",
+      package = "shiny",
+      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 = version_bs_date_picker,
+    cache_key_extra = get_package_version("shiny")
+  )
+}

R/input-daterange.R

@@ -92,7 +92,7 @@ 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)),
 
       shinyInputLabel(inputId, label),
       # input-daterange class is needed for dropdown behavior
@@ -100,6 +100,10 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
         tags$input(
           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,
@@ -118,6 +122,10 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
         tags$input(
           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,
@@ -129,6 +137,6 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
         )
       )
     ),
-    datePickerDependency
+    datePickerDependency()
   )
 }

R/input-file.R

@@ -2,8 +2,13 @@
 #'
 #' 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. See the `Server value` section.
+#' Whenever a file upload completes, the corresponding input variable is set to
+#' a dataframe. See the `Server value` section.
+#'
+#' Each time files are uploaded, they are written to a new random subdirectory
+#' inside of R's process-level temporary directory. The Shiny user session keeps
+#' track of all uploads in the session, and when the session ends, Shiny deletes
+#' all of the subdirectories where files where uploaded to.
 #'
 #' @family input elements
 #'
@@ -11,19 +16,30 @@
 #' @param multiple Whether the user should be allowed to select and upload
 #'   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.
+#' @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.
+#'   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.
+#' @param capture What source to use for capturing image, audio or video data.
+#'   This attribute facilitates user access to a device's media capture
+#'   mechanism, such as a camera, or microphone, from within a file upload
+#'   control.
 #'
+#'   A value of `user` indicates that the user-facing camera and/or microphone
+#'   should be used. A value of `environment` specifies that the outward-facing
+#'   camera and/or microphone should be used.
+#'
+#'   By default on most phones, this will accept still photos or video. For
+#'   still photos only, also use `accept="image/*"`. For video only, use
+#'   `accept="video/*"`.
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
@@ -56,7 +72,9 @@
 #' }
 #'
 #' @section Server value:
-#' A `data.frame` that contains one row for each selected file, and following columns:
+#'
+#'   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
@@ -73,7 +91,8 @@
 #'
 #' @export
 fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
-  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
+  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected",
+  capture = NULL) {
 
   restoredValue <- restoreInput(id = inputId, default = NULL)
 
@@ -89,9 +108,11 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
 
   inputTag <- tags$input(
     id = inputId,
+    class = "shiny-input-file",
     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
   )
 
@@ -100,9 +121,12 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
   if (length(accept) > 0)
     inputTag$attribs$accept <- paste(accept, collapse=',')
 
+  if (!is.null(capture)) {
+    inputTag$attribs$capture <- capture
+  }
 
   div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
 
     div(class = "input-group",

R/input-numeric.R

@@ -35,7 +35,7 @@ numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
   value <- restoreInput(id = inputId, default = value)
 
   # build input tag
-  inputTag <- tags$input(id = inputId, type = "number", class="form-control",
+  inputTag <- tags$input(id = inputId, type = "number", class="shiny-input-number form-control",
                          value = formatNoSci(value))
   if (!is.na(min))
     inputTag$attribs$min = min
@@ -45,7 +45,7 @@ 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), ";"),
+    style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
     inputTag
   )

R/input-password.R

@@ -33,9 +33,9 @@
 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), ";"),
+    style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
-    tags$input(id = inputId, type="password", class="form-control", value=value,
+    tags$input(id = inputId, type="password", class="shiny-input-password form-control", value=value,
                placeholder = placeholder)
   )
 }

R/input-radiobuttons.R

@@ -11,22 +11,22 @@
 #' @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 `choiceNames` and `choiceValues`
-#'   must not be provided, and vice-versa. The values should be strings; other
-#'   types (such as logicals and numbers) will be coerced to strings.
-#' @param selected The initially selected value (if not specified then defaults
-#'   to the first value)
+#'   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, `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.
+#'   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 [updateRadioButtons()]
@@ -82,7 +82,8 @@
 #' }
 #'
 #' @section Server value:
-#' A character string containing the value of the selected button.
+#'
+#'   A character string containing the value of the selected button.
 #'
 #' @export
 radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
@@ -103,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,
-    shinyInputLabel(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

@@ -4,7 +4,7 @@
 #' from a list of values.
 #'
 #' By default, `selectInput()` and `selectizeInput()` use the JavaScript library
-#' \pkg{selectize.js} (<https://github.com/selectize/selectize.js>) instead of
+#' \pkg{selectize.js} (<https://selectize.dev/>) instead of
 #' the basic select input element. To use the standard HTML select input
 #' element, use `selectInput()` with `selectize=FALSE`.
 #'
@@ -12,6 +12,14 @@
 #' 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
@@ -98,9 +106,10 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   # create select tag and add options
   selectTag <- tags$select(
     id = inputId,
+    class = "shiny-input-select",
     class = if (!selectize) "form-control",
     size = size,
-    selectOptions(choices, selected)
+    selectOptions(choices, selected, inputId, selectize)
   )
   if (multiple)
     selectTag$attribs$multiple <- "multiple"
@@ -108,7 +117,7 @@ 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), ";"),
+    style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
     div(selectTag)
   )
@@ -125,16 +134,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 {
@@ -158,7 +173,7 @@ needOptgroup <- function(choices) {
 
 #' @rdname selectInput
 #' @param ... Arguments passed to `selectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#' @param options A list of options. See the documentation of \pkg{selectize.js}(<https://selectize.dev/docs/usage>)
 #'   for possible options (character option values inside [base::I()] will
 #'   be treated as literal JavaScript code; see [renderDataTable()]
 #'   for details).
@@ -183,24 +198,23 @@ 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[[length(deps) + 1]] <- jqueryuiDependency()
   }
 
   # Insert script on same level as <select> tag
@@ -210,18 +224,68 @@ 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) {
+  if (!is_bs_theme(theme)) {
+    return(selectizeStaticDependency(version_selectize))
+  }
 
+  selectizeDir <- system_file(package = "shiny", "www/shared/selectize/")
+  bs_version <- bslib::theme_version(theme)
+  stylesheet <- file.path(
+    selectizeDir, "scss", paste0("selectize.bootstrap", bs_version, ".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, selectizeScripts())
 
+  bslib::bs_dependency(
+    input = sass::sass_file(stylesheet),
+    theme = theme,
+    name = "selectize",
+    version = version_selectize,
+    cache_key_extra = get_package_version("shiny"),
+    .dep_args = list(script = script)
+  )
+}
 
+selectizeStaticDependency <- function(version) {
+  htmlDependency(
+    "selectize",
+    version,
+    src = "www/shared/selectize",
+    package = "shiny",
+    stylesheet = "css/selectize.bootstrap3.css",
+    script = selectizeScripts()
+  )
+}
+
+selectizeScripts <- function() {
+  isMinified <- isTRUE(get_devmode_option("shiny.minified", TRUE))
+  paste0(
+    c(
+      "js/selectize",
+      "accessibility/js/selectize-plugin-a11y"
+    ),
+    if (isMinified) ".min.js" else ".js"
+  )
+}
 
 
 #' Select variables from a data frame
@@ -231,7 +295,7 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 #'
 #' By default, `varSelectInput()` and `selectizeInput()` use the
 #' JavaScript library \pkg{selectize.js}
-#' (<https://github.com/selectize/selectize.js>) to instead of the basic
+#' (<https://selectize.dev/>) to instead of the basic
 #' select input element. To use the standard HTML select input element, use
 #' `selectInput()` with `selectize=FALSE`.
 #'
@@ -327,7 +391,7 @@ varSelectInput <- function(
 
 #' @rdname varSelectInput
 #' @param ... Arguments passed to `varSelectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#' @param options A list of options. See the documentation of \pkg{selectize.js}(<https://selectize.dev/docs/usage>)
 #'   for possible options (character option values inside [base::I()] will
 #'   be treated as literal JavaScript code; see [renderDataTable()]
 #'   for details).

R/input-slider.R

@@ -1,25 +1,24 @@
 #' 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 `min` and `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 `NULL`, a heuristic is used to determine the step size). If
-#'   the values are dates, `step` is in days; if the values are times
-#'   (POSIXt), `step` is in seconds.
+#'   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 `FALSE` to hide tick marks, `TRUE` to show them
 #'   according to some simple heuristics.
 #' @param animate `TRUE` to show simple animation controls with default
@@ -72,23 +71,15 @@
 #' }
 #'
 #' @section Server value:
-#' A number, or in the case of slider range, a vector of two numbers.
+#' 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) {
+  validate_slider_value(min, max, value, "sliderInput")
 
   dataType <- getSliderType(min, max, value)
 
@@ -144,6 +135,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),
@@ -175,7 +167,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   })
 
   sliderTag <- div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+    style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
     do.call(tags$input, sliderProps)
   )
@@ -205,20 +197,54 @@ 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")
-    ),
-    htmlDependency("strftime", "0.9.2", c(href="shared/strftime"),
-      script = "strftime-min.js"
-    )
-  )
+  attachDependencies(sliderTag, ionRangeSliderDependency())
+}
 
-  attachDependencies(sliderTag, dep)
+
+ionRangeSliderDependency <- function() {
+  list(
+    # ion.rangeSlider also needs normalize.css, which is already included in Bootstrap.
+    htmlDependency(
+      "ionrangeslider-javascript",
+      version_ion_range_slider,
+      src = "www/shared/ionrangeslider",
+      package = "shiny",
+      script = "js/ion.rangeSlider.min.js"
+    ),
+    htmlDependency(
+      "strftime",
+      version_strftime,
+      src = "www/shared/strftime",
+      package = "shiny",
+      script = "strftime-min.js"
+    ),
+    bslib::bs_dependency_defer(ionRangeSliderDependencyCSS)
+  )
+}
+
+ionRangeSliderDependencyCSS <- function(theme) {
+  if (!is_bs_theme(theme)) {
+    return(htmlDependency(
+      "ionrangeslider-css",
+      version_ion_range_slider,
+      src = "www/shared/ionrangeslider",
+      package = "shiny",
+      stylesheet = "css/ion.rangeSlider.css"
+    ))
+  }
+
+  bslib::bs_dependency(
+    input = list(
+      list(accent = "$component-active-bg"),
+      sass::sass_file(
+        system_file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss")
+      )
+    ),
+    theme = theme,
+    name = "ionRangeSlider",
+    version = version_ion_range_slider,
+    cache_key_extra = get_package_version("shiny")
+  )
 }
 
 hasDecimals <- function(value) {
@@ -226,7 +252,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)
@@ -253,6 +278,37 @@ 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 (length(min)   != 1 || is_na(min) ||
+      length(max)   != 1 || is_na(max) ||
+      length(value) <  1 || length(value) > 2 || any(is.na(value)))
+  {
+    stop(call. = FALSE,
+      sprintf("In %s(): `min`, `max`, and `value` cannot be NULL, NA, or empty.", fun)
+    )
+  }
+
+  if (min(value) < min) {
+    warning(call. = FALSE,
+      sprintf(
+        "In %s(): `value` should be greater than or equal to `min` (value = %s, min = %s).",
+        fun, paste(value, collapse = ", "), min
+      )
+    )
+  }
+
+  if (max(value) > max) {
+    warning(
+      noBreaks. = TRUE, call. = FALSE,
+      sprintf(
+        "In %s(): `value` should be less than or equal to `max` (value = %s, max = %s).",
+        fun, paste(value, collapse = ", "), max
+      )
+    )
+  }
+}
+
 
 #' @rdname sliderInput
 #'

R/input-submit.R

@@ -10,7 +10,7 @@
 #' [actionButton()] instead of `submitButton` when you
 #' want to delay a reaction.
 #' See [this
-#' article](http://shiny.rstudio.com/articles/action-buttons.html) for more information (including a demo of how to "translate"
+#' 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
@@ -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

@@ -40,9 +40,9 @@ 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), ";"),
+    style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
-    tags$input(id = inputId, type="text", class="form-control", value=value,
+    tags$input(id = inputId, type="text", class="shiny-input-text form-control", value=value,
       placeholder = placeholder)
   )
 }

R/input-textarea.R

@@ -50,21 +50,19 @@ 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)) "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",
     shinyInputLabel(inputId, label),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     tags$textarea(
       id = inputId,
-      class = "form-control",
+      class = "shiny-input-textarea form-control",
       placeholder = placeholder,
       style = style,
       rows = rows,

R/input-utils.R

@@ -3,6 +3,8 @@ shinyInputLabel <- function(inputId, label = NULL) {
     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
   )
 }
@@ -39,7 +41,7 @@ normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
     if (length(choiceNames) != length(choiceValues)) {
       stop("`choiceNames` and `choiceValues` must have the same length.")
     }
-    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
+    if (any_named(choiceNames) || any_named(choiceValues)) {
       stop("`choiceNames` and `choiceValues` must not be named.")
     }
   } else {

R/insert-tab.R

@@ -112,35 +112,13 @@
 #'
 #' }
 #' @export
-insertTab <- function(inputId, tab, target,
-                      position = c("before", "after"), select = FALSE,
+insertTab <- function(inputId, tab, target = NULL,
+                      position = c("after", "before"), select = FALSE,
                       session = getDefaultReactiveDomain()) {
-  force(target)
-  force(select)
-  position <- match.arg(position)
-  inputId <- session$ns(inputId)
-
-  # Barbara -- August 2017
-  # Note: until now, the number of tabs in a tabsetPanel (or navbarPage
-  # or navlistPanel) was always fixed. So, an easy way to give an id to
-  # a tab was simply incrementing a counter. (Just like it was easy to
-  # give a random 4-digit number to identify the tabsetPanel). Since we
-  # can only know this in the client side, we'll just pass `id` and
-  # `tsid` (TabSetID) as dummy values that will be fixed in the JS code.
-  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
-    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
-
-  callback <- function() {
-    session$sendInsertTab(
-      inputId = inputId,
-      liTag = processDeps(item$liTag, session),
-      divTag = processDeps(item$divTag, session),
-      menuName = NULL,
-      target = target,
-      position = position,
-      select = select)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_insert(
+    inputId, tab, target,
+    match.arg(position), select, session
+  )
 }
 
 #' @param menuName This argument should only be used when you want to
@@ -159,63 +137,21 @@ insertTab <- function(inputId, tab, target,
 #' @export
 prependTab <- function(inputId, tab, select = FALSE, menuName = NULL,
                        session = getDefaultReactiveDomain()) {
-  force(select)
-  force(menuName)
-  inputId <- session$ns(inputId)
-
-  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
-    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
-
-  callback <- function() {
-    session$sendInsertTab(
-      inputId = inputId,
-      liTag = processDeps(item$liTag, session),
-      divTag = processDeps(item$divTag, session),
-      menuName = menuName,
-      target = NULL,
-      position = "after",
-      select = select)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_prepend(inputId, tab, menu_title = menuName, select = select, session = session)
 }
 
 #' @rdname insertTab
 #' @export
 appendTab <- function(inputId, tab, select = FALSE, menuName = NULL,
                       session = getDefaultReactiveDomain()) {
-  force(select)
-  force(menuName)
-  inputId <- session$ns(inputId)
-
-  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
-    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
-
-  callback <- function() {
-    session$sendInsertTab(
-      inputId = inputId,
-      liTag = processDeps(item$liTag, session),
-      divTag = processDeps(item$divTag, session),
-      menuName = menuName,
-      target = NULL,
-      position = "before",
-      select = select)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_append(inputId, tab, menu_title = menuName, select = select, session = session)
 }
 
 #' @rdname insertTab
 #' @export
 removeTab <- function(inputId, target,
                       session = getDefaultReactiveDomain()) {
-  force(target)
-  inputId <- session$ns(inputId)
-
-  callback <- function() {
-    session$sendRemoveTab(
-      inputId = inputId,
-      target = target)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_remove(inputId, target, session)
 }
 
 

R/insert-ui.R

@@ -1,6 +1,6 @@
 #' Insert and remove UI objects
 #'
-#' These functions allow you to dynamically add and remove arbirary UI
+#' These functions allow you to dynamically add and remove arbitrary 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
@@ -11,7 +11,7 @@
 #' function.
 #'
 #' 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
+#' no restriction on what you can use it 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

R/jqueryui.R

@@ -76,16 +76,20 @@ absolutePanel <- function(...,
 
   style <- paste(paste(names(cssProps), cssProps, sep = ':', collapse = ';'), ';', sep='')
   divTag <- tags$div(style=style, ...)
-  if (isTRUE(draggable)) {
-    divTag <- tagAppendAttributes(divTag, class='draggable')
-    return(tagList(
-      singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
-      divTag,
-      tags$script('$(".draggable").draggable();')
-    ))
-  } else {
+
+  if (identical(draggable, FALSE)) {
     return(divTag)
   }
+
+  # Add Shiny inputs and htmlwidgets to 'non-draggable' elements
+  # Cf. https://api.jqueryui.com/draggable/#option-cancel
+  dragOpts <- '{cancel: ".shiny-input-container,.html-widget,input,textarea,button,select,option"}'
+  dragJS <- sprintf('$(".draggable").draggable(%s);', dragOpts)
+  tagList(
+    tagAppendAttributes(divTag, class='draggable'),
+    jqueryuiDependency(),
+    tags$script(HTML(dragJS))
+  )
 }
 
 #' @rdname absolutePanel
@@ -99,3 +103,14 @@ fixedPanel <- function(...,
                 width=width, height=height, draggable=draggable, cursor=match.arg(cursor),
                 fixed=TRUE)
 }
+
+
+jqueryuiDependency <- function() {
+  htmlDependency(
+    "jqueryui",
+    version_jqueryui,
+    src = "www/shared/jqueryui",
+    package = "shiny",
+    script = "jquery-ui.min.js"
+  )
+}

R/knitr.R

@@ -0,0 +1,81 @@
+#' Knitr S3 methods
+#'
+#' These S3 methods are necessary to help Shiny applications and UI chunks embed
+#' themselves in knitr/rmarkdown documents.
+#'
+#' @name knitr_methods
+#' @keywords internal
+#' @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), ..., inline = inline)
+  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,19 +1,3 @@
-# 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
-
-# Note that Map objects can't be saved in one R session and restored in
-# another, because they are based on fastmap, which uses an external pointer,
-# and external pointers can't be saved and restored in another session.
-#' @importFrom fastmap fastmap
 Map <- R6Class(
   'Map',
   portable = FALSE,
@@ -64,9 +48,12 @@ Map <- R6Class(
   )
 )
 
-as.list.Map <- function(map) {
-  map$values()
+#' @export
+as.list.Map <- function(x, ...) {
+  x$values()
 }
-length.Map <- function(map) {
-  map$size()
+
+#' @export
+length.Map <- function(x) {
+  x$size()
 }

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()) {
@@ -290,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)
 
@@ -327,9 +346,9 @@ HandlerManager <- R6Class("HandlerManager",
                 ),
                 catch = function(err) {
                   httpResponse(status = 500L,
-                    content_type = "text/html",
+                    content_type = "text/html; charset=UTF-8",
                     content = as.character(htmltools::htmlTemplate(
-                      system.file("template", "error.html", package = "shiny"),
+                      system_file("template", "error.html", package = "shiny"),
                       message = conditionMessage(err)
                     ))
                   )
@@ -407,7 +426,7 @@ HandlerManager <- R6Class("HandlerManager",
 )
 
 maybeInjectAutoreload <- function(resp) {
-  if (getOption("shiny.autoreload", FALSE) &&
+  if (get_devmode_option("shiny.autoreload", FALSE) &&
       isTRUE(grepl("^text/html($|;)", resp$content_type)) &&
       is.character(resp$content)) {
 

R/mock-session.R

@@ -1,5 +1,5 @@
 # Promise helpers taken from:
-#   https://github.com/rstudio/promises/blob/master/tests/testthat/common.R
+#   https://github.com/rstudio/promises/blob/main/tests/testthat/common.R
 # Block until all pending later tasks have executed
 wait_for_it <- function() {
   while (!later::loop_empty()) {
@@ -9,8 +9,6 @@ wait_for_it <- function() {
 
 # Block until the promise is resolved/rejected. If resolved, return the value.
 # If rejected, throw (yes throw, not return) the error.
-#' @importFrom promises %...!%
-#' @importFrom promises %...>%
 extract <- function(promise) {
   promise_value <- NULL
   error <- NULL
@@ -31,7 +29,6 @@ extract <- function(promise) {
 #' @noRd
 #' @export
 `$.mockclientdata` <- function(x, name) {
-  if (name == "allowDataUriScheme") { return(TRUE) }
   if (name == "pixelratio") { return(1) }
   if (name == "url_protocol") { return("http:") }
   if (name == "url_hostname") { return("mocksession") }
@@ -156,6 +153,8 @@ makeExtraMethods <- function() {
     "sendInsertTab",
     "sendInsertUI",
     "sendModal",
+    "setCurrentTheme",
+    "getCurrentTheme",
     "sendNotification",
     "sendProgress",
     "sendRemoveTab",
@@ -167,12 +166,10 @@ makeExtraMethods <- function() {
   ), makeErrors(
     `@uploadEnd` = "for internal use only",
     `@uploadInit` = "for internal use only",
-    `@uploadieFinish` = "for internal use only",
     createBookmarkObservers = "for internal use only",
     dispatch = "for internal use only",
     handleRequest = "for internal use only",
     requestFlush = "for internal use only",
-    saveFileUrl = "for internal use only",
     startTiming = "for internal use only",
     wsClosed = "for internal use only"
   ))
@@ -236,9 +233,9 @@ MockShinySession <- R6Class(
     progressStack = 'Stack',
     #' @field token On a real `ShinySession`, used to identify this instance in URLs.
     token = 'character',
-    #' @field cache The session cache MemoryCache.
+    #' @field cache The session cache object.
     cache = NULL,
-    #' @field appcache The app cache MemoryCache.
+    #' @field appcache The app cache object.
     appcache = NULL,
     #' @field restoreContext Part of bookmarking support in a real
     #'   `ShinySession` but always `NULL` for a `MockShinySession`.
@@ -249,6 +246,8 @@ MockShinySession <- R6Class(
     #' @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() {
@@ -260,7 +259,7 @@ MockShinySession <- R6Class(
       private$file_generators <- fastmap()
 
       private$timer <- MockableTimerCallbacks$new()
-      self$progressStack <- Stack$new()
+      self$progressStack <- fastmap::faststack()
 
       self$userData <- new.env(parent=emptyenv())
 
@@ -273,8 +272,12 @@ MockShinySession <- R6Class(
       self$input <- .createReactiveValues(private$.input, readonly = TRUE)
 
       self$token <- createUniqueId(16)
-      self$cache <- MemoryCache$new()
-      self$appcache <- MemoryCache$new()
+
+      # 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
@@ -454,6 +457,11 @@ MockShinySession <- R6Class(
           function(v){
             list(val = v, err = NULL)
           }, catch=function(e){
+            if (
+              !inherits(e, c("shiny.custom.error", "shiny.output.cancel", "shiny.output.progress", "shiny.silent.error"))
+            ) {
+              self$unhandledError(e, close = FALSE)
+            }
             list(val = NULL, err = e)
           })
       })
@@ -557,10 +565,26 @@ MockShinySession <- R6Class(
     rootScope = function() {
       self
     },
+    #' @description Add an unhandled error callback.
+    #' @param callback The callback to add, which should accept an error object
+    #'   as its first argument.
+    #' @return A deregistration function.
+    onUnhandledError = function(callback) {
+      private$unhandledErrorCallbacks$register(callback)
+    },
     #' @description Called by observers when a reactive expression errors.
     #' @param e An error object.
-    unhandledError = function(e) {
-      self$close()
+    #' @param close If `TRUE`, the session will be closed after the error is
+    #'  handled, defaults to `FALSE`.
+    unhandledError = function(e, close = TRUE) {
+      if (close) {
+        class(e) <- c("shiny.error.fatal", class(e))
+      }
+
+      private$unhandledErrorCallbacks$invoke(e, onError = printError)
+      .globals$onUnhandledErrorCallbacks$invoke(e, onError = printError)
+
+      if (close) self$close()
     },
     #' @description Freeze a value until the flush cycle completes.
     #' @param x A `ReactiveValues` object.
@@ -617,6 +641,9 @@ MockShinySession <- R6Class(
     flushedCBs = NULL,
     # @field endedCBs `Callbacks` called when session ends.
     endedCBs = NULL,
+    # @field unhandledErrorCallbacks `Callbacks` called when an unhandled error
+    #   occurs.
+    unhandledErrorCallbacks = Callbacks$new(),
     # @field timer `MockableTimerCallbacks` called at particular times.
     timer = NULL,
     # @field was_closed Set to `TRUE` once the session is closed.

R/modal.R

@@ -29,19 +29,28 @@ 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 `NULL` for no footer.
 #' @param size One of `"s"` for small, `"m"` (the default) for medium,
-#'   or `"l"` for large.
+#'   `"l"` for large, or `"xl"` for extra large. Note that `"xl"` only 
+#'    works with Bootstrap 4 and above (to opt-in to Bootstrap 4+, 
+#'    pass [bslib::bs_theme()] to the `theme` argument of a page container 
+#'    like [fluidPage()]).
 #' @param easyClose If `TRUE`, the modal dialog can be dismissed by
 #'   clicking outside the dialog box, or be pressing the Escape key. If
 #'   `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
+#'   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).
@@ -145,18 +154,25 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #' }
 #' @export
 modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
-  size = c("m", "s", "l"), easyClose = FALSE, fade = TRUE) {
+  size = c("m", "s", "l", "xl"), easyClose = FALSE, fade = TRUE) {
 
   size <- match.arg(size)
 
-  cls <- if (fade) "modal fade" else "modal"
-  div(id = "shiny-modal", class = cls, tabindex = "-1",
-    `data-backdrop` = if (!easyClose) "static",
-    `data-keyboard` = if (!easyClose) "false",
+  backdrop <- if (!easyClose) "static"
+  keyboard <- if (!easyClose) "false"
+  div(
+    id = "shiny-modal",
+    class = "modal",
+    class = if (fade) "fade",
+    tabindex = "-1",
+    `data-backdrop` = backdrop,
+    `data-bs-backdrop` = backdrop,
+    `data-keyboard` = keyboard,
+    `data-bs-keyboard` = keyboard,
 
     div(
       class = "modal-dialog",
-      class = switch(size, s = "modal-sm", m = NULL, l = "modal-lg"),
+      class = switch(size, s = "modal-sm", m = NULL, l = "modal-lg", xl = "modal-xl"),
       div(class = "modal-content",
         if (!is.null(title)) div(class = "modal-header",
           tags$h4(class = "modal-title", title)
@@ -165,19 +181,26 @@ modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
         if (!is.null(footer)) div(class = "modal-footer", footer)
       )
     ),
-    tags$script("$('#shiny-modal').modal().focus();")
+    # jQuery plugin doesn't work in Bootstrap 5, but vanilla JS doesn't work in Bootstrap 4 :sob:
+    tags$script(HTML(
+      "if (window.bootstrap && !window.bootstrap.Modal.VERSION.match(/^4\\./)) {
+         var modal = new bootstrap.Modal(document.getElementById('shiny-modal'));
+         modal.show();
+      } else {
+         $('#shiny-modal').modal().focus();
+      }"
+    ))
   )
 }
 
-#' Create a button for a modal dialog
-#'
-#' When clicked, a `modalButton` will dismiss the modal dialog.
-#'
-#' @inheritParams actionButton
-#' @seealso [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
+  tags$button(
+    type = "button",
+    class = "btn btn-default",
+    `data-dismiss` = "modal",
+    `data-bs-dismiss` = "modal",
+    validateIcon(icon), label
   )
 }

R/modules.R

@@ -31,17 +31,42 @@ 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))
+  }
+
+  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
-#' <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
@@ -55,7 +80,7 @@ createSessionProxy <- function(parentSession, ...) {
 #'   almost always be used).
 #'
 #' @return The return value, if any, from executing the module server function
-#' @seealso <http://shiny.rstudio.com/articles/modules.html>
+#' @seealso <https://shiny.rstudio.com/articles/modules.html>
 #'
 #' @examples
 #' # Define the UI for a module

R/progress.R

@@ -76,8 +76,10 @@ Progress <- R6Class(
       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)
@@ -204,7 +206,7 @@ Progress <- R6Class(
 #'   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
-#'   `setProgress`.
+#'   [setProgress()] or [incProgress()].
 #' @param min The value that represents the starting point of the progress bar.
 #'   Must be less tham `max`. Default is 0.
 #' @param max The value that represents the end of the progress bar. Must be
@@ -227,6 +229,7 @@ Progress <- R6Class(
 #' @param value Single-element numeric vector; the value at which to set the
 #'   progress bar, relative to `min` and `max`.
 #'
+#' @return The result of `expr`.
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {

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()
       ))
@@ -65,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)
@@ -87,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)
@@ -140,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)
@@ -202,7 +206,8 @@ getCurrentContext <- function() {
   .getReactiveEnvironment()$currentContext()
 }
 hasCurrentContext <- function() {
-  !is.null(.getReactiveEnvironment()$.currentContext)
+  !is.null(.getReactiveEnvironment()$.currentContext) ||
+    isTRUE(getOption("shiny.suppressMissingContextError"))
 }
 
 getDummyContext <- function() {
@@ -214,10 +219,10 @@ getDummyContext <- function() {
 
 wrapForContext <- function(func, ctx) {
   force(func)
-  force(ctx)
+  force(ctx) # may be NULL (in the case of maskReactiveContext())
 
   function(...) {
-    ctx$run(function() {
+    .getReactiveEnvironment()$runWith(ctx, function() {
       captureStackTraces(
         func(...)
       )
@@ -229,12 +234,18 @@ reactivePromiseDomain <- function() {
   promises::new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
-      ctx <- getCurrentContext()
+
+      # ctx will be NULL if we're in a maskReactiveContext()
+      ctx <- if (hasCurrentContext()) getCurrentContext() else NULL
+
       wrapForContext(onFulfilled, ctx)
     },
     wrapOnRejected = function(onRejected) {
       force(onRejected)
-      ctx <- getCurrentContext()
+
+      # ctx will be NULL if we're in a maskReactiveContext()
+      ctx <- if (hasCurrentContext()) getCurrentContext() else NULL
+
       wrapForContext(onRejected, ctx)
     }
   )

R/reactives.R

@@ -105,9 +105,7 @@ ReactiveVal <- R6Class(
       invisible(TRUE)
     },
     freeze = function(session = getDefaultReactiveDomain()) {
-      if (is.null(session)) {
-        stop("Can't freeze a reactiveVal without a reactive domain")
-      }
+      checkReactiveDomain(session)
       rLog$freezeReactiveVal(private$reactId, session)
       session$onFlushed(function() {
         self$thaw(session)
@@ -231,18 +229,30 @@ reactiveVal <- function(value = NULL, label = NULL) {
 #' @rdname freezeReactiveValue
 #' @export
 freezeReactiveVal <- function(x) {
-  domain <- getDefaultReactiveDomain()
-  if (is.null(domain)) {
-    stop("freezeReactiveVal() must be called when a default reactive domain is active.")
+  if (getOption("shiny.deprecation.messages", TRUE) && getOption("shiny.deprecation.messages.freeze", TRUE)) {
+    rlang::warn(
+      "freezeReactiveVal() is soft-deprecated, and may be removed in a future version of Shiny. (See https://github.com/rstudio/shiny/issues/3063)",
+      .frequency = "once", .frequency_id = "freezeReactiveVal")
   }
+
+  domain <- getDefaultReactiveDomain()
+  checkReactiveDomain(domain)
+
   if (!inherits(x, "reactiveVal")) {
-    stop("x must be a reactiveVal object")
+    rlang::abort("`x` must be a reactiveVal.")
   }
 
   attr(x, ".impl", exact = TRUE)$freeze(domain)
   invisible()
 }
 
+checkReactiveDomain <- function(x) {
+  if (is.null(x)) {
+    rlang::abort("Can't freeze reactive values without a reactive domain.")
+  }
+}
+
+
 #' @export
 format.reactiveVal <- function(x, ...) {
   attr(x, ".impl", exact = TRUE)$format(...)
@@ -316,6 +326,9 @@ ReactiveValues <- R6Class(
     .dedupe = logical(0),
     # Key, asList(), or names() have been retrieved
     .hasRetrieved = list(),
+    # All names, in insertion order. The names are also stored in the .values
+    # object, but it does not preserve order.
+    .nameOrder = character(0),
 
 
     initialize = function(
@@ -357,7 +370,7 @@ ReactiveValues <- R6Class(
       keyValue
     },
 
-    set = function(key, value) {
+    set = function(key, value, force = FALSE) {
       # if key exists
       #   if it is the same value, return
       #
@@ -389,10 +402,13 @@ ReactiveValues <- R6Class(
 
       key_exists <- .values$containsKey(key)
 
-      if (key_exists) {
-        if (.dedupe && identical(.values$get(key), value)) {
-          return(invisible())
-        }
+      if (key_exists && !isTRUE(force) && .dedupe && identical(.values$get(key), value)) {
+        return(invisible())
+      }
+
+      # If it's new, append key to the name order
+      if (!key_exists) {
+        .nameOrder[length(.nameOrder) + 1] <<- key
       }
 
       # set the value for better logging
@@ -436,14 +452,13 @@ ReactiveValues <- R6Class(
     },
 
     names = function() {
-      nameValues <- .values$keys()
       if (!isTRUE(.hasRetrieved$names)) {
         domain <- getDefaultReactiveDomain()
-        rLog$defineNames(.reactId, nameValues, .label, domain)
+        rLog$defineNames(.reactId, .nameOrder, .label, domain)
         .hasRetrieved$names <<- TRUE
       }
       .namesDeps$register()
-      return(nameValues)
+      return(.nameOrder)
     },
 
     # Get a metadata value. Does not trigger reactivity.
@@ -469,10 +484,15 @@ ReactiveValues <- R6Class(
 
     # Mark a value as frozen If accessed while frozen, a shiny.silent.error will
     # be thrown.
-    freeze = function(key) {
+    freeze = function(key, invalidate = FALSE) {
       domain <- getDefaultReactiveDomain()
       rLog$freezeReactiveKey(.reactId, key, domain)
       setMeta(key, "frozen", TRUE)
+
+      if (invalidate) {
+        # Force an invalidation
+        self$set(key, NULL, force = TRUE)
+      }
     },
 
     thaw = function(key) {
@@ -486,7 +506,7 @@ ReactiveValues <- R6Class(
     },
 
     toList = function(all.names=FALSE) {
-      listValue <- .values$values()
+      listValue <- .values$mget(.nameOrder)
       if (!all.names) {
         listValue <- listValue[!grepl("^\\.", base::names(listValue))]
       }
@@ -555,9 +575,9 @@ ReactiveValues <- R6Class(
 #' @seealso [isolate()] and [is.reactivevalues()].
 #' @export
 reactiveValues <- function(...) {
-  args <- list(...)
+  args <- list2(...)
   if ((length(args) > 0) && (is.null(names(args)) || any(names(args) == "")))
-    stop("All arguments passed to reactiveValues() must be named.")
+    rlang::abort("All arguments passed to reactiveValues() must be named.")
 
   values <- .createReactiveValues(ReactiveValues$new())
 
@@ -568,7 +588,7 @@ reactiveValues <- function(...) {
 
 checkName <- function(x) {
   if (!is.character(x) || length(x) != 1) {
-    stop("Must use single string to index into reactivevalues")
+    rlang::abort("Must use single string to index into reactivevalues.")
   }
 }
 
@@ -610,6 +630,14 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 #' @export
 `$.reactivevalues` <- function(x, name) {
   checkName(name)
+
+  if (!hasCurrentContext()) {
+    rlang::abort(c(
+      paste0("Can't access reactive value '", name, "' outside of reactive consumer."),
+      i = "Do you need to wrap inside reactive() or observe()?"
+    ))
+  }
+
   .subset2(x, 'impl')$get(.subset2(x, 'ns')(name))
 }
 
@@ -619,7 +647,7 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 #' @export
 `$<-.reactivevalues` <- function(x, name, value) {
   if (.subset2(x, 'readonly')) {
-    stop("Attempted to assign value to a read-only reactivevalues object")
+    rlang::abort(paste0("Can't modify read-only reactive value '", name, "'"))
   }
   checkName(name)
   .subset2(x, 'impl')$set(.subset2(x, 'ns')(name), value)
@@ -631,12 +659,12 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 
 #' @export
 `[.reactivevalues` <- function(values, name) {
-  stop("Single-bracket indexing of reactivevalues object is not allowed.")
+  rlang::abort("Can't index reactivevalues with `[`.")
 }
 
 #' @export
 `[<-.reactivevalues` <- function(values, name, value) {
-  stop("Single-bracket indexing of reactivevalues object is not allowed.")
+  rlang::abort("Can't index reactivevalues with `[`.")
 }
 
 #' @export
@@ -652,16 +680,15 @@ names.reactivevalues <- function(x) {
 
 #' @export
 `names<-.reactivevalues` <- function(x, value) {
-  stop("Can't assign names to reactivevalues object")
+  rlang::abort("Can't assign names to reactivevalues.")
 }
 
 #' @export
 as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
-  shinyDeprecated("reactiveValuesToList",
-    msg = paste("'as.list.reactivevalues' is deprecated. ",
-      "Use reactiveValuesToList instead.",
-      "\nPlease see ?reactiveValuesToList for more information.",
-      sep = ""))
+  shinyDeprecated(
+    "0.4.0", "as.list.reactivevalues()", "reactiveValuesToList()",
+    details = "Please see ?reactiveValuesToList for more information."
+  )
 
   reactiveValuesToList(x, all.names)
 }
@@ -727,7 +754,10 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
 #' thing that happens if `req(FALSE)` is called. The value is thawed
 #' (un-frozen; accessing it will no longer raise an exception) when the current
 #' reactive domain is flushed. In a Shiny application, this occurs after all of
-#' the observers are executed.
+#' the observers are executed. **NOTE:** We are considering deprecating
+#' `freezeReactiveVal`, and `freezeReactiveValue` except when `x` is `input`.
+#' If this affects your app, please let us know by leaving a comment on
+#' [this GitHub issue](https://github.com/rstudio/shiny/issues/3063).
 #'
 #' @param x For `freezeReactiveValue`, a [reactiveValues()]
 #'   object (like `input`); for `freezeReactiveVal`, a
@@ -773,9 +803,7 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
 #' @export
 freezeReactiveValue <- function(x, name) {
   domain <- getDefaultReactiveDomain()
-  if (is.null(domain)) {
-    stop("freezeReactiveValue() must be called when a default reactive domain is active.")
-  }
+  checkReactiveDomain(domain)
 
   domain$freezeValue(x, name)
   invisible()
@@ -807,9 +835,10 @@ Observable <- R6Class(
                           domain = getDefaultReactiveDomain(),
                           ..stacktraceon = TRUE) {
       if (length(formals(func)) > 0)
-        stop("Can't make a reactive expression from a function that takes one ",
-             "or more parameters; only functions without parameters can be ",
-             "reactive.")
+        rlang::abort(c(
+          "Can't make a reactive expression from a function that takes arguments.",
+          "Only functions without parameters can become reactive expressions."
+        ))
 
       # This is to make sure that the function labels that show in the profiler
       # and in stack traces doesn't contain whitespace. See
@@ -853,8 +882,7 @@ Observable <- R6Class(
         invisible(.value)
     },
     format = function() {
-      label <- sprintf('reactive(%s)', paste(deparse(body(.origFunc)), collapse='\n'))
-      strsplit(label, "\n")[[1]]
+      simpleExprToFunction(fn_body(.origFunc), "reactive")
     },
     .updateValue = function() {
       ctx <- Context$new(.domain, .label, type = 'observable',
@@ -923,53 +951,75 @@ Observable <- R6Class(
 #' See the [Shiny tutorial](https://shiny.rstudio.com/tutorial/) for
 #' more information about reactive expressions.
 #'
-#' @param x For `reactive`, an expression (quoted or unquoted). For
-#'   `is.reactive`, an object to test.
-#' @param env The parent environment for the reactive expression. By default,
-#'   this is the calling environment, the same as when defining an ordinary
-#'   non-reactive expression.
-#' @param quoted Is the expression quoted? By default, this is `FALSE`.
-#'   This is useful when you want to use an expression that is stored in a
-#'   variable; to do so, it must be quoted with `quote()`.
+#' @param x For `is.reactive()`, an object to test. For `reactive()`, an expression. When passing in a [`quo()`]sure with `reactive()`, remember to use [`rlang::inject()`] to distinguish that you are passing in the content of your quosure, not the expression of the quosure.
+#' @template param-env
+#' @templateVar x x
+#' @templateVar env env
+#' @templateVar quoted quoted
+#' @template param-quoted
+#' @templateVar x x
+#' @templateVar quoted quoted
+
 #' @param label A label for the reactive expression, useful for debugging.
 #' @param domain See [domains].
 #' @param ..stacktraceon Advanced use only. For stack manipulation purposes; see
 #'   [stacktrace()].
+#' @param ... Not used.
 #' @return a function, wrapped in a S3 class "reactive"
 #'
 #' @examples
+#' library(rlang)
 #' values <- reactiveValues(A=1)
 #'
 #' reactiveB <- reactive({
 #'   values$A + 1
 #' })
-#'
-#' # Can use quoted expressions
-#' reactiveC <- reactive(quote({ values$A + 2 }), quoted = TRUE)
-#'
-#' # To store expressions for later conversion to reactive, use quote()
-#' expr_q <- quote({ values$A + 3 })
-#' reactiveD <- reactive(expr_q, quoted = TRUE)
-#'
 #' # View the values from the R console with isolate()
 #' isolate(reactiveB())
+#' # 2
+#'
+#' # To store expressions for later conversion to reactive, use quote()
+#' myquo <- rlang::quo(values$A + 2)
+#' # Unexpected value! Sending a quosure directly will not work as expected.
+#' reactiveC <- reactive(myquo)
+#' # We'd hope for `3`, but instead we get the quosure that was supplied.
 #' isolate(reactiveC())
+#'
+#' # Instead, the quosure should be `rlang::inject()`ed
+#' reactiveD <- rlang::inject(reactive(!!myquo))
 #' isolate(reactiveD())
+#' # 3
+#'
+#' # (Legacy) Can use quoted expressions
+#' expr <- quote({ values$A + 3 })
+#' reactiveE <- reactive(expr, quoted = TRUE)
+#' isolate(reactiveE())
+#' # 4
+#'
 #' @export
-reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
-                     domain = getDefaultReactiveDomain(),
-                     ..stacktraceon = TRUE) {
-  fun <- exprToFunction(x, env, quoted)
+reactive <- function(
+  x,
+  env = parent.frame(),
+  quoted = FALSE,
+  ...,
+  label = NULL,
+  domain = getDefaultReactiveDomain(),
+  ..stacktraceon = TRUE
+) {
+  check_dots_empty()
+
+  func <- installExprFunction(x, "func", env, quoted, wrappedWithLabel = FALSE)
   # Attach a label and a reference to the original user source for debugging
-  srcref <- attr(substitute(x), "srcref", exact = TRUE)
-  if (is.null(label)) {
-    label <- rexprSrcrefToLabel(srcref[[1]],
-      sprintf('reactive(%s)', paste(deparse(body(fun)), collapse='\n')))
-  }
-  if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
-  attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
-  o <- Observable$new(fun, label, domain, ..stacktraceon = ..stacktraceon)
-  structure(o$getValue, observable = o, class = c("reactiveExpr", "reactive", "function"))
+  userExpr <- fn_body(func)
+  label <- exprToLabel(userExpr, "reactive", label)
+
+  o <- Observable$new(func, label, domain, ..stacktraceon = ..stacktraceon)
+  structure(
+    o$getValue,
+    observable = o,
+    cacheHint = list(userExpr = zap_srcref(userExpr)),
+    class = c("reactiveExpr", "reactive", "function")
+  )
 }
 
 # Given the srcref to a reactive expression, attempts to figure out what the
@@ -1038,7 +1088,15 @@ execCount <- function(x) {
   else if (inherits(x, 'Observer'))
     return(x$.execCount)
   else
-    stop('Unexpected argument to execCount')
+    rlang::abort("Unexpected argument to execCount().")
+}
+
+# Internal utility functions for extracting things out of reactives.
+reactive_get_value_func <- function(x) {
+  attr(x, "observable", exact = TRUE)$.origFunc
+}
+reactive_get_domain <- function(x) {
+  attr(x, "observable", exact = TRUE)$.domain
 }
 
 # Observer ------------------------------------------------------------------
@@ -1070,8 +1128,10 @@ Observer <- R6Class(
                           domain = getDefaultReactiveDomain(),
                           autoDestroy = TRUE, ..stacktraceon = TRUE) {
       if (length(formals(observerFunc)) > 0)
-        stop("Can't make an observer from a function that takes parameters; ",
-             "only functions without parameters can be reactive.")
+        rlang::abort(c(
+          "Can't make an observer from a function that takes arguments.",
+          "Only functions without arguments can become observers."
+        ))
       if (grepl("\\s", label, perl = TRUE)) {
         funcLabel <- "<observer>"
       } else {
@@ -1150,13 +1210,13 @@ Observer <- R6Class(
             # validation = function(e) NULL,
             # shiny.output.cancel = function(e) NULL
 
-            if (inherits(e, "shiny.silent.error")) {
+            if (cnd_inherits(e, "shiny.silent.error")) {
               return()
             }
 
             printError(e)
             if (!is.null(.domain)) {
-              .domain$unhandledError(e)
+              .domain$unhandledError(e, close = TRUE)
             }
           },
           finally = .domain$decrementBusyCount
@@ -1282,12 +1342,7 @@ Observer <- R6Class(
 #'
 #' @param x An expression (quoted or unquoted). Any return value will be
 #'   ignored.
-#' @param env The parent environment for the reactive expression. By default,
-#'   this is the calling environment, the same as when defining an ordinary
-#'   non-reactive expression.
-#' @param quoted Is the expression quoted? By default, this is `FALSE`.
-#'   This is useful when you want to use an expression that is stored in a
-#'   variable; to do so, it must be quoted with `quote()`.
+#' @inheritParams reactive
 #' @param label A label for the observer, useful for debugging.
 #' @param suspended If `TRUE`, start the observer in a suspended state. If
 #'   `FALSE` (the default), start in a non-suspended state.
@@ -1301,6 +1356,8 @@ Observer <- R6Class(
 #'   automatically destroyed when its domain (if any) ends.
 #' @param ..stacktraceon Advanced use only. For stack manipulation purposes; see
 #'   [stacktrace()].
+#' @param ... Not used.
+#'
 #' @return An observer reference class object. This object has the following
 #'   methods:
 #'   \describe{
@@ -1344,29 +1401,43 @@ Observer <- R6Class(
 #'   print(values$A + 1)
 #' })
 #'
-#' # Can use quoted expressions
-#' obsC <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
+#' # To store expressions for later conversion to observe, use rlang::quo()
+#' myquo <- rlang::quo({ print(values$A + 3) })
+#' obsC <- rlang::inject(observe(!!myquo))
 #'
-#' # To store expressions for later conversion to observe, use quote()
-#' expr_q <- quote({ print(values$A + 3) })
-#' obsD <- observe(expr_q, quoted = TRUE)
+#' # (Legacy) Can use quoted expressions
+#' obsD <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
 #'
 #' # In a normal Shiny app, the web client will trigger flush events. If you
 #' # are at the console, you can force a flush with flushReact()
 #' shiny:::flushReact()
 #' @export
-observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
-                    suspended=FALSE, priority=0,
-                    domain=getDefaultReactiveDomain(), autoDestroy = TRUE,
-                    ..stacktraceon = TRUE) {
+observe <- function(
+  x,
+  env = parent.frame(),
+  quoted = FALSE,
+  ...,
+  label = NULL,
+  suspended = FALSE,
+  priority = 0,
+  domain = getDefaultReactiveDomain(),
+  autoDestroy = TRUE,
+  ..stacktraceon = TRUE)
+{
+  check_dots_empty()
 
-  fun <- exprToFunction(x, env, quoted)
-  if (is.null(label))
-    label <- sprintf('observe(%s)', paste(deparse(body(fun)), collapse='\n'))
+  func <- installExprFunction(x, "func", env, quoted)
+  label <- funcToLabel(func, "observe", label)
 
-  o <- Observer$new(fun, label=label, suspended=suspended, priority=priority,
-                    domain=domain, autoDestroy=autoDestroy,
-                    ..stacktraceon=..stacktraceon)
+  o <- Observer$new(
+    func,
+    label = label,
+    suspended = suspended,
+    priority = priority,
+    domain = domain,
+    autoDestroy = autoDestroy,
+    ..stacktraceon = ..stacktraceon
+  )
   invisible(o)
 }
 
@@ -1377,35 +1448,34 @@ observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
 #' already exist; if so, its value will be used as the initial value of the
 #' reactive variable (or `NULL` if the variable did not exist).
 #'
-#' @param symbol A character string indicating the name of the variable that
-#'   should be made reactive
-#' @param env The environment that will contain the reactive variable
-#'
+#' @param symbol Name of variable to make reactive, as a string.
+#' @param env Environment in which to create binding. Expert use only.
 #' @return None.
-#'
+#' @keywords internal
 #' @examples
-#' \dontrun{
+#' reactiveConsole(TRUE)
+#'
 #' a <- 10
 #' makeReactiveBinding("a")
+#'
 #' b <- reactive(a * -1)
 #' observe(print(b()))
+#'
 #' a <- 20
-#' }
+#' a <- 30
+#'
+#' reactiveConsole(FALSE)
 #' @export
 makeReactiveBinding <- function(symbol, env = parent.frame()) {
   if (exists(symbol, envir = env, inherits = FALSE)) {
     initialValue <- env[[symbol]]
     rm(list = symbol, envir = env, inherits = FALSE)
-  }
-  else
+  } else {
     initialValue <- NULL
-  values <- reactiveValues(value = initialValue)
-  makeActiveBinding(symbol, env=env, fun=function(v) {
-    if (missing(v))
-      values$value
-    else
-      values$value <- v
-  })
+  }
+
+  val <- reactiveVal(initialValue, label = symbol)
+  makeActiveBinding(symbol, val, env = env)
 
   invisible()
 }
@@ -1441,6 +1511,29 @@ setAutoflush <- local({
   }
 })
 
+
+#' Activate reactivity in the console
+#'
+#' This is an experimental feature that allows you to enable reactivity
+#' at the console, for the purposes of experimentation and learning.
+#'
+#' @keywords internal
+#' @param enabled Turn console reactivity on or off?
+#' @export
+#' @examples
+#' reactiveConsole(TRUE)
+#' x <- reactiveVal(10)
+#' y <- observe({
+#'   message("The value of x is ", x())
+#' })
+#' x(20)
+#' x(30)
+#' reactiveConsole(FALSE)
+reactiveConsole <- function(enabled) {
+  options(shiny.suppressMissingContextError = enabled)
+  setAutoflush(enabled)
+}
+
 # ---------------------------------------------------------------------------
 
 #' Timer
@@ -1737,6 +1830,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
   rv <- reactiveValues(cookie = isolate(checkFunc()))
 
   re_finalized <- FALSE
+  env <- environment()
 
   o <- observe({
     # When no one holds a reference to the reactive returned from
@@ -1744,7 +1838,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
     # firing and hold onto resources.
     if (re_finalized) {
       o$destroy()
-      rm(o, envir = parent.env(environment()))
+      rm(o, envir = env)
       return()
     }
 
@@ -1829,7 +1923,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' @export
 reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...) {
   filePath <- coerceToFunc(filePath)
-  extraArgs <- list(...)
+  extraArgs <- list2(...)
 
   reactivePoll(
     intervalMillis, session,
@@ -1948,7 +2042,11 @@ maskReactiveContext <- function(expr) {
 
 #' Event handler
 #'
-#' Respond to "event-like" reactive inputs, values, and expressions.
+#' Respond to "event-like" reactive inputs, values, and expressions. As of Shiny
+#' 1.6.0, we recommend using [bindEvent()] instead of `eventReactive()` and
+#' `observeEvent()`. This is because `bindEvent()` can be composed with
+#' [bindCache()], and because it can also be used with `render` functions (like
+#' [renderText()] and [renderPlot()]).
 #'
 #' Shiny's reactive programming framework is primarily designed for calculated
 #' values (reactive expressions) and side-effect-causing actions (observers)
@@ -1970,13 +2068,17 @@ maskReactiveContext <- function(expr) {
 #' response to an event. (Note that "recalculate a value" does not generally
 #' count as performing an action--see `eventReactive` for that.) The first
 #' argument is the event you want to respond to, and the second argument is a
-#' function that should be called whenever the event occurs.
+#' function that should be called whenever the event occurs. Note that
+#' `observeEvent()` is equivalent to using `observe() %>% bindEvent()` and as of
+#' Shiny 1.6.0, we recommend the latter.
 #'
 #' Use `eventReactive` 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.
+#' in response to the given event. Note that
+#' `eventReactive()` is equivalent to using `reactive() %>% bindEvent()` and as of
+#' Shiny 1.6.0, we recommend the latter.
 #'
 #' @section ignoreNULL and ignoreInit:
 #'
@@ -2010,6 +2112,7 @@ maskReactiveContext <- function(expr) {
 #' 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`}{
@@ -2049,23 +2152,30 @@ maskReactiveContext <- function(expr) {
 #' @param valueExpr The expression that produces the return value of the
 #'   `eventReactive`. It will be executed within an [isolate()]
 #'   scope.
-#' @param event.env The parent environment for `eventExpr`. By default,
-#'   this is the calling environment.
-#' @param event.quoted Is the `eventExpr` expression quoted? By default,
-#'   this is `FALSE`. This is useful when you want to use an expression
-#'   that is stored in a variable; to do so, it must be quoted with
-#'   `quote()`.
-#' @param handler.env The parent environment for `handlerExpr`. By default,
-#'   this is the calling environment.
-#' @param handler.quoted Is the `handlerExpr` expression quoted? By
-#'   default, this is `FALSE`. This is useful when you want to use an
-#'   expression that is stored in a variable; to do so, it must be quoted with
-#'   `quote()`.
-#' @param value.env The parent environment for `valueExpr`. By default,
-#'   this is the calling environment.
-#' @param value.quoted Is the `valueExpr` expression quoted? By default,
-#'   this is `FALSE`. This is useful when you want to use an expression
-#'   that is stored in a variable; to do so, it must be quoted with `quote()`.
+#' @param event.env The parent environment for the reactive expression. By default,
+#'   this is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression. If `eventExpr` is a quosure and `event.quoted` is `TRUE`,
+#'   then `event.env` is ignored.
+#' @param event.quoted If it is `TRUE`, then the [`quote()`]ed value of `eventExpr`
+#'   will be used when `eventExpr` is evaluated. If `eventExpr` is a quosure and you
+#'   would like to use its expression as a value for `eventExpr`, then you must set
+#'  `event.quoted` to `TRUE`.
+#' @param handler.env The parent environment for the reactive expression. By default,
+#'   this is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression. If `handlerExpr` is a quosure and `handler.quoted` is `TRUE`,
+#'   then `handler.env` is ignored.
+#' @param handler.quoted If it is `TRUE`, then the [`quote()`]ed value of `handlerExpr`
+#'   will be used when `handlerExpr` is evaluated. If `handlerExpr` is a quosure and you
+#'   would like to use its expression as a value for `handlerExpr`, then you must set
+#'  `handler.quoted` to `TRUE`.
+#' @param value.env The parent environment for the reactive expression. By default,
+#'   this is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression. If `valueExpr` is a quosure and `value.quoted` is `TRUE`,
+#'   then `value.env` is ignored.
+#' @param value.quoted If it is `TRUE`, then the [`quote()`]ed value of `valueExpr`
+#'   will be used when `valueExpr` is evaluated. If `valueExpr` is a quosure and you
+#'   would like to use its expression as a value for `valueExpr`, then you must set
+#'  `value.quoted` to `TRUE`.
 #' @param label A label for the observer or reactive, useful for debugging.
 #' @param suspended If `TRUE`, start the observer in a suspended state. If
 #'   `FALSE` (the default), start in a non-suspended state.
@@ -2077,8 +2187,8 @@ maskReactiveContext <- function(expr) {
 #' @param autoDestroy If `TRUE` (the default), the observer will be
 #'   automatically destroyed when its domain (if any) ends.
 #' @param ignoreNULL Whether the action should be triggered (or value
-#'   calculated, in the case of `eventReactive`) when the input is
-#'   `NULL`. See Details.
+#'   calculated, in the case of `eventReactive`) when the input event expression
+#'   is `NULL`. See Details.
 #' @param ignoreInit If `TRUE`, then, when this `observeEvent` is
 #'   first created/initialized, ignore the `handlerExpr` (the second
 #'   argument), whether it is otherwise supposed to run or not. The default is
@@ -2087,6 +2197,7 @@ maskReactiveContext <- function(expr) {
 #'   after the first time that the code in `handlerExpr` is run. This
 #'   pattern is useful when you want to subscribe to a event that should only
 #'   happen once.
+#' @param ... Currently not used.
 #'
 #' @return `observeEvent` returns an observer reference class object (see
 #'   [observe()]). `eventReactive` returns a reactive expression
@@ -2095,7 +2206,7 @@ maskReactiveContext <- function(expr) {
 #' @seealso [actionButton()]
 #'
 #' @examples
-#' ## Only run this example in interactive R sessions
+#' ## Only run examples in interactive R sessions
 #' if (interactive()) {
 #'
 #'   ## App 1: Sample usage
@@ -2114,6 +2225,12 @@ maskReactiveContext <- function(expr) {
 #'       observeEvent(input$button, {
 #'         cat("Showing", input$x, "rows\n")
 #'       })
+#'       # The observeEvent() above is equivalent to:
+#'       # observe({
+#'       #    cat("Showing", input$x, "rows\n")
+#'       #   }) %>%
+#'       #   bindEvent(input$button)
+#'
 #'       # Take a reactive dependency on input$button, but
 #'       # not on any of the stuff inside the function
 #'       df <- eventReactive(input$button, {
@@ -2133,6 +2250,12 @@ maskReactiveContext <- function(expr) {
 #'         print(paste("This will only be printed once; all",
 #'               "subsequent button clicks won't do anything"))
 #'       }, once = TRUE)
+#'       # The observeEvent() above is equivalent to:
+#'       # observe({
+#'       #   print(paste("This will only be printed once; all",
+#'       #         "subsequent button clicks won't do anything"))
+#'       #   }) %>%
+#'       #   bindEvent(input$go, once = TRUE)
 #'     }
 #'   )
 #'
@@ -2159,42 +2282,36 @@ maskReactiveContext <- function(expr) {
 observeEvent <- function(eventExpr, handlerExpr,
   event.env = parent.frame(), event.quoted = FALSE,
   handler.env = parent.frame(), handler.quoted = FALSE,
+  ...,
   label = NULL, suspended = FALSE, priority = 0,
   domain = getDefaultReactiveDomain(), autoDestroy = TRUE,
-  ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE) {
+  ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE)
+{
+  check_dots_empty()
 
-  eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
-  if (is.null(label))
-    label <- sprintf('observeEvent(%s)', paste(deparse(body(eventFunc)), collapse='\n'))
-  eventFunc <- wrapFunctionLabel(eventFunc, "observeEventExpr", ..stacktraceon = TRUE)
+  eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
+  handlerQ <- exprToQuo(handlerExpr, handler.env, handler.quoted)
 
-  handlerFunc <- exprToFunction(handlerExpr, handler.env, handler.quoted)
-  handlerFunc <- wrapFunctionLabel(handlerFunc, "observeEventHandler", ..stacktraceon = TRUE)
+  label <- quoToLabel(eventQ, "observeEvent", label)
 
-  initialized <- FALSE
+  handler <- inject(observe(
+    !!handlerQ,
+    label = label,
+    suspended = suspended,
+    priority = priority,
+    domain = domain,
+    autoDestroy = TRUE,
+    ..stacktraceon = FALSE # TODO: Does this go in the bindEvent?
+  ))
 
-  o <- observe({
-    hybrid_chain(
-      {eventFunc()},
-      function(value) {
-        if (ignoreInit && !initialized) {
-          initialized <<- TRUE
-          return()
-        }
-
-        if (ignoreNULL && isNullEvent(value)) {
-          return()
-        }
-
-        if (once) {
-          on.exit(o$destroy())
-        }
-
-        isolate(handlerFunc())
-      }
-    )
-  }, label = label, suspended = suspended, priority = priority, domain = domain,
-  autoDestroy = TRUE, ..stacktraceon = FALSE)
+  o <- inject(bindEvent(
+    ignoreNULL = ignoreNULL,
+    ignoreInit = ignoreInit,
+    once = once,
+    label = label,
+    !!eventQ,
+    x = handler
+  ))
 
   invisible(o)
 }
@@ -2204,34 +2321,24 @@ observeEvent <- function(eventExpr, handlerExpr,
 eventReactive <- function(eventExpr, valueExpr,
   event.env = parent.frame(), event.quoted = FALSE,
   value.env = parent.frame(), value.quoted = FALSE,
+  ...,
   label = NULL, domain = getDefaultReactiveDomain(),
-  ignoreNULL = TRUE, ignoreInit = FALSE) {
+  ignoreNULL = TRUE, ignoreInit = FALSE)
+{
+  check_dots_empty()
 
-  eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
-  if (is.null(label))
-    label <- sprintf('eventReactive(%s)', paste(deparse(body(eventFunc)), collapse='\n'))
-  eventFunc <- wrapFunctionLabel(eventFunc, "eventReactiveExpr", ..stacktraceon = TRUE)
+  eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
+  valueQ <- exprToQuo(valueExpr, value.env, value.quoted)
 
-  handlerFunc <- exprToFunction(valueExpr, value.env, value.quoted)
-  handlerFunc <- wrapFunctionLabel(handlerFunc, "eventReactiveHandler", ..stacktraceon = TRUE)
+  label <- quoToLabel(eventQ, "eventReactive", label)
 
-  initialized <- FALSE
-
-  invisible(reactive({
-    hybrid_chain(
-      eventFunc(),
-      function(value) {
-        if (ignoreInit && !initialized) {
-          initialized <<- TRUE
-          req(FALSE)
-        }
-
-        req(!ignoreNULL || !isNullEvent(value))
-
-        isolate(handlerFunc())
-      }
-    )
-  }, label = label, domain = domain, ..stacktraceon = FALSE))
+  invisible(inject(bindEvent(
+    ignoreNULL = ignoreNULL,
+    ignoreInit = ignoreInit,
+    label = label,
+    !!eventQ,
+    x = reactive(!!valueQ, domain = domain, label = label)
+  )))
 }
 
 isNullEvent <- function(value) {
@@ -2289,7 +2396,7 @@ isNullEvent <- function(value) {
 #' reactive recently (within the time window) invalidated. New `r`
 #' invalidations do not reset the time window. This means that if invalidations
 #' continually come from `r` within the time window, the throttled reactive
-#' will invalidate regularly, at a rate equal to or slower than than the time
+#' will invalidate regularly, at a rate equal to or slower than the time
 #' window.
 #'
 #' `ooo-oo-oo---- => o--o--o--o---`
@@ -2372,11 +2479,11 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
 
       # Ensure r() is called only after setting firstRun to FALSE since r()
       # may throw an error
-      r()
+      try(r(), silent = TRUE)
       return()
     }
     # This ensures r() is still tracked after firstRun
-    r()
+    try(r(), silent = TRUE)
 
     # The value (or possibly millis) changed. Start or reset the timer.
     v$when <- getDomainTimeMs(domain) + millis()
@@ -2391,7 +2498,7 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
     now <- getDomainTimeMs(domain)
     if (now >= v$when) {
       # Mod by 999999999 to get predictable overflow behavior
-      v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
+      v$trigger <- isolate(v$trigger %||% 0) %% 999999999 + 1
       v$when <- NULL
     } else {
       invalidateLater(v$when - now)
@@ -2409,7 +2516,7 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
   # commenting it out and studying the unit test failure that results.
   primer <- observe({
     primer$destroy()
-    er()
+    try(er(), silent = TRUE)
   }, label = "debounce primer", domain = domain, priority = priority)
 
   er
@@ -2451,7 +2558,7 @@ throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
   }
 
   # Responsible for tracking when f() changes.
-  observeEvent(r(), {
+  observeEvent(try(r(), silent = TRUE), {
     if (v$pending) {
       # In a blackout period and someone already scheduled; do nothing
     } else if (blackoutMillisLeft() > 0) {

R/reexports.R

@@ -1,6 +1,6 @@
 ####
-# Generated by `./tools/updateReexports.R`: do not edit by hand
-# Please call `source('tools/updateReexports.R') from the root folder to update`
+# Generated by `./tools/documentation/updateReexports.R`: do not edit by hand
+# Please call `source('tools/documentation/updateReexports.R')` from the root folder to update`
 ####
 
 
@@ -90,17 +90,20 @@ htmltools::em
 #' @export
 htmltools::hr
 
-
-# htmltools tag.Rd -------------------------------------------------------------
-
 #' @importFrom htmltools tag
 #' @export
 htmltools::tag
 
+
+# htmltools tagList.Rd ---------------------------------------------------------
+
 #' @importFrom htmltools tagList
 #' @export
 htmltools::tagList
 
+
+# htmltools tagAppendAttributes.Rd ---------------------------------------------
+
 #' @importFrom htmltools tagAppendAttributes
 #' @export
 htmltools::tagAppendAttributes
@@ -113,6 +116,9 @@ htmltools::tagHasAttribute
 #' @export
 htmltools::tagGetAttribute
 
+
+# htmltools tagAppendChild.Rd --------------------------------------------------
+
 #' @importFrom htmltools tagAppendChild
 #' @export
 htmltools::tagAppendChild

R/render-cached-plot.R

@@ -1,6 +1,7 @@
 #' 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()].
 #'
 #' `expr` is an expression that generates a plot, similar to that in
 #' `renderPlot`. Unlike with `renderPlot`, this expression does not
@@ -8,7 +9,7 @@
 #' changes.
 #'
 #' `cacheKeyExpr` is an expression which, when evaluated, returns an object
-#' which will be serialized and hashed using the [digest::digest()]
+#' 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
@@ -32,7 +33,7 @@
 #' to normal R objects before returning them. Your expression could even
 #' serialize and hash that information in an efficient way and return a string,
 #' which will in turn be hashed (very quickly) by the
-#' [digest::digest()] function.
+#' [rlang::hash()] function.
 #'
 #' Internally, the result from `cacheKeyExpr` is combined with the name of
 #' the output (if you assign it to `output$plot1`, it will be combined
@@ -40,95 +41,6 @@
 #' if there are multiple plots that have the same `cacheKeyExpr`, they
 #' will not have cache key collisions.
 #'
-#' @section Cache scoping:
-#'
-#'   There are a number of different ways you may want to scope the cache. For
-#'   example, you may want each user session to have their own plot cache, or
-#'   you may want each run of the application to have a cache (shared among
-#'   possibly multiple simultaneous user sessions), or you may want to have a
-#'   cache that persists even after the application is shut down and started
-#'   again.
-#'
-#'   To control the scope of the cache, use the `cache` parameter. There
-#'   are two ways of having Shiny automatically create and clean up the disk
-#'   cache.
-#'
-#' \describe{
-#'   \item{1}{To scope the cache to one run of a Shiny application (shared
-#'     among possibly multiple user sessions), use `cache="app"`. This
-#'     is the default. The cache will be shared across multiple sessions, so
-#'     there is potentially a large performance benefit if there are many users
-#'     of the application. When the application stops running, the cache will
-#'     be deleted. If plots cannot be safely shared across users, this should
-#'     not be used.}
-#'   \item{2}{To scope the cache to one session, use `cache="session"`.
-#'     When a new user session starts --- in other words, when a web browser
-#'     visits the Shiny application --- a new cache will be created on disk
-#'     for that session. When the session ends, the cache will be deleted.
-#'     The cache will not be shared across multiple sessions.}
-#'  }
-#'
-#'   If either `"app"` or `"session"` is used, the cache will be 10 MB
-#'   in size, and will be stored stored in memory, using a
-#'   [memoryCache()] object. Note that the cache space will be shared
-#'   among all cached plots within a single application or session.
-#'
-#'   In some cases, you may want more control over the caching behavior. For
-#'   example, you may want to use a larger or smaller cache, share a cache
-#'   among multiple R processes, or you may want the cache to persist across
-#'   multiple runs of an application, or even across multiple R processes.
-#'
-#'   To use different settings for an application-scoped cache, you can call
-#'   [shinyOptions()] at the top of your app.R, server.R, or
-#'   global.R. For example, this will create a cache with 20 MB of space
-#'   instead of the default 10 MB:
-#'   \preformatted{
-#'   shinyOptions(cache = memoryCache(size = 20e6))
-#'   }
-#'
-#'   To use different settings for a session-scoped cache, you can call
-#'   [shinyOptions()] at the top of your server function. To use
-#'   the session-scoped cache, you must also call `renderCachedPlot` with
-#'   `cache="session"`. This will create a 20 MB cache for the session:
-#'   \preformatted{
-#'   function(input, output, session) {
-#'     shinyOptions(cache = memoryCache(size = 20e6))
-#'
-#'     output$plot <- renderCachedPlot(
-#'       ...,
-#'       cache = "session"
-#'     )
-#'   }
-#'   }
-#'
-#'   If you want to create a cache that is shared across multiple concurrent
-#'   R processes, you can use a [diskCache()]. You can create an
-#'   application-level shared cache by putting this at the top of your app.R,
-#'   server.R, or global.R:
-#'   \preformatted{
-#'   shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
-#'   }
-#'
-#'   This will create a subdirectory in your system temp directory named
-#'   `myapp-cache` (replace `myapp-cache` with a unique name of
-#'   your choosing). On most platforms, this directory will be removed when
-#'   your system reboots. This cache will persist across multiple starts and
-#'   stops of the R process, as long as you do not reboot.
-#'
-#'   To have the cache persist even across multiple reboots, you can create the
-#'   cache in a location outside of the temp directory. For example, it could
-#'   be a subdirectory of the application:
-#'   \preformatted{
-#'   shinyOptions(cache = diskCache("./myapp-cache"))
-#'   }
-#'
-#'   In this case, resetting the cache will have to be done manually, by deleting
-#'   the directory.
-#'
-#'   You can also scope a cache to just one plot, or selected plots. To do that,
-#'   create a [memoryCache()] or [diskCache()], and pass it
-#'   as the `cache` argument of `renderCachedPlot`.
-#'
 #' @section Interactive plots:
 #'
 #'   `renderCachedPlot` can be used to create interactive plots. See
@@ -136,6 +48,7 @@
 #'
 #'
 #' @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.
@@ -146,14 +59,13 @@
 #'   possible pixel dimension. See [sizeGrowthRatio()] for more
 #'   information on the default sizing policy.
 #' @param res The resolution of the PNG, in pixels per inch.
-#' @param cache The scope of the cache, or a cache object. This can be
-#'   `"app"` (the default), `"session"`, or a cache object like
-#'   a [diskCache()]. See the Cache Scoping section for more
-#'   information.
+#' @param width,height not used. They are specified via the argument
+#'   `sizePolicy`.
 #'
-#' @seealso See [renderPlot()] for the regular, non-cached version of
-#'   this function. For more about configuring caches, see
-#'   [memoryCache()] and [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)
+  )
 }
 
 

R/render-plot.R

@@ -34,13 +34,19 @@
 #'   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 [grDevices::png()]. Note that this affects the resolution of PNG
+#'   passed to [plotPNG()]. Note that this affects the resolution of PNG
 #'   rendering in R; it won't change the actual ppi of the browser.
-#' @param ... Arguments to be passed through to [grDevices::png()].
+#' @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. If the value is `NA` (the
+#'   default), then `ggplot2::get_alt_text()` is used to extract alt text from
+#'   ggplot objects; for other plots, `NA` results in alt text of "Plot object".
+#'   `NULL` or `""` is not recommended because those should be limited to
+#'   decorative images.
+#' @param ... Arguments to be passed through to [plotPNG()].
 #'   These can be used to set the width, height, background color, etc.
-#' @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.
+#' @inheritParams renderUI
 #' @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`.
@@ -51,13 +57,19 @@
 #'   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 = NA,
+                       env = parent.frame(), quoted = FALSE,
+                       execOnResize = FALSE, outputArgs = list()
 ) {
-  # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
-  # is called
-  installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
+
+  func <- installExprFunction(
+    expr, "func", env, quoted,
+    label = "renderPlot",
+    # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
+    # is called
+    ..stacktraceon = TRUE
+  )
 
   args <- list(...)
 
@@ -75,7 +87,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()
 
@@ -94,6 +115,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
@@ -104,7 +126,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,
@@ -112,6 +134,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))
@@ -130,17 +153,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
         ))
 
@@ -156,15 +183,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 = installedFuncExpr(func), res = res)
+  )
+  class(markedFunc) <- c("shiny.renderPlot", class(markedFunc))
+  markedFunc
 }
 
-resizeSavedPlot <- function(name, session, result, width, height, pixelratio, res, ...) {
-  if (result$img$width == width && result$img$height == height &&
-      result$pixelratio == pixelratio && result$res == res) {
+resizeSavedPlot <- function(name, session, result, width, height, alt, pixelratio, res, ...) {
+  if (isTRUE(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)
@@ -176,6 +215,7 @@ resizeSavedPlot <- function(name, session, result, width, height, pixelratio, re
     src = session$fileUrl(name, outfile, contentType = "image/png"),
     width = width,
     height = height,
+    alt = result$alt,
     coordmap = coordmap,
     error = attr(coordmap, "error", exact = TRUE)
   )
@@ -183,7 +223,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
@@ -206,7 +246,7 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
   # 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)
+    showtext::showtext_opts(dpi = res*pixelratio)
   } else {
     NULL
   }
@@ -216,8 +256,9 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
       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
@@ -235,7 +276,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
@@ -250,6 +291,7 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
               recordedPlot = grDevices::recordPlot(),
               coordmap = getCoordmap(value, width*pixelratio, height*pixelratio, res*pixelratio),
               pixelratio = pixelratio,
+              alt = if (anyNA(alt)) getAltText(value) else alt,
               res = res
             )
           }
@@ -264,9 +306,10 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
     ),
     function(result) {
       result$img <- dropNulls(list(
-        src = session$fileUrl(name, outfile, contentType='image/png'),
+        src = session$fileUrl(name, outfile, contentType = 'image/png'),
         width = width,
         height = height,
+        alt = result$alt,
         coordmap = result$coordmap,
         # Get coordmap error message if present
         error = attr(result$coordmap, "error", exact = TRUE)
@@ -300,6 +343,24 @@ custom_print.ggplot <- function(x) {
   ), class = "ggplot_build_gtable")
 }
 
+# Infer alt text description from renderPlot() value
+# (currently just ggplot2 is supported)
+getAltText <- function(x, default = "Plot object") {
+  # Since, inside renderPlot(), custom_print.ggplot()
+  # overrides print.ggplot, this class indicates a ggplot()
+  if (!inherits(x, "ggplot_build_gtable")) {
+    return(default)
+  }
+  # ggplot2::get_alt_text() was added in v3.3.4
+  # https://github.com/tidyverse/ggplot2/pull/4482
+  get_alt <- getNamespace("ggplot2")$get_alt_text
+  if (!is.function(get_alt)) {
+    return(default)
+  }
+  alt <- paste(get_alt(x$build), collapse = " ")
+  if (nzchar(alt)) alt else default
+}
+
 # The coordmap extraction functions below return something like the examples
 # below. For base graphics:
 # plot(mtcars$wt, mtcars$mpg)
@@ -551,7 +612,7 @@ getGgplotCoordmap <- function(p, width, height, res) {
 find_panel_info <- function(b) {
   # Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
   # an API for extracting the necessary information.
-  ggplot_ver <- utils::packageVersion("ggplot2")
+  ggplot_ver <- get_package_version("ggplot2")
 
   if (ggplot_ver > "2.2.1") {
     find_panel_info_api(b)
@@ -571,6 +632,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.
@@ -587,8 +652,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
     )
   }
 

R/render-table.R

@@ -1,10 +1,12 @@
 #' Table Output
 #'
-#' Creates a reactive table that is suitable for assigning to an `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 `div` and have the CSS
-#' class name `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
 #'   [xtable::xtable()].
@@ -40,21 +42,37 @@
 #'   (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.
+#' @inheritParams renderUI
 #' @param outputArgs A list of arguments to be passed through to the
 #'   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())
+{
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderTable")
 
   if (!is.function(spacing)) spacing <- match.arg(spacing)
 

R/run-url.R

@@ -23,10 +23,10 @@
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
-#'   runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
+#'   runUrl('https://github.com/rstudio/shiny_example/archive/main.tar.gz')
 #'
 #'   # Can run an app from a subdirectory in the archive
-#'   runUrl("https://github.com/rstudio/shiny_example/archive/master.zip",
+#'   runUrl("https://github.com/rstudio/shiny_example/archive/main.zip",
 #'     subdir = "inst/shinyapp/")
 #' }
 runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
@@ -121,7 +121,8 @@ runGist <- function(gist, destdir = NULL, ...) {
 #' @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 `"master"`.
+#'   Defaults to `"HEAD"`, which means the default branch on GitHub, typically
+#'   `"main"` or `"master"`.
 #' @export
 #' @examples
 #' ## Only run this example in interactive R sessions
@@ -133,7 +134,7 @@ runGist <- function(gist, destdir = NULL, ...) {
 #'   runGitHub("shiny_example", "rstudio", subdir = "inst/shinyapp/")
 #' }
 runGitHub <- function(repo, username = getOption("github.user"),
-                      ref = "master", subdir = NULL, destdir = NULL, ...) {
+                      ref = "HEAD", subdir = NULL, destdir = NULL, ...) {
 
   if (grepl('/', repo)) {
     res <- strsplit(repo, '/')[[1]]

R/runapp.R

@@ -0,0 +1,590 @@
+#' 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 between 3000:8000, excluding ports that are blocked
+#'   by Google Chrome for being considered unsafe: 3659, 4045, 5060,
+#'   5061, 6000, 6566, 6665:6669 and 6697. Up to twenty random
+#'   ports will be tried.
+#' @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. The 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
+          # https://chromium.googlesource.com/chromium/src.git/+/refs/heads/main/net/base/port_util.cc
+          if (!port %in% c(3659, 4045, 5060, 5061, 6000, 6566, 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.
+#' @param package The package in which to find the example (defaults to
+#'   `"shiny"`).
+#'
+#'   To provide examples in your package, store examples in the
+#'   `inst/examples-shiny` directory of your package. Each example should be
+#'   in its own subdirectory and should be runnable when [runApp()] is called
+#'   on the subdirectory. Example apps can include a `DESCRIPTION` file and a
+#'   `README.md` file to provide metadata and commentary about the example. See
+#'   the article on [Display Modes](https://shiny.posit.co/r/articles/build/display-modes/)
+#'   on the Shiny website for more information.
+#' @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"),
+  package = "shiny"
+) {
+  if (!identical(package, "shiny") && !is_installed(package)) {
+    rlang::check_installed(package)
+  }
+
+  use_legacy_shiny_examples <-
+    identical(package, "shiny") &&
+    isTRUE(getOption('shiny.legacy.examples', FALSE))
+
+  examplesDir <- system_file(
+    if (use_legacy_shiny_examples) "examples" else "examples-shiny",
+    package = package
+  )
+
+  dir <- resolve(examplesDir, example)
+
+  if (is.null(dir)) {
+    valid_examples <- sprintf(
+      'Valid examples in {%s}: "%s"',
+      package,
+      paste(list.files(examplesDir), collapse = '", "')
+    )
+
+    if (is.na(example)) {
+      message(valid_examples)
+      return(invisible())
+    }
+
+    stop("Example '", example, "' does not exist. ", valid_examples)
+  }
+
+  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/serializers.R

@@ -5,7 +5,6 @@
 #'   value. The returned value will be used for the test snapshot.
 #' @param session A Shiny session object.
 #'
-#' @keywords internal
 #' @export
 setSerializer <- function(inputId, fun, session = getDefaultReactiveDomain()) {
   if (is.null(session)) {

R/server-input-handlers.R

@@ -1,18 +1,23 @@
-# Create a map for input handlers and register the defaults.
-inputHandlers <- Map$new()
+# Create a Map object for input handlers and register the defaults.
+# This is assigned in .onLoad time.
+inputHandlers <- NULL
+on_load({
+  inputHandlers <- Map$new()
+})
 
 #' Register an Input Handler
 #'
 #' Adds an input handler for data of this type. When called, Shiny will use the
 #' function provided to refine the data passed back from the client (after being
-#' deserialized by jsonlite) before making it available in the `input`
-#' variable of the `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 `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: `shiny.matrix`,
 #' `shiny.number`, and `shiny.date`.
@@ -20,35 +25,32 @@ inputHandlers <- Map$new()
 #' 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.
+#'   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
 #'   `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.
+#'   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)
 #' })
 #'
 #' ## On the Javascript side, the associated input binding must have a corresponding getType method:
-#' getType: function(el) {
-#'   return "mypackage.validint";
-#' }
+#' # getType: function(el) {
+#' #   return "mypackage.validint";
+#' # }
 #'
 #' }
-#' @seealso [removeInputHandler()]
+#' @seealso [removeInputHandler()] [applyInputHandlers()]
 #' @export
 registerInputHandler <- function(type, fun, force=FALSE){
   if (inputHandlers$containsKey(type) && !force){
@@ -127,115 +129,117 @@ applyInputHandlers <- function(inputs, shinysession = getDefaultReactiveDomain()
   inputs
 }
 
+on_load({
+  # Takes a list-of-lists and returns a matrix. The lists
+  # must all be the same length. NULL is replaced by NA.
+  registerInputHandler("shiny.matrix", function(data, ...) {
+    if (length(data) == 0)
+      return(matrix(nrow=0, ncol=0))
 
-# Takes a list-of-lists and returns a matrix. The lists
-# must all be the same length. NULL is replaced by NA.
-registerInputHandler("shiny.matrix", function(data, ...) {
-  if (length(data) == 0)
-    return(matrix(nrow=0, ncol=0))
-
-  m <- matrix(unlist(lapply(data, function(x) {
-    sapply(x, function(y) {
-      ifelse(is.null(y), NA, y)
-    })
-  })), nrow = length(data[[1]]), ncol = length(data))
-  return(m)
-})
-
-
-registerInputHandler("shiny.number", function(val, ...){
-  ifelse(is.null(val), NA, val)
-})
-
-registerInputHandler("shiny.password", function(val, shinysession, name) {
-  # Mark passwords as not serializable
-  setSerializer(name, serializerUnserializable)
-  val
-})
-
-registerInputHandler("shiny.date", function(val, ...){
-  # First replace NULLs with NA, then convert to Date vector
-  datelist <- ifelse(lapply(val, is.null), NA, val)
-
-  res <- NULL
-  tryCatch({
-      res <- as.Date(unlist(datelist))
-    },
-    error = function(e) {
-      # It's possible for client to send a string like "99999-01-01", which
-      # as.Date can't handle.
-      warning(e$message)
-      res <<- as.Date(rep(NA, length(datelist)))
-    }
-  )
-
-  res
-})
-
-registerInputHandler("shiny.datetime", function(val, ...){
-  # First replace NULLs with NA, then convert to POSIXct vector
-  times <- lapply(val, function(x) {
-    if (is.null(x)) NA
-    else x
+    m <- matrix(unlist(lapply(data, function(x) {
+      sapply(x, function(y) {
+        ifelse(is.null(y), NA, y)
+      })
+    })), nrow = length(data[[1]]), ncol = length(data))
+    return(m)
   })
-  as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
-})
-
-registerInputHandler("shiny.action", function(val, shinysession, name) {
-  # mark up the action button value with a special class so we can recognize it later
-  class(val) <- c(class(val), "shinyActionButtonValue")
-  val
-})
-
-registerInputHandler("shiny.file", function(val, shinysession, name) {
-  # This function is only used when restoring a Shiny fileInput. When a file is
-  # uploaded the usual way, it takes a different code path and won't hit this
-  # function.
-  if (is.null(val))
-    return(NULL)
-
-  # The data will be a named list of lists; convert to a data frame.
-  val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
-
-  # `val$datapath` should be a filename without a path, for security reasons.
-  if (basename(val$datapath) != val$datapath) {
-    stop("Invalid '/' found in file input path.")
-  }
-
-  # Prepend the persistent dir
-  oldfile <- file.path(getCurrentRestoreContext()$dir, val$datapath)
-
-  # Copy the original file to a new temp dir, so that a restored session can't
-  # modify the original.
-  newdir <- file.path(tempdir(), createUniqueId(12))
-  dir.create(newdir)
-  val$datapath <- file.path(newdir, val$datapath)
-  file.copy(oldfile, val$datapath)
-
-  # Need to mark this input value with the correct serializer. When a file is
-  # uploaded the usual way (instead of being restored), this occurs in
-  # session$`@uploadEnd`.
-  setSerializer(name, serializerFileInput)
-
-  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
-
-  val
-})
-
-
-# to be used with !!!answer
-registerInputHandler("shiny.symbolList", function(val, ...) {
-  if (is.null(val)) {
-    list()
-  } else {
-    lapply(val, as.symbol)
-  }
-})
-# to be used with !!answer
-registerInputHandler("shiny.symbol", function(val, ...) {
-  if (is.null(val) || identical(val, "")) {
-    NULL
-  } else {
-    as.symbol(val)
-  }
+
+
+  registerInputHandler("shiny.number", function(val, ...){
+    ifelse(is.null(val), NA, val)
+  })
+
+  registerInputHandler("shiny.password", function(val, shinysession, name) {
+    # Mark passwords as not serializable
+    setSerializer(name, serializerUnserializable)
+    val
+  })
+
+  registerInputHandler("shiny.date", function(val, ...){
+    # First replace NULLs with NA, then convert to Date vector
+    datelist <- ifelse(lapply(val, is.null), NA, val)
+
+    res <- NULL
+    tryCatch({
+        res <- as.Date(unlist(datelist))
+      },
+      error = function(e) {
+        # It's possible for client to send a string like "99999-01-01", which
+        # as.Date can't handle.
+        warning(e$message)
+        res <<- as.Date(rep(NA, length(datelist)))
+      }
+    )
+
+    res
+  })
+
+  registerInputHandler("shiny.datetime", function(val, ...){
+    # First replace NULLs with NA, then convert to POSIXct vector
+    times <- lapply(val, function(x) {
+      if (is.null(x)) NA
+      else x
+    })
+    as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
+  })
+
+  registerInputHandler("shiny.action", function(val, shinysession, name) {
+    # mark up the action button value with a special class so we can recognize it later
+    class(val) <- c("shinyActionButtonValue", class(val))
+    val
+  })
+
+  registerInputHandler("shiny.file", function(val, shinysession, name) {
+    # This function is only used when restoring a Shiny fileInput. When a file is
+    # uploaded the usual way, it takes a different code path and won't hit this
+    # function.
+    if (is.null(val))
+      return(NULL)
+
+    # The data will be a named list of lists; convert to a data frame.
+    val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
+
+    # `val$datapath` should be a filename without a path, for security reasons.
+    if (basename(val$datapath) != val$datapath) {
+      stop("Invalid '/' found in file input path.")
+    }
+
+    # Prepend the persistent dir
+    oldfile <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+
+    # Copy the original file to a new temp dir, so that a restored session can't
+    # modify the original.
+    newdir <- file.path(tempdir(), createUniqueId(12))
+    dir.create(newdir)
+    val$datapath <- file.path(newdir, val$datapath)
+    file.copy(oldfile, val$datapath)
+
+    # Need to mark this input value with the correct serializer. When a file is
+    # uploaded the usual way (instead of being restored), this occurs in
+    # session$`@uploadEnd`.
+    setSerializer(name, serializerFileInput)
+
+    snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
+
+    val
+  })
+
+
+  # to be used with !!!answer
+  registerInputHandler("shiny.symbolList", function(val, ...) {
+    if (is.null(val)) {
+      list()
+    } else {
+      lapply(val, as.symbol)
+    }
+  })
+  # to be used with !!answer
+  registerInputHandler("shiny.symbol", function(val, ...) {
+    if (is.null(val) || identical(val, "")) {
+      NULL
+    } else {
+      as.symbol(val)
+    }
+  })
+
 })

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

@@ -1,7 +1,12 @@
 #' @include server-input-handlers.R
 
-appsByToken <- Map$new()
-appsNeedingFlush <- Map$new()
+appsByToken <- NULL
+appsNeedingFlush <- NULL
+on_load({
+  appsByToken <- Map$new()
+  appsNeedingFlush <- Map$new()
+})
+
 
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
@@ -22,184 +27,16 @@ registerClient <- function(client) {
 }
 
 
-.globals$resourcePaths <- list()
-.globals$resources <- list()
-
 .globals$showcaseDefault <- 0
 
 .globals$showcaseOverride <- FALSE
 
-#' 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('^[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, "'")
-    }
-  )
-
-  # # 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")))
-  {
-    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))
-}
 
 #' Define Server Functionality
 #'
-#' Defines the server-side logic of the Shiny application. This generally
+#' @description `r lifecycle::badge("superseded")`
+#'
+#' @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.
@@ -217,7 +54,7 @@ resourcePathHandler <- function(req) {
 #' optional `session` parameter, which is used when greater control is
 #' needed.
 #'
-#' See the [tutorial](http://rstudio.github.com/shiny/tutorial/) for more
+#' See the [tutorial](https://shiny.rstudio.com/tutorial/) for more
 #' on how to write a server function.
 #'
 #' @param func The server function for this application. See the details section
@@ -246,6 +83,17 @@ 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)
 }
@@ -279,13 +127,16 @@ decodeMessage <- function(data) {
   return(mainMessage)
 }
 
-autoReloadCallbacks <- Callbacks$new()
+autoReloadCallbacks <- NULL
+on_load({
+  autoReloadCallbacks <- Callbacks$new()
+})
 
 createAppHandlers <- function(httpHandlers, serverFuncSource) {
   appvars <- new.env()
   appvars$server <- NULL
 
-  sys.www.root <- system.file('www', package='shiny')
+  sys.www.root <- system_file('www', package='shiny')
 
   # This value, if non-NULL, must be present on all HTTP and WebSocket
   # requests as the Shiny-Shared-Secret header or else access will be
@@ -307,7 +158,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       }
 
       if (identical(ws$request$PATH_INFO, "/autoreload/")) {
-        if (!getOption("shiny.autoreload", FALSE)) {
+        if (!get_devmode_option("shiny.autoreload", FALSE)) {
           ws$close()
           return(TRUE)
         }
@@ -488,7 +339,7 @@ argsForServerFunc <- function(serverFunc, session) {
 getEffectiveBody <- function(func) {
   if (is.null(func))
     NULL
-  else if (isS4(func) && class(func) == "functionWithTrace")
+  else if (isS4(func) && inherits(func, "functionWithTrace"))
     body(func@original)
   else
     body(func)
@@ -542,7 +393,7 @@ startApp <- function(appObj, port, host, quiet) {
     list(
       # Always handle /session URLs dynamically, even if / is a static path.
       "session" = excludeStaticPath(),
-      "shared" = system.file(package = "shiny", "www", "shared")
+      "shared" = system_file(package = "shiny", "www", "shared")
     ),
     .globals$resourcePaths
   )
@@ -644,9 +495,6 @@ serviceApp <- function() {
 
 .shinyServerMinVersion <- '0.3.4'
 
-# Global flag that's TRUE whenever we're inside of the scope of a call to runApp
-.globals$running <- FALSE
-
 #' Check whether a Shiny application is running
 #'
 #' This function tests whether a Shiny application is currently running.
@@ -655,589 +503,9 @@ serviceApp <- function() {
 #'   `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
-#' `"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 (.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())
-      }
-    })
-  )
-
-  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 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 `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.
-#'
-#' @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 `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
-}
-
-#' 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)
-  }
-}
 
 # Returns TRUE if we're running in Shiny Server or other hosting environment,
 # otherwise returns FALSE.

R/shiny-options.R

@@ -8,31 +8,55 @@ 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
 #'
-#' `getShinyOption()` retrieves the value of a Shiny option. `shinyOptions()`
-#' sets the value of Shiny options; it can also be used to return a list of all
-#' currently-set Shiny options.
+#' @description
 #'
-#' @section Scope:
-#' There is a global option set which is available by default. When a Shiny
-#' application is run with [runApp()], that option set is duplicated and the
-#' new option set is available for getting or setting values. If options
-#' are set from `global.R`, `app.R`, `ui.R`, or `server.R`, or if they are set
-#' from inside the server function, then the options will be scoped to the
-#' application. When the application exits, the new option set is discarded and
-#' the global option set is restored.
+#' 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.
 #'
-#' @section Options:
-#' There are a number of global options that affect Shiny's behavior. These can
-#' be set globally with `options()` or locally (for a single app) with
-#' `shinyOptions()`.
+#' 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."`.
+#'
+#' 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
@@ -64,12 +88,17 @@ getShinyOption <- function(name, default = NULL) {
 #' \item{shiny.host (defaults to `"127.0.0.1"`)}{The IP address that Shiny should listen on. See
 #'   [runApp()] for more information.}
 #' \item{shiny.jquery.version (defaults to `3`)}{The major version of jQuery to use.
-#' Currently only values of `3` or `1` are supported. If `1`, then jQuery 1.12.4 is used. If `3`,
-#' then jQuery 3.5.1 is used.}
-#' \item{shiny.json.digits (defaults to `16`)}{The number of digits to use when converting
-#'   numbers to JSON format to send to the client web browser.}
+#'   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 `I(16)`)}{Max number of digits to use when converting
+#'   numbers to JSON format to send to the client web browser. Use [I()] to specify significant digits.
+#'   Use `NA` for max precision.}
 #' \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.mathjax.url (defaults to `"https://mathjax.rstudio.com/latest/MathJax.js"`)}{
+#'   The URL that should be used to load MathJax, via [withMathJax()].}
+#' \item{shiny.mathjax.config (defaults to `"config=TeX-AMS-MML_HTMLorMML"`)}{The querystring
+#'   used to load MathJax, via [withMathJax()].}
 #' \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
@@ -84,7 +113,7 @@ getShinyOption <- function(name, default = NULL) {
 #'   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
+#'   generic error message is printed instead (the error and stack 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
@@ -101,52 +130,136 @@ getShinyOption <- function(name, default = NULL) {
 #'   console.}
 #' \item{shiny.testmode (defaults to `FALSE`)}{If `TRUE`, then various features for testing Shiny
 #'   applications are enabled.}
+#' \item{shiny.snapshotsortc (defaults to `FALSE`)}{If `TRUE`, test snapshot keys
+#'   for \pkg{shinytest} will be sorted consistently using the C locale.  Snapshots
+#'   retrieved by \pkg{shinytest2} will always sort using the C locale.}
 #' \item{shiny.trace (defaults to `FALSE`)}{Print messages sent between the R server and the web
 #'   browser client to the R console. This is useful for debugging. Possible
 #'   values are `"send"` (only print messages sent to the client),
 #'   `"recv"` (only print messages received by the server), `TRUE`
 #'   (print all messages), or `FALSE` (default; don't print any of these
 #'   messages).}
-#' \item{shiny.usecairo (defaults to `TRUE`)}{This is used to disable graphical rendering by the
-#'   Cairo package, if it is installed. See [plotPNG()] for more
-#'   information.}
+#' \item{shiny.autoload.r (defaults to `TRUE`)}{If `TRUE`, then the R/
+#'   of a shiny app will automatically be sourced.}
+#' \item{shiny.useragg (defaults to `TRUE`)}{Set to `FALSE` to prevent PNG rendering via the
+#'   ragg package. See [plotPNG()] for more information.}
+#' \item{shiny.usecairo (defaults to `TRUE`)}{Set to `FALSE` to prevent PNG rendering via the
+#'   Cairo package. 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
-#' @examples
-#' \dontrun{
-#' shinyOptions(myOption = 10)
-#' getShinyOption("myOption")
-#' }
 #' @export
 shinyOptions <- function(...) {
-  newOpts <- list(...)
+  newOpts <- list2(...)
 
   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")
@@ -157,9 +270,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,43 @@
+# See also R/reexports.R
+
+## usethis namespace: start
+#' @importFrom lifecycle deprecated is_present
+#' @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 enquo0 as_function get_expr get_env new_function enquos
+#'    eval_tidy expr pairlist2 new_quosure enexpr as_quosure is_quosure inject
+#'    quo_set_env quo_set_expr quo_get_expr
+#'    enquos0 zap_srcref %||% is_na
+#'    is_false list2
+#'    missing_arg is_missing maybe_missing
+#'    quo_is_missing fn_fmls<- fn_body fn_body<-
+#'    check_dots_empty check_dots_unnamed
+#' @import htmltools
+#' @import httpuv
+#' @import xtable
+#' @import R6
+#' @import mime
+## usethis namespace: end
+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
+
+
+# For usethis::use_release_issue()
+release_bullets <- function() {
+  c(
+    "Update static imports: `staticimports::import()`"
+  )
+}

R/shinyapp.R

@@ -93,8 +93,7 @@ shinyApp <- function(ui, server, 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(
@@ -114,7 +113,10 @@ shinyApp <- function(ui, server, 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
@@ -126,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"
+    )
   }
 }
 
@@ -188,7 +193,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     staticPaths <- list()
   }
 
-  fallbackWWWDir <- system.file("www-dir", package = "shiny")
+  fallbackWWWDir <- system_file("www-dir", package = "shiny")
 
   serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE,
     function(serverR) {
@@ -281,7 +286,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
-  if (!getOption("shiny.autoreload", FALSE)) {
+  if (!get_devmode_option("shiny.autoreload", FALSE)) {
     return(function(){})
   }
 
@@ -334,7 +339,7 @@ initAutoReloadMonitor <- function(dir) {
 #' @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
+#' @param renv The environment 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.
@@ -360,10 +365,12 @@ loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalren
   helpersDir <- file.path(appDir, "R")
 
   disabled <- list.files(helpersDir, pattern="^_disable_autoload\\.r$", recursive=FALSE, ignore.case=TRUE)
-  if (length(disabled) > 0){
+  if (length(disabled) > 0) {
     return(invisible(renv))
   }
 
+  warn_if_app_dir_is_package(appDir)
+
   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:
@@ -378,6 +385,27 @@ loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalren
   invisible(renv)
 }
 
+warn_if_app_dir_is_package <- function(appDir) {
+  has_namespace <- file.exists(file.path.ci(appDir, "NAMESPACE"))
+  has_desc_pkg <- FALSE
+
+  if (!has_namespace) {
+    descFile <- file.path.ci(appDir, "DESCRIPTION")
+
+    has_desc_pkg <-
+      file.exists(descFile) &&
+      identical(as.character(read.dcf(descFile, fields = "Type")), "Package")
+  }
+
+  if (has_namespace || has_desc_pkg) {
+    warning(
+      "Loading R/ subdirectory for Shiny application, but this directory appears ",
+      "to contain an R package. Sourcing files in R/ may cause unexpected behavior. ",
+      "See `?loadSupport` for more details."
+    )
+  }
+}
+
 # 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
@@ -385,27 +413,30 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
 {
   fullpath <- file.path.ci(appDir, fileName)
 
-  # In an upcoming version of shiny, this option will go away.
-  if (getOption("shiny.autoload.r", TRUE)) {
-    # Create a child env which contains all the helpers and will be the shared parent
-    # of the ui.R and server.R load.
-    sharedEnv <- new.env(parent = globalenv())
-  } else {
-    sharedEnv <- globalenv()
-  }
-
-
   # This sources app.R and caches the content. When appObj() is called but
   # app.R hasn't changed, it won't re-source the file. But if called and
   # app.R has changed, it'll re-source the file and return the result.
   appObj <- cachedFuncWithFile(appDir, fileName, case.sensitive = FALSE,
     function(appR) {
+      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)
     }
@@ -436,17 +467,13 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
     staticPaths <- list()
   }
 
-  fallbackWWWDir <- system.file("www-dir", package = "shiny")
+  fallbackWWWDir <- system_file("www-dir", package = "shiny")
 
   oldwd <- NULL
   monitorHandle <- NULL
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
-    # TODO: we should support hot reloading on R/*.R changes.
-    if (getOption("shiny.autoload.r", TRUE)) {
-      loadSupport(appDir, renv=sharedEnv, globalrenv=NULL)
-    }
     if (!is.null(appObj()$onStart)) appObj()$onStart()
     monitorHandle <<- initAutoReloadMonitor(appDir)
     invisible()
@@ -462,6 +489,8 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
     }
   }
 
+  appObjOptions <- appObj()$options
+
   structure(
     list(
       # fallbackWWWDir is _not_ listed in staticPaths, because it needs to
@@ -480,7 +509,7 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
       serverFuncSource = dynServerFuncSource,
       onStart = onStart,
       onStop = onStop,
-      options = options
+      options = joinOptions(appObjOptions, options)
     ),
     class = "shiny.appobj"
   )
@@ -530,18 +559,25 @@ is.shiny.appobj <- function(x) {
 }
 
 #' @rdname shiny.appobj
-#' @param ... Additional parameters to be passed to print.
+#' @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")]
+  runApp(x)
+}
 
-  # Quote x and put runApp in quotes so that there's a nicer stack trace (#1851)
-  args <- c(list(quote(x)), opts)
+# 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))
 
-  do.call("runApp", args)
+  mergeVectors(a, b)
 }
 
 #' @rdname shiny.appobj
@@ -551,7 +587,7 @@ 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
 
@@ -571,84 +607,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
-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.
-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/shinyui.R

@@ -14,7 +14,11 @@ NULL
 #' # now we can just write "static" content without withMathJax()
 #' div("more math here $$\\sqrt{2}$$")
 withMathJax <- function(...) {
-  path <- 'https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
+  path <- paste0(
+    getOption("shiny.mathjax.url", "https://mathjax.rstudio.com/latest/MathJax.js"),
+    "?",
+    getOption("shiny.mathjax.config", "config=TeX-AMS-MML_HTMLorMML")
+  )
   tagList(
     tags$head(
       singleton(tags$script(src = path, type = 'text/javascript'))
@@ -24,7 +28,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")) {
@@ -37,62 +43,153 @@ 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
+      system_file("template", "default.html", package = "shiny"),
+      lang = lang,
+      body = ui,
+      # this template is a complete HTML document
+      document_ = TRUE
     )
   }
 
-  jquery <- function() {
-    version <- getOption("shiny.jquery.version", 3)
-    if (version == 3) {
-      return(htmlDependency(
-        "jquery", "3.5.1",
-        c(href = "shared"),
-        script = "jquery.min.js"
-      ))
-    }
-    if (version == 1) {
-      return(htmlDependency(
-        "jquery", "1.12.4",
-        c(href = "shared/legacy"),
-        script = "jquery.min.js"
-      ))
-    }
-    stop("Unsupported version of jQuery: ", version)
-  }
-
-  shiny_deps <- list(
-    htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
-    jquery(),
-    htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
-      script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
-      stylesheet = "shiny.css")
+  shiny_deps <- c(
+    list(jqueryDependency()),
+    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",
+        get_package_version("shiny"),
+        src = "www/shared",
+        package = "shiny",
+        script = "shiny-testmode.js",
+        all_files = FALSE
+      )
   }
 
+  if (in_devmode()) {
+    # If we're in dev mode, add a simple script to the head that injects a
+    # global variable for the client to use to detect dev mode.
+    shiny_deps[[length(shiny_deps) + 1]] <-
+      htmlDependency(
+        "shiny-devmode",
+        get_package_version("shiny"),
+        src = "www/shared",
+        package = "shiny",
+        head="<script>window.__SHINY_DEV_MODE__ = true;</script>",
+        all_files = FALSE
+      )
+  }
+
+
   html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
-  writeUTF8(html, con = connection)
+  enc2utf8(paste(collapse = "\n", html))
+}
+
+jqueryDependency <- function() {
+  version <- getOption("shiny.jquery.version", 3)
+  if (version == 3) {
+    return(htmlDependency(
+      "jquery", version_jquery,
+      src = "www/shared",
+      package = "shiny",
+      script = "jquery.min.js",
+      all_files = FALSE
+    ))
+  }
+  if (version == 1) {
+    return(htmlDependency(
+      "jquery", "1.12.4",
+      src = "www/shared/legacy",
+      package = "shiny",
+      script = "jquery.min.js",
+      all_files = FALSE
+    ))
+  }
+  stop("Unsupported version of jQuery: ", version)
+}
+
+shinyDependencies <- function() {
+  list(
+    bslib::bs_dependency_defer(shinyDependencyCSS),
+    htmlDependency(
+      name = "shiny-javascript",
+      version = get_package_version("shiny"),
+      src = "www/shared",
+      package = "shiny",
+      script =
+        if (isTRUE(
+          get_devmode_option(
+            "shiny.minified",
+            TRUE
+          )
+        ))
+          "shiny.min.js"
+        else
+          "shiny.js",
+      all_files = FALSE
+    )
+  )
+}
+
+shinyDependencyCSS <- function(theme) {
+  version <- get_package_version("shiny")
+
+  if (!is_bs_theme(theme)) {
+    return(htmlDependency(
+      name = "shiny-css",
+      version = version,
+      src = "www/shared",
+      package = "shiny",
+      stylesheet = "shiny.min.css",
+      all_files = FALSE
+    ))
+  }
+
+  bs_version <- bslib::theme_version(theme)
+  bootstrap_scss <- paste0("shiny.bootstrap", bs_version, ".scss")
+
+  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 `r lifecycle::badge("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
 #' returns the value that is passed to it.
 #'
-#' @param ui A user interace definition
+#' @param ui A user interface 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
 }
@@ -101,16 +198,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)
@@ -118,7 +217,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")
@@ -150,8 +249,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,123 @@
-utils::globalVariables('func')
+utils::globalVariables('func', add = TRUE)
 
 #' Mark a function as a 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.
+#' `r lifecycle::badge("superseded")` Please use [`createRenderFunction()`] to
+#' support async execution. (Shiny 1.1.0)
+#'
+#' 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.
+#'
+#' Note that it is generally preferable to use [createRenderFunction()] instead
+#' of `markRenderFunction()`. It essentially wraps up the user-provided
+#' expression in the `transform` function passed to it, then passes the resulting
+#' function to `markRenderFunction()`. It also provides a simpler calling
+#' interface. There may be cases where `markRenderFunction()` must be used instead of
+#' [createRenderFunction()] -- for example, when the `transform` parameter of
+#' [createRenderFunction()] is not flexible enough for your needs.
 #'
 #' @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 `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).
+#'   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()]
 #' @export
-markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
+markRenderFunction <- function(
+  uiFunc,
+  renderFunc,
+  outputArgs = list(),
+  cacheHint = "auto",
+  cacheWriteHook = NULL,
+  cacheReadHook = NULL
+) {
+  # (Do not emit warning for superseded code, "since there’s no risk if you keep using it")
+  # # This method is called by the superseding function, createRenderFunction().
+  # if (in_devmode()) {
+  #   shinyDeprecated("1.1.0", "markRenderFunction()", "createRenderFunction()")
+  # }
+
+  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_quosure(x)) zap_srcref(quo_get_expr(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,15 +130,20 @@ 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
@@ -57,7 +151,27 @@ print.shiny.render.function <- function(x, ...) {
   cat_line("<shiny.render.function>")
 }
 
-#' Implement render functions
+#' Implement custom render functions
+#'
+#' Developer-facing utilities for implementing a custom `renderXXX()` function.
+#' Before using these utilities directly, consider using the [`htmlwidgets`
+#' package](http://www.htmlwidgets.org/develop_intro.html) to implement custom
+#' outputs (i.e., custom `renderXXX()`/`xxxOutput()` functions). That said,
+#' these utilities can be used more directly if a full-blown htmlwidget isn't
+#' needed and/or the user-supplied reactive expression needs to be wrapped in
+#' additional call(s).
+#'
+#' To implement a custom `renderXXX()` function, essentially 2 things are needed:
+#'   1. Capture the user's reactive expression as a function.
+#'      * New `renderXXX()` functions can use `quoToFunction()` for this, but
+#'      already existing `renderXXX()` functions that contain `env` and `quoted`
+#'      parameters may want to continue using `installExprFunction()` for better
+#'      legacy support (see examples).
+#'   2. Flag the resulting function (from 1) as a Shiny rendering function and
+#'   also provide a UI container for displaying the result of the rendering
+#'   function.
+#'      * `createRenderFunction()` is currently recommended (instead of
+#'      [markRenderFunction()]) for this step (see examples).
 #'
 #' @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
@@ -70,34 +184,99 @@ print.shiny.render.function <- function(x, ...) {
 #' @param outputFunc The UI function that is used (or most commonly used) with
 #'   this render function. This can be used in R Markdown documents to create
 #'   complete output widgets out of just the render function.
-#' @param outputArgs A list of arguments to pass to the `outputFunc`.
-#'   Render functions should include `outputArgs = list()` in their own
-#'   parameter list, and pass through the value as this argument, to allow app
-#'   authors to customize outputs. (Currently, this is only supported for
-#'   dynamically generated UIs, such as those created by Shiny code snippets
-#'   embedded in R Markdown documents).
+#' @inheritParams markRenderFunction
 #' @return An annotated render function, ready to be assigned to an
 #'   `output` slot.
 #'
+#' @examples
+#' # A custom render function that repeats the supplied value 3 times
+#' renderTriple <- function(expr) {
+#'   # Wrap user-supplied reactive expression into a function
+#'   func <- quoToFunction(rlang::enquo0(expr))
+#'
+#'   createRenderFunction(
+#'     func,
+#'     transform = function(value, session, name, ...) {
+#'       paste(rep(value, 3), collapse=", ")
+#'     },
+#'     outputFunc = textOutput
+#'   )
+#' }
+#'
+#' # For better legacy support, consider using installExprFunction() over quoToFunction()
+#' renderTripleLegacy <- function(expr, env = parent.frame(), quoted = FALSE) {
+#'   func <- installExprFunction(expr, "func", env, quoted)
+#'
+#'   createRenderFunction(
+#'     func,
+#'     transform = function(value, session, name, ...) {
+#'       paste(rep(value, 3), collapse=", ")
+#'     },
+#'     outputFunc = textOutput
+#'   )
+#' }
+#'
+#' # Test render function from the console
+#' reactiveConsole(TRUE)
+#'
+#' v <- reactiveVal("basic")
+#' r <- renderTriple({ v() })
+#' r()
+#' #> [1] "basic, basic, basic"
+#'
+#' # User can supply quoted code via rlang::quo(). Note that evaluation of the
+#' # expression happens when r2() is invoked, not when r2 is created.
+#' q <- rlang::quo({ v() })
+#' r2 <- rlang::inject(renderTriple(!!q))
+#' v("rlang")
+#' r2()
+#' #> [1] "rlang, rlang, rlang"
+#'
+#' # Supplying quoted code without rlang::quo() requires installExprFunction()
+#' expr <- quote({ v() })
+#' r3 <- renderTripleLegacy(expr, quoted = TRUE)
+#' v("legacy")
+#' r3()
+#' #> [1] "legacy, legacy, legacy"
+#'
+#' # The legacy approach also supports with quosures (env is ignored in this case)
+#' q <- rlang::quo({ v() })
+#' r4 <- renderTripleLegacy(q, quoted = TRUE)
+#' v("legacy-rlang")
+#' r4()
+#' #> [1] "legacy-rlang, legacy-rlang, legacy-rlang"
+#'
+#' # Turn off reactivity in the console
+#' reactiveConsole(FALSE)
+#'
 #' @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) {
@@ -140,6 +319,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
 #'
@@ -192,9 +387,7 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #'   the output, see [plotPNG()].
 #'
 #' @param expr An expression that returns a list.
-#' @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.
+#' @inheritParams renderUI
 #' @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 `func`, then this should be `TRUE`;
@@ -273,9 +466,10 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #'
 #' shinyApp(ui, server)
 #' }
-renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
-                        deleteFile, outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
+renderImage <- function(expr, env = parent.frame(), quoted = FALSE,
+                        deleteFile, outputArgs=list())
+{
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderImage")
 
   # missing() must be used directly within the function with the given arg
   if (missing(deleteFile)) {
@@ -324,7 +518,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
       }
 
       # 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')]
@@ -333,7 +527,10 @@ 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
@@ -372,41 +569,40 @@ isTemp <- function(path, tempDir = tempdir(), mustExist) {
   return(substr(path, 1, nchar(tempDir)) == tempDir)
 }
 
-#' Printable Output
+#' Text Output
 #'
-#' Makes a reactive version of the given function that captures any printed
-#' output, and also captures its printable result (unless
-#' [base::invisible()]), into a string. The resulting function is suitable
-#' for assigning to an  `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`.
 #'
+#' `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 `shiny-text-output`.
 #'
-#' The result of executing `func` will be printed inside a
-#' [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 `NULL` then `NULL` will actually be visible in the output.
-#' To display nothing, make your function return [base::invisible()].
-#'
-#' @param expr An expression that may print output and/or return a printable R
-#'   object.
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
-#' @param width The value for `[options][base::options]('width')`.
+#' @param expr An expression to evaluate.
+#' @inheritParams renderUI
+#' @param width Width of printed output.
 #' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to [verbatimTextOutput()] when `renderPrint` is used
-#'   in an interactive R Markdown document.
-#' @seealso [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())
+{
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderPrint")
 
   # Set a promise domain that sets the console width
   #   and captures output
@@ -419,12 +615,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)
@@ -432,7 +628,15 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     )
   }
 
-  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
+  markRenderFunction(
+    verbatimTextOutput,
+    renderFunc,
+    outputArgs,
+    cacheHint = list(
+      label = "renderPrint",
+      origUserExpr = installedFuncExpr(func)
+    )
+  )
 }
 
 createRenderPrintPromiseDomain <- function(width) {
@@ -476,45 +680,22 @@ createRenderPrintPromiseDomain <- function(width) {
   )
 }
 
-#' Text Output
-#'
-#' Makes a reactive version of the given function that also uses
-#' [base::cat()] to turn its result into a single-element character
-#' vector.
-#'
-#' 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 `shiny-text-output`.
-#'
-#' The result of executing `func` will passed to `cat`, inside a
-#' [utils::capture.output()] call.
-#'
-#' @param expr An expression that returns an R object that can be used as an
-#'   argument to `cat`.
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
-#' @param outputArgs A list of arguments to be passed through to the implicit
-#'   call to [textOutput()] when `renderText` is used in an
-#'   interactive R Markdown document.
 #' @param sep A separator passed to `cat` to be appended after each
 #'   element.
-#'
-#' @seealso [renderPrint()] for capturing the print output of a
-#'   function, rather than the returned text value.
-#'
-#' @example res/text-example.R
 #' @export
-renderText <- function(expr, env=parent.frame(), quoted=FALSE,
+#' @rdname renderPrint
+renderText <- function(expr, env = parent.frame(), quoted = FALSE,
                        outputArgs=list(), sep=" ") {
-  installExprFunction(expr, "func", env, quoted)
+
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderText")
 
   createRenderFunction(
     func,
     function(value, session, name, ...) {
       paste(utils::capture.output(cat(value, sep=sep)), collapse="\n")
     },
-    textOutput, outputArgs
+    textOutput,
+    outputArgs
   )
 }
 
@@ -527,9 +708,13 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' @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 `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
+#' @template param-env
+#' @templateVar x expr
+#' @templateVar env env
+#' @templateVar quoted quoted
+#' @template param-quoted
+#' @templateVar x expr
+#' @templateVar quoted quoted
 #' @param outputArgs A list of arguments to be passed through to the implicit
 #'   call to [uiOutput()] when `renderUI` is used in an
 #'   interactive R Markdown document.
@@ -555,9 +740,10 @@ 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())
+{
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderUI")
 
   createRenderFunction(
     func,
@@ -567,7 +753,8 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
 
       processDeps(result, shinysession)
     },
-    uiOutput, outputArgs
+    uiOutput,
+    outputArgs
   )
 }
 
@@ -590,10 +777,10 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
 #'   that file path. (Reactive values and functions may be used from this
 #'   function.)
 #' @param contentType A string of the download's
-#'   [content type](http://en.wikipedia.org/wiki/Internet_media_type), for
-#'   example `"text/csv"` or `"image/png"`. If `NULL` or
-#'   `NA`, the content type will be guessed based on the filename
-#'   extension, or `application/octet-stream` if the extension is unknown.
+#'   [content type](https://en.wikipedia.org/wiki/Internet_media_type), for
+#'   example `"text/csv"` or `"image/png"`. If `NULL`, 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 [downloadButton()] when `downloadHandler` is used
 #'   in an interactive R Markdown document.
@@ -623,37 +810,42 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
 #' shinyApp(ui, server)
 #' }
 #' @export
-downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()) {
+downloadHandler <- function(filename, content, contentType=NULL, outputArgs=list()) {
   renderFunc <- function(shinysession, name, ...) {
     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
 #'
-#' 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.
+#' @description
+#' `r lifecycle::badge("deprecated")`
+#'
+#' This function is deprecated, use
+#' [DT::renderDT()](https://rstudio.github.io/DT/shiny.html) instead. It
+#' provides a superset of functionality, better performance, and better user
+#' experience.
 #'
-#' For the `options` argument, the character elements that have the class
-#' `"AsIs"` (usually returned from [base::I()]) will be evaluated in
-#' JavaScript. This is useful when the type of the option value is not supported
-#' in JSON, e.g., a JavaScript function, which can be obtained by evaluating a
-#' character string. Note this only applies to the root-level elements of the
-#' options list, and the `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 (<http://datatables.net/extensions/>).
+#'   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
@@ -661,17 +853,8 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #'   `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 [dataTableOutput()] when `renderDataTable` is used
+#'   call to `dataTableOutput()` when `renderDataTable()` is used
 #'   in an interactive R Markdown document.
-#'
-#' @references <http://datatables.net>
-#' @note This function only provides the server-side version of DataTables
-#'   (using R to process the data object on the server side). There is a
-#'   separate package \pkg{DT} (<https://github.com/rstudio/DT>) that allows
-#'   you to create both server-side and client-side DataTables, and supports
-#'   additional DataTables features. Consider using `DT::renderDataTable()`
-#'   and `DT::dataTableOutput()` (see
-#'   <http://rstudio.github.io/DT/shiny.html> for more information).
 #' @export
 #' @inheritParams renderPlot
 #' @examples
@@ -696,11 +879,62 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #'     }
 #'   )
 #' }
+#' @keywords internal
 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()) {
+
+  legacy <- useLegacyDataTable(
+    from = "shiny::renderDataTable()",
+    to = "DT::renderDT()"
+  )
+
+  if (!quoted) {
+    expr <- substitute(expr)
+    quoted <- TRUE
+  }
+
+  if (legacy) {
+
+    legacyRenderDataTable(
+      expr, env = env, quoted = quoted,
+      options = options,
+      searchDelay = searchDelay,
+      callback = callback,
+      escape = escape,
+      outputArgs = outputArgs
+    )
+
+  } else {
+
+    if (!missing(searchDelay)) {
+      warning("Ignoring renderDataTable()'s searchDelay value (since DT::renderDT() has no equivalent).")
+    }
+
+    force(options)
+    force(callback)
+    force(escape)
+    force(outputArgs)
+
+    DT::renderDataTable(
+      expr, env = env, quoted = quoted,
+      options = if (is.null(options)) list() else options,
+      # Turn function into a statement
+      callback = DT::JS(paste0("(", callback, ")(table)")),
+      escape = escape,
+      outputArgs = outputArgs
+    )
+  }
+}
+
+
+legacyRenderDataTable <- function(expr, options = NULL, searchDelay = 500,
+                                  callback = 'function(oTable) {}', escape = TRUE,
+                                  env = parent.frame(), quoted = FALSE,
+                                  outputArgs=list()) {
+
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderDataTable")
 
   renderFunc <- function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
@@ -734,7 +968,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
@@ -752,7 +987,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
 DT10Names <- function() {
   rbind(
     utils::read.table(
-      system.file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
+      system_file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
       stringsAsFactors = FALSE
     ),
     c('aoColumns', 'Removed')  # looks like an omission on the upgrade guide
@@ -787,64 +1022,3 @@ checkDT9 <- function(options) {
   names(options)[i] <- nms10
   options
 }
-
-# Deprecated functions ------------------------------------------------------
-
-#' Deprecated reactive functions
-#' @name deprecatedReactives
-#' @keywords internal
-NULL
-
-#' Plot output (deprecated)
-#'
-#' `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")
-  renderPlot({ func() }, width=width, height=height, ...)
-}
-
-#' Table output (deprecated)
-#'
-#' `reactiveTable` has been replaced by [renderTable()].
-#' @rdname deprecatedReactives
-#' @export
-reactiveTable <- function(func, ...) {
-  shinyDeprecated(new="renderTable")
-  renderTable({ func() })
-}
-
-#' Print output (deprecated)
-#'
-#' `reactivePrint` has been replaced by [renderPrint()].
-#' @rdname deprecatedReactives
-#' @export
-reactivePrint <- function(func) {
-  shinyDeprecated(new="renderPrint")
-  renderPrint({ func() })
-}
-
-#' UI output (deprecated)
-#'
-#' `reactiveUI` has been replaced by [renderUI()].
-#' @rdname deprecatedReactives
-#' @export
-reactiveUI <- function(func) {
-  shinyDeprecated(new="renderUI")
-  renderUI({ func() })
-}
-
-#' Text output (deprecated)
-#'
-#' `reactiveText` has been replaced by [renderText()].
-#' @rdname deprecatedReactives
-#' @export
-reactiveText <- function(func) {
-  shinyDeprecated(new="renderText")
-  renderText({ func() })
-}

R/showcase.R

@@ -32,26 +32,40 @@ licenseLink <- function(licenseName) {
 showcaseHead <- function() {
 
   deps  <- list(
-    htmlDependency("jqueryui", "1.12.1", c(href="shared/jqueryui"),
-      script = "jquery-ui.min.js"),
-    htmlDependency("showdown", "0.3.1", c(href="shared/showdown/compressed"),
-      script = "showdown.js"),
-    htmlDependency("highlight.js", "6.2", c(href="shared/highlight"),
-      script = "highlight.pack.js")
+    jqueryuiDependency(),
+    htmlDependency(
+      "showdown",
+      "0.3.1",
+      src = "www/shared/showdown/compressed",
+      package="shiny",
+      script = "showdown.js"
+    ),
+    htmlDependency(
+      "highlight.js",
+      "6.2",
+      src = "www/shared/highlight",
+      package="shiny",
+      script = "highlight.pack.js",
+      stylesheet = "rstudio.css"
+    ),
+    htmlDependency(
+      "showcase",
+      "0.1.0",
+      src = "www/shared",
+      package = "shiny",
+      script = "shiny-showcase.js",
+      stylesheet = "shiny-showcase.css",
+      all_files = FALSE
+    )
   )
 
   mdfile <- file.path.ci(getwd(), 'Readme.md')
-  html <- with(tags, tagList(
-    script(src="shared/shiny-showcase.js"),
-    link(rel="stylesheet", type="text/css",
-         href="shared/highlight/rstudio.css"),
-    link(rel="stylesheet", type="text/css",
-         href="shared/shiny-showcase.css"),
+  html <- tagList(
     if (file.exists(mdfile))
-      script(type="text/markdown", id="showcase-markdown-content",
+      tags$script(type="text/markdown", id="showcase-markdown-content",
         paste(readUTF8(mdfile), collapse="\n"))
     else ""
-  ))
+  )
 
   return(attachDependencies(html, deps))
 }
@@ -83,7 +97,7 @@ navTabsHelper <- function(files, prefix = "") {
     with(tags,
       li(class=if (tolower(file) %in% c("app.r", "server.r")) "active" else "",
          a(href=paste("#", gsub(".", "_", file, fixed=TRUE), "_code", sep=""),
-           "data-toggle"="tab", paste0(prefix, file)))
+           "data-toggle"="tab", "data-bs-toggle"="tab", paste0(prefix, file)))
     )
   })
 }
@@ -92,7 +106,7 @@ navTabsDropdown <- function(files) {
   if (length(files) > 0) {
     with(tags,
       li(role="presentation", class="dropdown",
-        a(class="dropdown-toggle", `data-toggle`="dropdown", href="#",
+        a(class="dropdown-toggle", `data-toggle`="dropdown", `data-bs-toggle`="dropdown", href="#",
           role="button", `aria-haspopup`="true", `aria-expanded`="false",
           "www", span(class="caret")
         ),
@@ -134,7 +148,7 @@ showcaseCodeTabs <- function(codeLicense) {
     a(id="showcase-code-position-toggle",
       class="btn btn-default btn-sm",
       onclick="toggleCodePosition()",
-      icon("level-up"),
+      icon("level-up-alt"),
       "show with app"),
     ul(class="nav nav-tabs",
        navTabsHelper(rFiles),
@@ -220,4 +234,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/staticimports.R

@@ -0,0 +1,200 @@
+# Generated by staticimports; do not edit by hand.
+# ======================================================================
+# Imported from pkg:staticimports
+# ======================================================================
+
+# Given a vector, return TRUE if any elements are named, FALSE otherwise.
+# For zero-length vectors, always return FALSE.
+any_named <- function(x) {
+  if (length(x) == 0) return(FALSE)
+  nms <- names(x)
+  !is.null(nms) && any(nzchar(nms))
+}
+
+# Given a vector, return TRUE if any elements are unnamed, FALSE otherwise.
+# For zero-length vectors, always return FALSE.
+any_unnamed <- function(x) {
+  if (length(x) == 0) return(FALSE)
+  nms <- names(x)
+  is.null(nms) || !all(nzchar(nms))
+}
+
+# Borrowed from pkgload:::dev_meta, with some modifications.
+# Returns TRUE if `pkg` was loaded with `devtools::load_all()`.
+devtools_loaded <- function(pkg) {
+  ns <- .getNamespace(pkg)
+  if (is.null(ns) || is.null(ns$.__DEVTOOLS__)) {
+    return(FALSE)
+  }
+  TRUE
+}
+
+get_package_version <- function(pkg) {
+  # `utils::packageVersion()` can be slow, so first try the fast path of
+  # checking if the package is already loaded.
+  ns <- .getNamespace(pkg)
+  if (is.null(ns)) {
+    utils::packageVersion(pkg)
+  } else {
+    as.package_version(ns$.__NAMESPACE__.$spec[["version"]])
+  }
+}
+
+is_installed <- function(pkg, version = NULL) {
+  installed <- isNamespaceLoaded(pkg) || nzchar(system_file_cached(package = pkg))
+
+  if (is.null(version)) {
+    return(installed)
+  }
+
+  if (!is.character(version) && !inherits(version, "numeric_version")) {
+    # Avoid https://bugs.r-project.org/show_bug.cgi?id=18548
+    alert <- if (identical(Sys.getenv("TESTTHAT"), "true")) stop else warning
+    alert("`version` must be a character string or a `package_version` or `numeric_version` object.")
+
+    version <- numeric_version(sprintf("%0.9g", version))
+  }
+
+  installed && isTRUE(get_package_version(pkg) >= version)
+}
+
+# Simplified version rlang:::s3_register() that just uses
+# warning() instead of rlang::warn() when registration fails
+# https://github.com/r-lib/rlang/blob/main/R/compat-s3-register.R
+s3_register <- function(generic, class, method = NULL) {
+  stopifnot(is.character(generic), length(generic) == 1)
+  stopifnot(is.character(class), length(class) == 1)
+
+  pieces <- strsplit(generic, "::")[[1]]
+  stopifnot(length(pieces) == 2)
+  package <- pieces[[1]]
+  generic <- pieces[[2]]
+
+  caller <- parent.frame()
+
+  get_method_env <- function() {
+    top <- topenv(caller)
+    if (isNamespace(top)) {
+      asNamespace(environmentName(top))
+    } else {
+      caller
+    }
+  }
+  get_method <- function(method, env) {
+    if (is.null(method)) {
+      get(paste0(generic, ".", class), envir = get_method_env())
+    } else {
+      method
+    }
+  }
+
+  register <- function(...) {
+    envir <- asNamespace(package)
+
+    # Refresh the method each time, it might have been updated by
+    # `devtools::load_all()`
+    method_fn <- get_method(method)
+    stopifnot(is.function(method_fn))
+
+    # Only register if generic can be accessed
+    if (exists(generic, envir)) {
+      registerS3method(generic, class, method_fn, envir = envir)
+    } else {
+      warning(
+        "Can't find generic `", generic, "` in package ", package,
+        " register S3 method. Do you need to update ", package,
+        " to the latest version?", call. = FALSE
+      )
+    }
+  }
+
+  # Always register hook in case package is later unloaded & reloaded
+  setHook(packageEvent(package, "onLoad"), function(...) {
+    register()
+  })
+
+  # Avoid registration failures during loading (pkgload or regular).
+  # Check that environment is locked because the registering package
+  # might be a dependency of the package that exports the generic. In
+  # that case, the exports (and the generic) might not be populated
+  # yet (#1225).
+  if (isNamespaceLoaded(package) && environmentIsLocked(asNamespace(package))) {
+    register()
+  }
+
+  invisible()
+}
+
+# Borrowed from pkgload::shim_system.file, with some modifications. This behaves
+# like `system.file()`, except that (1) for packages loaded with
+# `devtools::load_all()`, it will return the path to files in the package's
+# inst/ directory, and (2) for other packages, the directory lookup is cached.
+# Also, to keep the implementation simple, it doesn't support specification of
+# lib.loc or mustWork.
+system_file <- function(..., package = "base") {
+  if (!devtools_loaded(package))  {
+    return(system_file_cached(..., package = package))
+  }
+
+  if (!is.null(names(list(...)))) {
+    stop("All arguments other than `package` must be unnamed.")
+  }
+
+  # If package was loaded with devtools (the package loaded with load_all),
+  # also search for files under inst/, and don't cache the results (it seems
+  # more likely that the package path will change during the development
+  # process)
+  pkg_path <- find.package(package)
+
+  # First look in inst/
+  files_inst <- file.path(pkg_path, "inst", ...)
+  present_inst <- file.exists(files_inst)
+
+  # For any files that weren't present in inst/, look in the base path
+  files_top <- file.path(pkg_path, ...)
+  present_top <- file.exists(files_top)
+
+  # Merge them together. Here are the different possible conditions, and the
+  # desired result. NULL means to drop that element from the result.
+  #
+  # files_inst:   /inst/A  /inst/B  /inst/C  /inst/D
+  # present_inst:    T        T        F        F
+  # files_top:      /A       /B       /C       /D
+  # present_top:     T        F        T        F
+  # result:       /inst/A  /inst/B    /C       NULL
+  #
+  files <- files_top
+  files[present_inst] <- files_inst[present_inst]
+  # Drop cases where not present in either location
+  files <- files[present_inst | present_top]
+  if (length(files) == 0) {
+    return("")
+  }
+  # Make sure backslashes are replaced with slashes on Windows
+  normalizePath(files, winslash = "/")
+}
+
+# A wrapper for `system.file()`, which caches the package path because
+# `system.file()` can be slow. If a package is not installed, the result won't
+# be cached.
+system_file_cached <- local({
+  pkg_dir_cache <- character()
+
+  function(..., package = "base") {
+    if (!is.null(names(list(...)))) {
+      stop("All arguments other than `package` must be unnamed.")
+    }
+
+    not_cached <- is.na(match(package, names(pkg_dir_cache)))
+    if (not_cached) {
+      pkg_dir <- system.file(package = package)
+      if (nzchar(pkg_dir)) {
+        pkg_dir_cache[[package]] <<- pkg_dir
+      }
+    } else {
+      pkg_dir <- pkg_dir_cache[[package]]
+    }
+
+    file.path(pkg_dir, ...)
+  }
+})

R/test-server.R

@@ -1,23 +1,20 @@
-#' @noRd
-isModuleServer <- function(x) {
-  is.function(x) && names(formals(x))[1] == "id"
-}
-
 #' Reactive testing for Shiny server functions and modules
 #'
 #' A way to test the reactive interactions in Shiny applications. Reactive
 #' interactions are defined in the server function of applications and in
 #' modules.
-#' @param app The path to an application or module to test. In addition to
-#'   paths, applications may be represented by any object suitable for coercion
-#'   to an `appObj` by [`as.shiny.appobj`]. Application server functions must
-#'   include a `session` argument in order to be tested. If `app` is `NULL` or
-#'   not supplied, the nearest enclosing directory that is a Shiny app, starting
-#'   with the current directory, is used.
-#' @param expr Test code containing expectations. The test expression will run
-#'   in the server function environment, meaning that the parameters of the
-#'   server function (e.g. `input`, `output`, and `session`) will be available
-#'   along with any other values created inside of the server function.
+#' @param 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.
@@ -28,7 +25,19 @@ isModuleServer <- function(x) {
 #' @include mock-session.R
 #' @rdname testServer
 #' @examples
-#' server <- function(id, multiplier = 2, prefix = "I am ") {
+#' # 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
@@ -39,7 +48,7 @@ isModuleServer <- function(x) {
 #'   })
 #' }
 #'
-#' testServer(server, args = list(multiplier = 2), {
+#' testServer(myModuleServer, args = list(multiplier = 2), {
 #'   session$setInputs(x = 1)
 #'   # You're also free to use third-party
 #'   # testing packages like testthat:
@@ -54,74 +63,94 @@ isModuleServer <- function(x) {
 #' })
 #' @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)
 
-  on.exit(if (!session$isClosed()) session$close())
-
-  withMockContext <- function(expr) {
-    isolate(
-      withReactiveDomain(session, {
-        withr::with_options(list(`shiny.allowoutputreads` = TRUE), {
-          withLocalOptions({
-            # Sets a cache for renderCachedPlot() with cache = "app" to use.
-            shinyOptions("cache" = session$appcache)
-            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(rlang::exec(app, !!!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(rlang::eval_tidy(quosure, mask, rlang::caller_env()))
-  } else {
-    if (is.null(app)) {
-      app <- findEnclosingApp(".")
-    }
-
-    appobj <- as.shiny.appobj(app)
-    if (!is.null(appobj$onStart))
-      appobj$onStart()
-    # Ensure appobj$onStop() is called, and the current directory is restored,
-    # regardless of whether invoking the server function is successful.
-    tryCatch({
-      server <- appobj$serverFuncSource()
-      if (! "session" %in% names(formals(server)))
-        stop("Tested application server functions must declare input, output, and session arguments.")
-      body(server) <- rlang::expr({
-        session$setEnv(base::environment())
-        !!body(server)
-      })
-      if (length(args))
-        stop("Arguments were provided to a server function.")
-      withMockContext(server(input = session$input, output = session$output, session = session))
-    }, finally = {
-      if (!is.null(appobj$onStop))
-        appobj$onStop()
-    })
-
-    # 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(rlang::eval_tidy(quosure, mask, rlang::caller_env()))
+    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/update-input.R

@@ -1,8 +1,7 @@
 #' 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 [textInput()]
 #'
@@ -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)
 }
@@ -82,7 +83,7 @@ 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 [checkboxInput()]
 #'
@@ -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,8 +119,9 @@ 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 `icon=character(0)`.
+#' @param disabled If `TRUE`, the button will not be clickable; if `FALSE`, it
+#'   will be.
+#' @inheritParams actionButton
 #'
 #' @seealso [actionButton()]
 #'
@@ -146,13 +150,13 @@ updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
 #'       label = "New label",
 #'       icon = icon("calendar"))
 #'
-#'     # Leaves goButton2's label unchaged and
+#'     # Leaves goButton2's label unchanged and
 #'     # removes its icon
 #'     updateActionButton(session, "goButton2",
 #'       icon = character(0))
 #'
 #'     # Leaves goButton3's icon, if it exists,
-#'     # unchaged and changes its label
+#'     # unchanged and changes its label
 #'     updateActionButton(session, "goButton3",
 #'       label = "New label 3")
 #'
@@ -167,25 +171,24 @@ updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
 #' }
 #' @rdname updateActionButton
 #' @export
-updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
+updateActionButton <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL, disabled = NULL) {
+  validate_session_object(session)
+
   if (!is.null(icon)) icon <- as.character(validateIcon(icon))
-  message <- dropNulls(list(label=label, icon=icon))
+  message <- dropNulls(list(label=label, icon=icon, disabled=disabled))
   session$sendInputMessage(inputId, message)
 }
 #' @rdname updateActionButton
 #' @export
-updateActionLink <- updateActionButton
+updateActionLink <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL) {
+  updateActionButton(session, inputId=inputId, label=label, icon=icon)
+}
 
 
 #' 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
-#'   `yyyy-mm-dd` format. Supply `NA` to clear the date.
-#' @param min The minimum allowed date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format.
-#' @param max The maximum allowed date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format.
+#' @inheritParams dateInput
 #'
 #' @seealso [dateInput()]
 #'
@@ -213,8 +216,10 @@ updateActionLink <- updateActionButton
 #' 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)
 
   value <- dateYMD(value, "value")
   min   <- dateYMD(min, "min")
@@ -228,14 +233,7 @@ 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
-#'   `yyyy-mm-dd` format. Supplying `NA` clears the start date.
-#' @param end The end date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format. Supplying `NA` clears the end date.
-#' @param min The minimum allowed date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format.
-#' @param max The maximum allowed date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format.
+#' @inheritParams dateRangeInput
 #'
 #' @seealso [dateRangeInput()]
 #'
@@ -265,9 +263,11 @@ 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) {
+                                 max = NULL)
+{
+  validate_session_object(session)
 
   start <- dateYMD(start, "start")
   end <- dateYMD(end, "end")
@@ -287,10 +287,10 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 #' Change the selected tab on the client
 #'
 #' @param session The `session` object passed to function given to
-#'   `shinyServer`.
+#'   `shinyServer`. Default is `getDefaultReactiveDomain()`.
 #' @param inputId The id of the `tabsetPanel`, `navlistPanel`,
 #' or `navbarPage` object.
-#' @param selected The name of the tab to make active.
+#' @inheritParams tabsetPanel
 #'
 #' @seealso [tabsetPanel()], [navlistPanel()],
 #' [navbarPage()]
@@ -323,7 +323,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)
 }
@@ -339,10 +341,7 @@ 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 [numericInput()]
 #'
@@ -374,9 +373,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)
@@ -389,12 +390,7 @@ 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 [sliderInput()]
 #'
@@ -426,9 +422,28 @@ 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 (!is.null(value)) {
+    if (!is.null(min) && !is.null(max)) {
+      # Validate value/min/max together if all three are provided
+      tryCatch(
+        validate_slider_value(min, max, value, "updateSliderInput"),
+        error = function(err) warning(conditionMessage(err), call. = FALSE)
+      )
+    } else if (length(value) <  1 || length(value) > 2 || any(is.na(value))) {
+      # Otherwise ensure basic assumptions about value are met
+      warning(
+        "In updateSliderInput(): value must be a single value or a length-2 ",
+        "vector and cannot contain NA values.",
+        call. = FALSE
+      )
+    }
+  }
+
   # 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)
@@ -461,6 +476,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)
@@ -518,9 +535,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)
 }
@@ -561,9 +581,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]]
@@ -613,11 +636,14 @@ 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)
 }
@@ -629,9 +655,12 @@ updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
 #'   `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(
@@ -744,12 +773,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,
@@ -760,7 +792,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,249 @@
+# 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))
+  )
+}
+
+
+#' @describeIn createRenderFunction convert a quosure to a function.
+#' @param q Quosure of the expression `x`. When capturing expressions to create
+#'   your quosure, it is recommended to use [`enquo0()`] to not unquote the
+#'   object too early. See [`enquo0()`] for more details.
+#' @inheritParams installExprFunction
+#' @export
+quoToFunction <- function(
+  q,
+  label = sys.call(-1)[[1]],
+  ..stacktraceon = FALSE
+) {
+  func <- quoToSimpleFunction(as_quosure(q))
+  wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
+}
+
+updateFunctionLabel <- function(label) {
+  badFnName <- "anonymous"
+  if (all(is.language(label))) {
+    # Prevent immediately invoked functions like as.language(a()())
+    if (is.language(label) && length(label) > 1) {
+      return(badFnName)
+    }
+    label <- deparse(label, width.cutoff = 500L)
+  }
+  label <- as.character(label)
+  # Prevent function calls that are over one line; (Assignments are hard to perform)
+    # Prevent immediately invoked functions like "a()()"
+  if (length(label) > 1 || grepl("(", label, fixed = TRUE)) {
+    return(badFnName)
+  }
+  if (label == "NULL") {
+    return(badFnName)
+  }
+  label
+}
+
+quoToSimpleFunction <- function(q) {
+  # Should not use `new_function(list(), get_expr(q), get_env(q))` as extra logic
+  # is done by rlang to convert the quosure to a function within `as_function(q)`
+  fun <- as_function(q)
+
+  # If the quosure is empty, then the returned function can not be called.
+  # https://github.com/r-lib/rlang/issues/1244
+  if (quo_is_missing(q)) {
+    fn_body(fun) <- quote({})
+  }
+
+  # `as_function()` returns a function that takes `...`. We need one that takes no
+  # args.
+  fn_fmls(fun) <- list()
+
+  fun
+}
+
+
+#' Convert an expression to a function
+#'
+#' `r lifecycle::badge("superseded")` Please use [`installExprFunction()`] for a better
+#' debugging experience (Shiny 0.8.0). If the `expr` and `quoted` parameters are not needed, please see
+#' [`quoToFunction()`] (Shiny 1.6.0).
+#'
+#' Similar to [installExprFunction()] but doesn't register debug hooks.
+#'
+#' @param expr A quoted or unquoted expression, or a quosure.
+#' @param env The desired environment for the function. Defaults to the
+#'   calling environment two steps back.
+#' @param quoted Is the expression quoted?
+#' @seealso [`installExprFunction()`] for the modern approach to converting an expression to a function
+#' @export
+#' @keywords internal
+exprToFunction <- function(expr, env = parent.frame(), quoted = FALSE) {
+  # If `expr` is a raw quosure, must say `quoted = TRUE`; (env is ignored)
+  # If `inject()` a quosure, env is ignored, and quoted should be FALSE (aka ignored).
+  # Make article of usage
+  # * (by joe)
+
+  if (!quoted) {
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+  # MUST call with `quoted = TRUE` as exprToQuo() will not reach high enough
+  q <- exprToQuo(expr, env, quoted = TRUE)
+
+  # MUST call `as_function()`. Can NOT call `new_function()`
+  # rlang has custom logic for handling converting a quosure to a function
+  quoToSimpleFunction(q)
+}
+# For internal use only; External users should be using `exprToFunction()` or `installExprFunction()`
+# MUST be the exact same logic as `exprToFunction()`, but without the `quoToSimpleFunction()` call
+exprToQuo <- function(expr, env = parent.frame(), quoted = FALSE) {
+  if (!quoted) {
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+  q <-
+    if (is_quosure(expr)) {
+      # inject()ed quosure
+      # do nothing
+      expr
+    } else if (is.language(expr) || rlang::is_atomic(expr) || is.null(expr)) {
+      # Most common case...
+      new_quosure(expr, env = env)
+    } else {
+      stop("Don't know how to convert '", class(expr)[1], "' to a function; a quosure or quoted expression was expected")
+    }
+  q
+}
+
+#' @describeIn createRenderFunction converts a user's reactive `expr` into a
+#'   function that's assigned to a `name` in the `assign.env`.
+#'
+#' @param name The name the function should be given
+#' @param eval.env The desired environment for the function. Defaults to the
+#'   calling environment two steps back.
+#' @param assign.env The environment in which the function should be assigned.
+#' @param label A label for the object to be shown in the debugger. Defaults to
+#'   the name of the calling function.
+#' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
+#'   [stacktrace()].
+#' @inheritParams exprToFunction
+#' @export
+installExprFunction <- function(expr, name, eval.env = parent.frame(2),
+                                quoted = FALSE,
+                                assign.env = parent.frame(1),
+                                label = sys.call(-1)[[1]],
+                                wrappedWithLabel = TRUE,
+                                ..stacktraceon = FALSE) {
+  if (!quoted) {
+    quoted <- TRUE
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+
+  func <- exprToFunction(expr, eval.env, quoted)
+  if (length(label) > 1) {
+    # Just in case the deparsed code is more complicated than we imagine. If we
+    # have a label with length > 1 it causes warnings in wrapFunctionLabel.
+    label <- paste0(label, collapse = "\n")
+  }
+  wrappedWithLabel <- isTRUE(wrappedWithLabel)
+  if (wrappedWithLabel) {
+    func <- wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
+  }
+  assign(name, func, envir = assign.env)
+  if (!wrappedWithLabel) {
+    registerDebugHook(name, assign.env, label)
+  }
+
+  invisible(func)
+}
+
+# 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]],
+      simpleExprToFunction(expr, function_name)
+    )
+  }
+  if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
+  attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
+  label
+}
+simpleExprToFunction <- function(expr, function_name) {
+  sprintf('%s(%s)', function_name, paste(deparse(expr), collapse='\n'))
+}
+
+installedFuncExpr <- function(func) {
+  fn_body(attr(func, "wrappedFunc", exact = TRUE))
+}
+
+funcToLabelBody <- function(func) {
+  paste(deparse(installedFuncExpr(func)), collapse='\n')
+}
+funcToLabel <- function(func, functionLabel, label = NULL) {
+  if (!is.null(label)) return(label)
+
+  sprintf(
+    '%s(%s)',
+    functionLabel,
+    funcToLabelBody(func)
+  )
+}
+quoToLabelBody <- function(q) {
+  paste(deparse(quo_get_expr(q)), collapse='\n')
+}
+quoToLabel <- function(q, functionLabel, label = NULL) {
+  if (!is.null(label)) return(label)
+
+  sprintf(
+    '%s(%s)',
+    functionLabel,
+    quoToLabelBody(q)
+  )
+}

R/utils.R

@@ -2,6 +2,11 @@
 #' @include map.R
 NULL
 
+# @staticimports pkg:staticimports
+#   is_installed get_package_version system_file
+#   s3_register
+#   any_named any_unnamed
+
 #' Make a random number generator repeatable
 #'
 #' Given a function that generates random data, returns a wrapped version of
@@ -113,24 +118,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))]
@@ -144,34 +131,6 @@ dropNullsOrEmpty <- function(x) {
   x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
 }
 
-# Given a vector/list, return TRUE if any elements are named, FALSE otherwise.
-anyNamed <- function(x) {
-  # Zero-length vector
-  if (length(x) == 0) return(FALSE)
-
-  nms <- names(x)
-
-  # List with no name attribute
-  if (is.null(nms)) return(FALSE)
-
-  # List with name attribute; check for any ""
-  any(nzchar(nms))
-}
-
-# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
-anyUnnamed <- function(x) {
-  # Zero-length vector
-  if (length(x) == 0) return(FALSE)
-
-  nms <- names(x)
-
-  # List with no name attribute
-  if (is.null(nms)) return(TRUE)
-
-  # List with name attribute; check for any ""
-  any(!nzchar(nms))
-}
-
 
 # Given a vector/list, returns a named vector/list (the labels will be blank).
 asNamed <- function(x) {
@@ -182,12 +141,16 @@ asNamed <- function(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
 # duplicated names in a or b, only the last one with that name is kept.
 mergeVectors <- function(a, b) {
-  if (anyUnnamed(a) || anyUnnamed(b)) {
+  if (any_unnamed(a) || any_unnamed(b)) {
     stop("Vectors must be either NULL or have names for all elements")
   }
 
@@ -199,15 +162,27 @@ mergeVectors <- function(a, b) {
 # Sort a vector by the names of items. If there are multiple items with the
 # same name, preserve the original order of those items. For empty
 # vectors/lists/NULL, return the original value.
-sortByName <- function(x) {
-  if (anyUnnamed(x))
+sortByName <- function(x, method = "auto") {
+  if (any_unnamed(x))
     stop("All items must be named")
 
   # Special case for empty vectors/lists, and NULL
   if (length(x) == 0)
     return(x)
 
-  x[order(names(x))]
+  # Must provide consistent sort order
+  #  https://github.com/rstudio/shinytest/issues/409
+  # Using a flag in the snapshot url to determine the method
+  # `method="radix"` uses `C` locale, which is consistent across platforms
+  # Even if two platforms share `en_us.UTF-8`, they may not sort consistently
+  #  https://blog.zhimingwang.org/macos-lc_collate-hunt
+  #  (macOS) $ LC_ALL=en_US.UTF-8 sort <<<$'python-dev\npython3-dev'
+  #  python-dev
+  #  python3-dev
+  #  (Linux) $ LC_ALL=en_US.UTF-8 sort <<<$'python-dev\npython3-dev'
+  #  python3-dev
+  #  python-dev
+  x[order(names(x), method = method)]
 }
 
 # Sort a vector. If a character vector, sort using C locale, which is consistent
@@ -220,6 +195,7 @@ sort_c <- function(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.
@@ -417,120 +393,6 @@ getContentType <- function(file, defaultType = 'application/octet-stream') {
   mime::guess_type(file, unknown = defaultType, subtype = subtype)
 }
 
-# Create a zero-arg function from a quoted expression and environment
-# @examples
-# makeFunction(body=quote(print(3)))
-makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
-  eval(call("function", args, body), env)
-}
-
-#' 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.
-#'
-#' 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
-#'   deprecation message).
-#' If expr was a non-quoted expression from two calls back, then this will
-#'   quote the original expression and convert it to a function.
-#
-#' @param expr A quoted or unquoted expression, or a function.
-#' @param env The desired environment for the function. Defaults to the
-#'   calling environment two steps back.
-#' @param quoted Is the expression quoted?
-#'
-#' @examples
-#' # Example of a new renderer, similar to renderText
-#' # This is something that toolkit authors will do
-#' renderTriple <- function(expr, env=parent.frame(), quoted=FALSE) {
-#'   # Convert expr to a function
-#'   func <- shiny::exprToFunction(expr, env, quoted)
-#'
-#'   function() {
-#'     value <- func()
-#'     paste(rep(value, 3), collapse=", ")
-#'   }
-#' }
-#'
-#'
-#' # Example of using the renderer.
-#' # This is something that app authors will do.
-#' values <- reactiveValues(A="text")
-#'
-#' \dontrun{
-#' # Create an output object
-#' output$tripleA <- renderTriple({
-#'   values$A
-#' })
-#' }
-#'
-#' # At the R console, you can experiment with the renderer using isolate()
-#' tripleA <- renderTriple({
-#'   values$A
-#' })
-#'
-#' isolate(tripleA())
-#' # "text, text, text"
-#' @export
-exprToFunction <- function(expr, env=parent.frame(), quoted=FALSE) {
-  if (!quoted) {
-    expr <- eval(substitute(substitute(expr)), parent.frame())
-  }
-
-  # expr is a quoted expression
-  makeFunction(body=expr, env=env)
-}
-
-#' 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.
-#'
-#' 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 [exprToFunction()]; see that method's documentation
-#'   for more documentation and examples.
-#'
-#' @param expr A quoted or unquoted expression
-#' @param name The name the function should be given
-#' @param eval.env The desired environment for the function. Defaults to the
-#'   calling environment two steps back.
-#' @param quoted Is the expression quoted?
-#' @param assign.env The environment in which the function should be assigned.
-#' @param label A label for the object to be shown in the debugger. Defaults to
-#'   the name of the calling function.
-#' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
-#'   [stacktrace()].
-#' @export
-installExprFunction <- function(expr, name, eval.env = parent.frame(2),
-                                quoted = FALSE,
-                                assign.env = parent.frame(1),
-                                label = deparse(sys.call(-1)[[1]]),
-                                wrappedWithLabel = TRUE,
-                                ..stacktraceon = FALSE) {
-  if (!quoted) {
-    quoted <- TRUE
-    expr <- eval(substitute(substitute(expr)), parent.frame())
-  }
-
-  func <- exprToFunction(expr, eval.env, quoted)
-  if (length(label) > 1) {
-    # Just in case the deparsed code is more complicated than we imagine. If we
-    # have a label with length > 1 it causes warnings in wrapFunctionLabel.
-    label <- paste0(label, collapse = "\n")
-  }
-  if (wrappedWithLabel) {
-    func <- wrapFunctionLabel(func, label, ..stacktraceon = ..stacktraceon)
-  } else {
-    registerDebugHook(name, assign.env, label)
-  }
-  assign(name, func, envir = assign.env)
-}
-
 #' Parse a GET query string from a URL
 #'
 #' Returns a named list of key-value pairs.
@@ -622,7 +484,7 @@ shinyCallingHandlers <- function(expr) {
   withCallingHandlers(captureStackTraces(expr),
     error = function(e) {
       # Don't intercept shiny.silent.error (i.e. validation errors)
-      if (inherits(e, "shiny.silent.error"))
+      if (cnd_inherits(e, "shiny.silent.error"))
         return()
 
       handle <- getOption('shiny.error')
@@ -631,38 +493,6 @@ shinyCallingHandlers <- function(expr) {
   )
 }
 
-#' Print message for deprecated functions in Shiny
-#'
-#' To disable these messages, use `options(shiny.deprecation.messages=FALSE)`.
-#'
-#' @param new Name of replacement function.
-#' @param msg Message to print. If used, this will override the default message.
-#' @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).
 #'
 #' Call this function after exprToFunction to give any active debugger a hook
@@ -1111,52 +941,39 @@ reactiveStop <- function(message = "", class = NULL) {
 
 #' Validate input values and other conditions
 #'
-#' For an output rendering function (e.g. [renderPlot()]), you may
-#' need to check that certain input values are available and valid before you
-#' can render the output. `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 `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 `validate` is to use the `need`
-#' function, which takes an expression and a string; if the expression is
-#' considered a failure, then the string will be used as the error message. The
-#' `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{`FALSE`}
-#'   \item{`NULL`}
-#'   \item{`""`}
-#'   \item{An empty atomic vector}
-#'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all `FALSE` or missing values}
-#'   \item{An object of class `"try-error"`}
-#'   \item{A value that represents an unclicked [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 `NA` but not `NULL`, you
-#' can use the condition `!is.null(input$foo)`, because `!is.null(NA)
-#' == TRUE`.
-#'
-#' If you need validation logic that differs significantly from `need`, you
-#' can create other validation test functions. A passing test should return
-#' `NULL`. A failing test should return an error message as a
-#' single-element character vector, or if the failure should happen silently,
-#' `FALSE`.
-#'
-#' Because validation failure is signaled as an error, you can use
-#' `validate` in reactive expressions, and validation failures will
-#' automatically propagate to outputs that use the reactive expression. In
-#' other words, if reactive expression `a` needs `input$x`, and two
-#' outputs use `a` (and thus depend indirectly on `input$x`), it's
-#' not necessary for the outputs to validate `input$x` explicitly, as long
-#' as `a` does validate it.
+#' ```
 #'
 #' @param ... A list of tests. Each test should equal `NULL` for success,
 #'   `FALSE` for silent failure, or a string for failure with an error
@@ -1171,7 +988,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #'
 #' ui <- fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
-#'   selectizeInput('in2', 'Select a state', choices = state.name),
+#'   selectizeInput('in2', 'Select a state', choices = c("", state.name)),
 #'   plotOutput('plot')
 #' )
 #'
@@ -1189,7 +1006,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #'
 #' }
 validate <- function(..., errorClass = character(0)) {
-  results <- sapply(list(...), function(x) {
+  results <- sapply(list2(...), function(x) {
     # Detect NULL or NA
     if (is.null(x))
       return(NA_character_)
@@ -1233,7 +1050,7 @@ 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).
@@ -1242,11 +1059,13 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' 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 `r()` is called and any of `input$a`,
 #' `input$b`, and `rv$state` are `NULL`, `FALSE`, `""`,
@@ -1255,62 +1074,29 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #'
 #' 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, `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.
 #'
-#' **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, `req` considers a value truthy *unless* it is one
-#' of:
-#'
-#' \itemize{
-#'   \item{`FALSE`}
-#'   \item{`NULL`}
-#'   \item{`""`}
-#'   \item{An empty atomic vector}
-#'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all `FALSE` or missing values}
-#'   \item{An object of class `"try-error"`}
-#'   \item{A value that represents an unclicked [actionButton()]}
-#' }
-#'
-#' Note in particular that the value `0` is considered truthy, even though
-#' `as.logical(0)` is `FALSE`.
-#'
-#' If the built-in rules for truthiness do not match your requirements, you can
-#' always work around them. Since `FALSE` is falsy, you can simply provide
-#' the results of your own checks to `req`:
-#'
-#' `req(input$a != 0)`
-#'
-#' **Using `req(FALSE)`**
+#' @section Using `req(FALSE)`:
 #'
 #' 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
+#' chain now. There is no advantage to this, except perhaps ease of readability
 #' if you have a complicated condition to check for (or perhaps if you'd like to
 #' divide your condition into nested `if` statements).
 #'
-#' **Using `cancelOutput = TRUE`**
+#' @section Using `cancelOutput = TRUE`:
 #'
 #' When `req(..., cancelOutput = TRUE)` is used, the "silent" exception is
 #' also raised, but it is treated slightly differently if one or more outputs are
@@ -1328,8 +1114,10 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' @param ... Values to check for truthiness.
 #' @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
+#'   whatever state it happens to be in. If `"progress"`, do the same as `TRUE`,
+#'   but also keep the output in recalculating state; this is intended for cases
+#'   when an in-progress calculation will not be completed in this reactive
+#'   flush cycle, but is still expected to provide a result in the future.
 #' @return The first value that was passed in.
 #' @export
 #' @examples
@@ -1361,6 +1149,8 @@ req <- function(..., cancelOutput = FALSE) {
     if (!isTruthy(item)) {
       if (isTRUE(cancelOutput)) {
         cancelOutput()
+      } else if (identical(cancelOutput, "progress")) {
+        reactiveStop(class = "shiny.output.progress")
       } else {
         reactiveStop(class = "validation")
       }
@@ -1419,23 +1209,47 @@ 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)
-
-  if (!is.atomic(x))
-    return(TRUE)
-
   if (is.null(x))
     return(FALSE)
+  if (inherits(x, 'try-error'))
+    return(FALSE)
+  if (!is.atomic(x))
+    return(TRUE)
   if (length(x) == 0)
     return(FALSE)
   if (all(is.na(x)))
@@ -1503,7 +1317,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)
@@ -1587,15 +1401,19 @@ URLencode <- function(value, reserved = FALSE) {
   if (reserved) encodeURIComponent(value) else encodeURI(value)
 }
 
-# Make user-supplied dates are either NULL or can be coerced
-# to a yyyy-mm-dd formatted string. If a date is specified, this
-# function returns a string for consistency across locales.
-# Also, `as.Date()` is used to coerce strings to date objects
-# so that strings like "2016-08-9" are expanded to "2016-08-09"
+# 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)
-  if (length(date) > 1) warning("Expected `", argName, "` to be of length 1.")
-  tryCatch(date <- format(as.Date(date), "%Y-%m-%d"),
+  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,
@@ -1611,25 +1429,40 @@ dateYMD <- function(date = NULL, argName = "value") {
 # function which calls the original function using the specified name. This can
 # be helpful for profiling, because the specified name will show up on the stack
 # trace.
-wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
+wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE, dots = TRUE) {
   if (name == "name" || name == "func" || name == "relabelWrapper") {
     stop("Invalid name for wrapFunctionLabel: ", name)
   }
+  if (nchar(name, "bytes") > 10000) {
+    # Max variable length in R is 10000 bytes. Truncate to a shorter number of
+    # chars because some characters could be multi-byte.
+    name <- substr(name, 1, 5000)
+  }
+
   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 (isTRUE(dots)) {
+    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())
+  } else {
+    # Same logic as when `dots = TRUE`, but without the `...`
+    if (..stacktraceon) {
+      body <- expr({ ..stacktraceon..((!!name)()) })
+    } else {
+      body <- expr({ (!!name)() })
+    }
+    relabelWrapper <- new_function(list(), body, environment())
+  }
 
+  # Preserve the original function that was passed in; is used for caching.
+  attr(relabelWrapper, "wrappedFunc") <- func
   relabelWrapper
 }
 
@@ -1689,19 +1522,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)
           }
         })
       },
@@ -1722,24 +1559,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)
@@ -1783,7 +1609,10 @@ getSliderType <- function(min, max, value) {
     else                            "number"
   }))
   if (length(type) > 1) {
-    stop("Type mismatch for `min`, `max`, and `value`. Each must be Date, POSIXt, or number.")
+    rlang::abort(c(
+      "Type mismatch for `min`, `max`, and `value`.",
+      "All values must either be numeric, Date, or POSIXt."
+    ))
   }
   type[[1]]
 }
@@ -1884,12 +1713,20 @@ findEnclosingApp <- function(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)
+# Until `rlang::cnd_inherits()` is on CRAN
+cnd_inherits <- function(cnd, class) {
+  cnd_some(cnd, ~ inherits(.x, class))
+}
+cnd_some <- function(.cnd, .p, ...) {
+  .p <- rlang::as_function(.p)
+
+  while (rlang::is_condition(.cnd)) {
+    if (.p(.cnd, ...)) {
+      return(TRUE)
+    }
+
+    .cnd <- .cnd$parent
+  }
+
+  FALSE
 }

R/version_bs_date_picker.R

@@ -0,0 +1,2 @@
+# Generated by tools/updateBootstrapDatepicker.R; do not edit by hand
+version_bs_date_picker <- "1.9.0"

R/version_ion_range_slider.R

@@ -0,0 +1,2 @@
+# Generated by tools/updateIonRangeSlider.R; do not edit by hand
+version_ion_range_slider <- "2.3.1"

R/version_jquery.R

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

R/version_jqueryui.R

@@ -0,0 +1,2 @@
+# Generated by tools/updatejQueryUI.R; do not edit by hand
+version_jqueryui <- "1.13.2"

R/version_selectize.R

@@ -0,0 +1,2 @@
+# Generated by tools/updateSelectize.R; do not edit by hand
+version_selectize <- "0.15.2"

R/version_strftime.R

@@ -0,0 +1,2 @@
+# Generated by tools/updateStrftime.R; do not edit by hand
+version_strftime <- "0.9.2"