Add debug statements

.Rbuildignore

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

.browserslistrc

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

.eslintrc.yml

@@ -1,110 +0,0 @@
-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
-  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,6 +1,4 @@
 /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/ISSUE_TEMPLATE/question.md

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

.github/shiny-workflows/routine.sh

@@ -1,13 +0,0 @@
-#!/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
-  echo "package.json has changed after running ./tools/updatePackageJsonVersion.R. Re-running 'yarn build'"
-  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,23 +1,198 @@
-# 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
+name: R-CMD-check
 on:
   push:
-    branches: [main, rc-**]
+    branches:
+      - master
   pull_request:
-    branches: [main]
-  schedule:
-    - cron: '0 5 * * 1' # every monday
+    branches:
+      - master
 
-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:
-    uses: rstudio/shiny-workflows/.github/workflows/R-CMD-check.yaml@v1
+    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

.github/workflows/pr-commands.yaml

@@ -0,0 +1,35 @@
+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,19 +10,3 @@ 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

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

.vscode/extensions.json

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

.vscode/settings.json

@@ -1,24 +0,0 @@
-{
-  "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,
-  },
-  "[json]": {
-    "editor.formatOnSave": true,
-    "editor.defaultFormatter": "esbenp.prettier-vscode",
-    "files.trimTrailingWhitespace": true,
-    "files.insertFinalNewline": true,
-},
-}

.yarnrc.yml

@@ -1,10 +0,0 @@
-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,19 +1,19 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.10.0.9001
+Version: 1.5.0.9004
 Authors@R: c(
-    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("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
+    person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
+    person("JJ", "Allaire", role = "aut", email = "jj@rstudio.com"),
+    person("Carson", "Sievert", role = "aut", email = "carson@rstudio.com"),
+    person("Barret", "Schloerke", role = "aut", email = "barret@rstudio.com"),
+    person("Yihui", "Xie", role = "aut", email = "yihui@rstudio.com"),
+    person("Jeff", "Allen", role = "aut", email = "jeff@rstudio.com"),
+    person("Jonathan", "McPherson", role = "aut", email = "jonathan@rstudio.com"),
     person("Alan", "Dipert", role = "aut"),
     person("Barbara", "Borges", role = "aut"),
-    person("Posit Software, PBC", role = c("cph", "fnd")),
+    person(family = "RStudio", role = "cph"),
     person(family = "jQuery Foundation", role = "cph",
     comment = "jQuery library and jQuery UI library"),
     person(family = "jQuery contributors", role = c("ctb", "cph"),
@@ -44,6 +44,8 @@ Authors@R: c(
     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("Salmen", "Bejaoui", role = c("ctb", "cph"),
@@ -60,7 +62,7 @@ Authors@R: c(
     comment = "showdown.js library"),
     person("Ivan", "Sagalaev", role = c("ctb", "cph"),
     comment = "highlight.js library"),
-    person(given = "R Core Team", role = c("ctb", "cph"),
+    person(family = "R Core Team", role = c("ctb", "cph"),
     comment = "tar implementation from R")
     )
 Description: Makes it incredibly easy to build interactive web
@@ -78,52 +80,49 @@ Imports:
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
-    fontawesome (>= 0.4.0),
-    htmltools (>= 0.5.4),
+    digest,
+    htmltools (>= 0.5.0.9001),
     R6 (>= 2.0),
     sourcetools,
     later (>= 1.0.0),
-    promises (>= 1.3.2),
+    promises (>= 1.1.0),
     tools,
-    cli,
-    rlang (>= 0.4.10),
-    fastmap (>= 1.1.1),
+    crayon,
+    rlang (>= 0.4.0),
+    fastmap (>= 1.0.0),
     withr,
     commonmark (>= 1.7),
     glue (>= 1.3.2),
-    bslib (>= 0.6.0),
-    cachem (>= 1.1.0),
-    lifecycle (>= 0.2.0)
+    bootstraplib (>= 0.2.0.9001)
 Suggests:
-    coro (>= 1.1.0),
     datasets,
-    DT,
     Cairo (>= 1.5-5),
-    testthat (>= 3.2.1),
+    testthat (>= 2.1.1),
     knitr (>= 1.6),
     markdown,
     rmarkdown,
     ggplot2,
     reactlog (>= 1.0.0),
     magrittr,
+    shinytest,
     yaml,
-    mirai,
     future,
     dygraphs,
     ragg,
     showtext,
-    sass,
-    watcher 
-URL: https://shiny.posit.co/,
-    https://github.com/rstudio/shiny
+    sass
+Remotes:
+    rstudio/htmltools,
+    rstudio/sass,
+    rstudio/bootstraplib
+URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     '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'
@@ -131,20 +130,19 @@ Collate:
     'map.R'
     'utils.R'
     'bootstrap.R'
-    'busy-indicators-spinners.R'
-    'busy-indicators.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'
@@ -189,29 +187,17 @@ Collate:
     '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'
-    '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.2
+RoxygenNote: 7.1.1
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-Config/testthat/edition: 3
-Config/Needs/check:
-  shinytest2

LICENSE

@@ -10,6 +10,7 @@ these components are included below):
 - Bootstrap, https://github.com/twbs/bootstrap
 - 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
 - selectize-plugin-a11y, https://github.com/SLMNBJ/selectize-plugin-a11y
 - ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
@@ -307,6 +308,449 @@ 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
 ----------------------------------------------------------------------
 

NAMESPACE

@@ -19,32 +19,14 @@ 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)
@@ -55,7 +37,6 @@ S3method(str,reactivevalues)
 export("conditionStackTrace<-")
 export(..stacktraceoff..)
 export(..stacktraceon..)
-export(ExtendedTask)
 export(HTML)
 export(MockShinySession)
 export(NS)
@@ -69,8 +50,6 @@ export(animationOptions)
 export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
-export(bindCache)
-export(bindEvent)
 export(bookmarkButton)
 export(bootstrapLib)
 export(bootstrapPage)
@@ -78,7 +57,6 @@ export(br)
 export(browserViewer)
 export(brushOpts)
 export(brushedPoints)
-export(busyIndicatorOptions)
 export(callModule)
 export(captureStackTraces)
 export(checkboxGroupInput)
@@ -95,7 +73,6 @@ export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
 export(debounce)
-export(devmode)
 export(dialogViewer)
 export(diskCache)
 export(div)
@@ -107,6 +84,7 @@ export(enableBookmarking)
 export(eventReactive)
 export(exportTestValues)
 export(exprToFunction)
+export(extractStackTrace)
 export(fileInput)
 export(fillCol)
 export(fillPage)
@@ -117,6 +95,7 @@ export(fixedRow)
 export(flowLayout)
 export(fluidPage)
 export(fluidRow)
+export(formatStackTrace)
 export(freezeReactiveVal)
 export(freezeReactiveValue)
 export(getCurrentOutputInfo)
@@ -125,7 +104,6 @@ export(getDefaultReactiveDomain)
 export(getQueryString)
 export(getShinyOption)
 export(getUrlHash)
-export(get_devmode_option)
 export(h1)
 export(h2)
 export(h3)
@@ -143,7 +121,6 @@ export(httpResponse)
 export(icon)
 export(imageOutput)
 export(img)
-export(in_devmode)
 export(incProgress)
 export(includeCSS)
 export(includeHTML)
@@ -192,7 +169,6 @@ export(onRestore)
 export(onRestored)
 export(onSessionEnded)
 export(onStop)
-export(onUnhandledError)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -205,23 +181,25 @@ 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)
 export(reactlog)
-export(reactlogAddMark)
 export(reactlogReset)
 export(reactlogShow)
 export(registerInputHandler)
 export(registerThemeDependency)
-export(register_devmode_option)
 export(removeInputHandler)
 export(removeModal)
 export(removeNotification)
@@ -264,6 +242,7 @@ export(shinyUI)
 export(showBookmarkUrlModal)
 export(showModal)
 export(showNotification)
+export(showReactLog)
 export(showTab)
 export(sidebarLayout)
 export(sidebarPanel)
@@ -319,7 +298,6 @@ export(updateTextInput)
 export(updateVarSelectInput)
 export(updateVarSelectizeInput)
 export(urlModal)
-export(useBusyIndicators)
 export(validate)
 export(validateCssUnit)
 export(varSelectInput)
@@ -332,8 +310,8 @@ export(withMathJax)
 export(withProgress)
 export(withReactiveDomain)
 export(withTags)
-export(with_devmode)
 import(R6)
+import(digest)
 import(htmltools)
 import(httpuv)
 import(methods)
@@ -382,46 +360,5 @@ 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)

R/app_template.R

@@ -10,7 +10,8 @@
 #' 2: app.R              : Main application file
 #' 3: R/example.R        : Helper file with R code
 #' 4: R/example-module.R : Example module
-#' 5: tests/testthat/    : Tests using the testthat and shinytest2 package
+#' 5: tests/shinytest/   : Tests using the shinytest package
+#' 6: tests/testthat/    : Tests using the testthat package
 #' ```
 #'
 #' If option 1 is selected, the full example application including the
@@ -23,12 +24,13 @@
 #' |   |- 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
 #' ```
 #'
@@ -43,21 +45,20 @@
 #' * `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
-#'   [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/` directory using the [testthat](https://testthat.r-lib.org/) package.
 #' * `tests/testthat/test-examplemodule.R` is a test for an application's module server function.
 #' * `tests/testthat/test-server.R` is a test for the application's server code
-#' * `tests/testthat/test-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", and "tests". In an
+#'   "app", "rdir", "module", "shinytest", and "testthat". In an
 #'   interactive session, "default" falls back to "ask"; in a non-interactive
 #'   session, "default" falls back to "all". With "ask", this function will
 #'   prompt the user to select which template items will be added to the new app
@@ -78,19 +79,15 @@ 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",
-    tests  = "tests/testthat/    : Tests using {testthat} and {shinytest2}"
+    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"
   )
 
-  # Support legacy value
-  examples[examples == "shinytest"] <- "tests"
-  examples[examples == "testthat"] <- "tests"
-  examples <- unique(examples)
-
   if (identical(examples, "default")) {
-    if (rlang::is_interactive()) {
+    if (interactive()) {
       examples <- "ask"
     } else {
       examples <- "all"
@@ -127,8 +124,18 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
     return(invisible())
   }
 
-  if ("tests" %in% examples) {
-    rlang::check_installed("shinytest2", "for {testthat} tests to work as expected", version = "0.2.0")
+  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.")
+      }
+
+    }
   }
 
   # =======================================================
@@ -145,7 +152,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
@@ -201,13 +208,16 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
   }
 
   # Copy the files for a tests/ subdirectory
-  copy_test_dir <- function() {
+  copy_test_dir <- function(name) {
     files <- dir(template_path("tests"), recursive = TRUE)
+    # Note: This is not the same as using dir(pattern = "^shinytest"), since
+    # that will not match files inside of shinytest/.
+    files <- files[grepl(paste0("^", name), files)]
 
     # Filter out files that are not module files in the R directory.
     if (! "rdir" %in% examples) {
       # find all files in the testthat folder that are not module or server files
-      is_r_folder_file <- !grepl("module|server|shinytest2|testthat", basename(files))
+      is_r_folder_file <- (!grepl("module|server", basename(files))) & (dirname(files) == "testthat")
       files <- files[!is_r_folder_file]
     }
 
@@ -272,10 +282,12 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
     copy_file(file.path("R", module_files))
   }
 
-  # tests/testthat dir
-  if ("tests" %in% examples) {
-    copy_test_dir()
+  # tests/ dir
+  if ("shinytest" %in% examples) {
+    copy_test_dir("shinytest")
+  }
+  if ("testthat" %in% examples) {
+    copy_test_dir("testthat")
   }
-
   invisible()
 }

R/bind-cache.R

@@ -1,774 +0,0 @@
-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 [mirai::mirai()] or [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

@@ -1,315 +0,0 @@
-#' 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,3 +1,6 @@
+#' @include stack.R
+NULL
+
 ShinySaveState <- R6Class("ShinySaveState",
   public = list(
     input = NULL,
@@ -76,7 +79,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", default = NULL)
+  saveInterface <- getShinyOption("save.interface")
 
   if (is.null(saveInterface)) {
     if (inShinyServer()) {
@@ -99,13 +102,13 @@ saveShinySaveState <- function(state) {
 
 # Encode the state to a URL. This does not save to disk.
 encodeShinySaveState <- function(state) {
+  exclude <- c(state$exclude, "._bookmark_")
+  inputVals <- serializeReactiveValues(state$input, exclude, stateDir = NULL)
+
   # Allow user-supplied onSave function to do things like add state$values.
   if (!is.null(state$onSave))
     isolate(state$onSave(state))
 
-  exclude <- c(state$exclude, "._bookmark_")
-  inputVals <- serializeReactiveValues(state$input, exclude, stateDir = NULL)
-
   inputVals <- vapply(inputVals,
     function(x) toJSON(x, strict_atomic = FALSE),
     character(1),
@@ -293,7 +296,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", default = NULL)
+      loadInterface <- getShinyOption("load.interface")
 
       if (is.null(loadInterface)) {
         if (inShinyServer()) {
@@ -321,38 +324,34 @@ 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_reg, queryString)[[1]]) > 1)
+      if (length(gregexpr("(^|&)_inputs_(&|$)", queryString)[[1]]) > 1)
         stop("Invalid state string: more than one '_inputs_' found")
-      if (length(gregexpr(values_reg, queryString)[[1]]) > 1)
+      if (length(gregexpr("(^|&)_values_(&|$)", 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_reg)[[1]]
+      splitStr <- strsplit(queryString, "(^|&)_inputs_(&|$)")[[1]]
       if (length(splitStr) == 2) {
         inputStr <- splitStr[2]
         # Remove any _values_ (and content after _values_) that may come after
         # _inputs_
-        inputStr <- strsplit(inputStr, values_reg)[[1]][1]
+        inputStr <- strsplit(inputStr, "(^|&)_values_(&|$)")[[1]][1]
 
       } else {
         inputStr <- ""
       }
 
       # Look for _values_ and store following content in valueStr
-      splitStr <- strsplit(queryString, values_reg)[[1]]
+      splitStr <- strsplit(queryString, "(^|&)_values_(&|$)")[[1]]
       if (length(splitStr) == 2) {
         valueStr <- splitStr[2]
         # Remove any _inputs_ (and content after _inputs_) that may come after
         # _values_
-        valueStr <- strsplit(valueStr, inputs_reg)[[1]][1]
+        valueStr <- strsplit(valueStr, "(^|&)_inputs_(&|$)")[[1]][1]
 
       } else {
         valueStr <- ""
@@ -363,20 +362,16 @@ RestoreContext <- R6Class("RestoreContext",
       values <- parseQueryString(valueStr, nested = TRUE)
 
       valuesFromJSON <- function(vals) {
-        varsUnparsed <- c()
-        valsParsed <- mapply(names(vals), vals, SIMPLIFY = FALSE,
+        mapply(names(vals), vals, SIMPLIFY = FALSE,
           FUN = function(name, value) {
             tryCatch(
               safeFromJSON(value),
               error = function(e) {
-                varsUnparsed <<- c(varsUnparsed, name)
-                warning("Failed to parse URL parameter \"", name, "\"")
+                stop("Failed to parse URL parameter \"", name, "\"")
               }
             )
           }
         )
-        valsParsed[varsUnparsed] <- NULL
-        valsParsed
       }
 
       inputs <- valuesFromJSON(inputs)
@@ -452,10 +447,8 @@ RestoreInputSet <- R6Class("RestoreInputSet",
   )
 )
 
-restoreCtxStack <- NULL
-on_load({
-    restoreCtxStack <- fastmap::faststack()
-})
+
+restoreCtxStack <- Stack$new()
 
 withRestoreContext <- function(ctx, expr) {
   restoreCtxStack$push(ctx)
@@ -551,7 +544,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 current history
+#' @param mode When the query string is updated, should the the current history
 #'   entry be replaced (default), or should a new history entry be pushed onto
 #'   the history stack? The former should only be used in a live bookmarking
 #'   context. The latter is useful if you want to navigate between states using
@@ -1167,10 +1160,10 @@ setBookmarkExclude <- function(names = character(0), session = getDefaultReactiv
 #'     toupper(input$text)
 #'   })
 #'   onBookmark(function(state) {
-#'     state$values$hash <- rlang::hash(input$text)
+#'     state$values$hash <- digest::digest(input$text, "md5")
 #'   })
 #'   onRestore(function(state) {
-#'     if (identical(rlang::hash(input$text), state$values$hash)) {
+#'     if (identical(digest::digest(input$text, "md5"), 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)
@@ -1193,10 +1186,10 @@ setBookmarkExclude <- function(names = character(0), session = getDefaultReactiv
 #' server <- function(input, output, session) {
 #'   callModule(capitalizerServer, "tc")
 #'   onBookmark(function(state) {
-#'     state$values$hash <- rlang::hash(input$text)
+#'     state$values$hash <- digest::digest(input$text, "md5")
 #'   })
 #'   onRestore(function(state) {
-#'     if (identical(rlang::hash(input$text), state$values$hash)) {
+#'     if (identical(digest::digest(input$text, "md5"), 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 definition that can be passed to the [shinyUI] function
+#' @return A UI defintion that can be passed to the [shinyUI] function
 #' @export
 pageWithSidebar <- function(headerPanel,
                             sidebarPanel,

R/bootstrap-layout.R

@@ -11,9 +11,14 @@
 #' @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 definition that can be passed to the [shinyUI] function.
+#' @return A UI defintion 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
@@ -21,7 +26,7 @@
 #'   higher-level layout functions like [sidebarLayout()].
 #'
 #' @note See the [
-#'   Shiny-Application-Layout-Guide](https://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fluid
+#'   Shiny-Application-Layout-Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fluid
 #'   pages.
 #'
 #' @family layout functions
@@ -83,9 +88,10 @@
 #' }
 #' @rdname fluidPage
 #' @export
-fluidPage <- function(..., title = NULL, theme = NULL, lang = NULL) {
+fluidPage <- function(..., title = NULL, responsive = NULL, theme = NULL, lang = NULL) {
   bootstrapPage(div(class = "container-fluid", ...),
                 title = title,
+                responsive = responsive,
                 theme = theme,
                 lang = lang)
 }
@@ -109,9 +115,14 @@ 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 definition that can be passed to the [shinyUI] function.
+#' @return A UI defintion 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
@@ -120,7 +131,7 @@ fluidRow <- function(...) {
 #'   with `fixedRow` and `column`.
 #'
 #' @note See the [
-#'   Shiny Application Layout Guide](https://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fixed
+#'   Shiny Application Layout Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fixed
 #'   pages.
 #'
 #' @family layout functions
@@ -148,9 +159,10 @@ fluidRow <- function(...) {
 #'
 #' @rdname fixedPage
 #' @export
-fixedPage <- function(..., title = NULL, theme = NULL, lang = NULL) {
+fixedPage <- function(..., title = NULL, responsive = NULL, theme = NULL, lang = NULL) {
   bootstrapPage(div(class = "container", ...),
                 title = title,
+                responsive = responsive,
                 theme = theme,
                 lang = lang)
 }
@@ -390,7 +402,7 @@ mainPanel <- function(..., width = 8) {
 #' }
 #' @export
 verticalLayout <- function(..., fluid = TRUE) {
-  lapply(list2(...), function(row) {
+  lapply(list(...), function(row) {
     col <- column(12, row)
     if (fluid)
       fluidRow(col)
@@ -427,8 +439,8 @@ verticalLayout <- function(..., fluid = TRUE) {
 #' @export
 flowLayout <- function(..., cellArgs = list()) {
 
-  children <- list2(...)
-  childIdx <- !nzchar(names(children) %||% character(length(children)))
+  children <- list(...)
+  childIdx <- !nzchar(names(children) %OR% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
 
@@ -510,13 +522,13 @@ inputPanel <- function(...) {
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
-  children <- list2(...)
-  childIdx <- !nzchar(names(children) %||% character(length(children)))
+  children <- list(...)
+  childIdx <- !nzchar(names(children) %OR% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
   count <- length(children)
 
-  if (length(cellWidths) == 0 || isTRUE(is.na(cellWidths))) {
+  if (length(cellWidths) == 0 || is.na(cellWidths)) {
     cellWidths <- sprintf("%.3f%%", 100 / count)
   }
   cellWidths <- rep(cellWidths, length.out = count)
@@ -608,7 +620,7 @@ fillCol <- function(..., flex = 1, width = "100%", height = "100%") {
 }
 
 flexfill <- function(..., direction, flex, width = width, height = height) {
-  children <- list2(...)
+  children <- list(...)
   attrs <- list()
 
   if (!is.null(names(children))) {
@@ -689,3 +701,37 @@ 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/busy-indicators-spinners.R

@@ -1,4 +0,0 @@
-# Generated by tools/updateSpinnerTypes.R: do not edit by hand
-.busySpinnerTypes <-
-  c("ring", "ring2", "ring3", "bars", "bars2", "bars3", "pulse", 
-  "pulse2", "pulse3", "dots", "dots2", "dots3")

R/busy-indicators.R

@@ -1,294 +0,0 @@
-#' Enable/disable busy indication
-#'
-#' Busy indicators provide a visual cue to users when the server is busy
-#' calculating outputs or otherwise performing tasks (e.g., producing
-#' downloads). When enabled, a spinner is shown on each
-#' calculating/recalculating output, and a pulsing banner is shown at the top of
-#' the page when the app is otherwise busy. Busy indication is enabled by
-#' default for UI created with \pkg{bslib}, but must be enabled otherwise. To
-#' enable/disable, include the result of this function in anywhere in the app's
-#' UI.
-#'
-#' When both `spinners` and `pulse` are set to `TRUE`, the pulse is
-#' automatically disabled when spinner(s) are active. When both `spinners` and
-#' `pulse` are set to `FALSE`, no busy indication is shown (other than the
-#' graying out of recalculating outputs).
-#'
-#' @param ... Currently ignored.
-#' @param spinners Whether to show a spinner on each calculating/recalculating
-#'   output.
-#' @param pulse Whether to show a pulsing banner at the top of the page when the
-#'   app is busy.
-#' @param fade Whether to fade recalculating outputs. A value of `FALSE` is
-#'   equivalent to `busyIndicatorOptions(fade_opacity=1)`.
-#'
-#' @export
-#' @seealso [busyIndicatorOptions()] for customizing the appearance of the busy
-#'   indicators.
-#' @examplesIf rlang::is_interactive()
-#'
-#' library(bslib)
-#'
-#' ui <- page_fillable(
-#'   useBusyIndicators(),
-#'   card(
-#'     card_header(
-#'       "A plot",
-#'       input_task_button("simulate", "Simulate"),
-#'       class = "d-flex justify-content-between align-items-center"
-#'     ),
-#'     plotOutput("p"),
-#'   )
-#' )
-#'
-#' server <- function(input, output) {
-#'   output$p <- renderPlot({
-#'     input$simulate
-#'     Sys.sleep(4)
-#'     plot(x = rnorm(100), y = rnorm(100))
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-useBusyIndicators <- function(..., spinners = TRUE, pulse = TRUE, fade = TRUE) {
-
-  rlang::check_dots_empty()
-
-  attrs <- list("shinyBusySpinners" = spinners, "shinyBusyPulse" = pulse)
-
-  js <- vapply(names(attrs), character(1), FUN = function(key) {
-    if (attrs[[key]]) {
-      sprintf("document.documentElement.dataset.%s = 'true';", key)
-    } else {
-      sprintf("delete document.documentElement.dataset.%s;", key)
-    }
-  })
-
-  # TODO: it'd be nice if htmltools had something like a page_attrs() that allowed us
-  # to do this without needing to inject JS into the head.
-  res <- tags$script(HTML(paste(js, collapse = "\n")))
-
-  if (!fade) {
-    res <- tagList(res, fadeOptions(opacity = 1))
-  }
-
-  res
-}
-
-#' Customize busy indicator options
-#'
-#' @description
-#' Shiny automatically includes busy indicators, which more specifically means:
-#'   1. Calculating/recalculating outputs have a spinner overlay.
-#'   2. Outputs fade out/in when recalculating.
-#'   3. When no outputs are calculating/recalculating, but Shiny is busy
-#'     doing something else (e.g., a download, side-effect, etc), a page-level
-#'     pulsing banner is shown.
-#'
-#' This function allows you to customize the appearance of these busy indicators
-#' by including the result of this function inside the app's UI. Note that,
-#' unless `spinner_selector` (or `fade_selector`) is specified, the spinner/fade
-#' customization applies to the parent element. If the customization should
-#' instead apply to the entire page, set `spinner_selector = 'html'` and
-#' `fade_selector = 'html'`.
-#'
-#' @param ... Currently ignored.
-#' @param spinner_type The type of spinner. Pre-bundled types include:
-#'   '`r paste0(.busySpinnerTypes, collapse = "', '")`'.
-#'
-#'   A path to a local SVG file can also be provided. The SVG should adhere to
-#'   the following rules:
-#'   * The SVG itself should contain the animation.
-#'   * It should avoid absolute sizes (the spinner's containing DOM element
-#'     size is set in CSS by `spinner_size`, so it should fill that container).
-#'   * It should avoid setting absolute colors (the spinner's containing DOM element
-#'     color is set in CSS by `spinner_color`, so it should inherit that color).
-#' @param spinner_color The color of the spinner. This can be any valid CSS
-#'   color. Defaults to the app's "primary" color if Bootstrap is on the page.
-#' @param spinner_size The size of the spinner. This can be any valid CSS size.
-#' @param spinner_delay The amount of time to wait before showing the spinner.
-#'   This can be any valid CSS time and can be useful for not showing the spinner
-#'   if the computation finishes quickly.
-#' @param spinner_selector A character string containing a CSS selector for
-#'   scoping the spinner customization. The default (`NULL`) will apply the
-#'   spinner customization to the parent element of the spinner.
-#' @param fade_opacity The opacity (a number between 0 and 1) for recalculating
-#'   output. Set to 1 to "disable" the fade.
-#' @param fade_selector A character string containing a CSS selector for
-#'   scoping the spinner customization. The default (`NULL`) will apply the
-#'   spinner customization to the parent element of the spinner.
-#' @param pulse_background A CSS background definition for the pulse. The
-#'   default uses a
-#'   [linear-gradient](https://developer.mozilla.org/en-US/docs/Web/CSS/gradient/linear-gradient)
-#'   of the theme's indigo, purple, and pink colors.
-#' @param pulse_height The height of the pulsing banner. This can be any valid
-#'   CSS size.
-#' @param pulse_speed The speed of the pulsing banner. This can be any valid CSS
-#'   time.
-#'
-#' @export
-#' @seealso [useBusyIndicators()] to disable/enable busy indicators.
-#' @examplesIf rlang::is_interactive()
-#'
-#' library(bslib)
-#'
-#' card_ui <- function(id, spinner_type = id) {
-#'   card(
-#'     busyIndicatorOptions(spinner_type = spinner_type),
-#'     card_header(paste("Spinner:", spinner_type)),
-#'     plotOutput(shiny::NS(id, "plot"))
-#'   )
-#' }
-#'
-#' card_server <- function(id, simulate = reactive()) {
-#'   moduleServer(
-#'     id = id,
-#'     function(input, output, session) {
-#'       output$plot <- renderPlot({
-#'         Sys.sleep(1)
-#'         simulate()
-#'         plot(x = rnorm(100), y = rnorm(100))
-#'       })
-#'     }
-#'   )
-#' }
-#'
-#' ui <- page_fillable(
-#'   useBusyIndicators(),
-#'   input_task_button("simulate", "Simulate", icon = icon("refresh")),
-#'   layout_columns(
-#'     card_ui("ring"),
-#'     card_ui("bars"),
-#'     card_ui("dots"),
-#'     card_ui("pulse"),
-#'     col_widths = 6
-#'   )
-#' )
-#'
-#' server <- function(input, output, session) {
-#'   simulate <- reactive(input$simulate)
-#'   card_server("ring", simulate)
-#'   card_server("bars", simulate)
-#'   card_server("dots", simulate)
-#'   card_server("pulse", simulate)
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-busyIndicatorOptions <- function(
-  ...,
-  spinner_type = NULL,
-  spinner_color = NULL,
-  spinner_size = NULL,
-  spinner_delay = NULL,
-  spinner_selector = NULL,
-  fade_opacity = NULL,
-  fade_selector = NULL,
-  pulse_background = NULL,
-  pulse_height = NULL,
-  pulse_speed = NULL
-) {
-
-  rlang::check_dots_empty()
-
-  res <- tagList(
-    spinnerOptions(
-      type = spinner_type,
-      color = spinner_color,
-      size = spinner_size,
-      delay = spinner_delay,
-      selector = spinner_selector
-    ),
-    fadeOptions(opacity = fade_opacity, selector = fade_selector),
-    pulseOptions(
-      background = pulse_background,
-      height = pulse_height,
-      speed = pulse_speed
-    )
-  )
-
-  bslib::as.card_item(dropNulls(res))
-}
-
-
-spinnerOptions <- function(type = NULL, color = NULL, size = NULL, delay = NULL, selector = NULL) {
-  if (is.null(type) && is.null(color) && is.null(size) && is.null(delay) && is.null(selector)) {
-    return(NULL)
-  }
-
-  url <- NULL
-  if (!is.null(type)) {
-    stopifnot(is.character(type) && length(type) == 1)
-    if (file.exists(type) && grepl("\\.svg$", type)) {
-      typeRaw <- readBin(type, "raw", n = file.info(type)$size)
-      url <- sprintf("url('data:image/svg+xml;base64,%s')", rawToBase64(typeRaw))
-    } else {
-      type <- rlang::arg_match(type, .busySpinnerTypes)
-      url <- sprintf("url('spinners/%s.svg')", type)
-    }
-  }
-
-  # Options controlled via CSS variables.
-  css_vars <- htmltools::css(
-    "--shiny-spinner-url" = url,
-    "--shiny-spinner-color" = htmltools::parseCssColors(color),
-    "--shiny-spinner-size" = htmltools::validateCssUnit(size),
-    "--shiny-spinner-delay" = delay
-  )
-
-  id <- NULL
-  if (is.null(selector)) {
-    id <- paste0("spinner-options-", p_randomInt(100, 1000000))
-    selector <- sprintf(":has(> #%s)", id)
-  }
-
-  css <- HTML(paste0(selector, " {", css_vars, "}"))
-
-  tags$style(css, id = id)
-}
-
-fadeOptions <- function(opacity = NULL, selector = NULL) {
-  if (is.null(opacity) && is.null(selector)) {
-    return(NULL)
-  }
-
-  css_vars <- htmltools::css(
-    "--shiny-fade-opacity" = opacity
-  )
-
-  id <- NULL
-  if (is.null(selector)) {
-    id <- paste0("fade-options-", p_randomInt(100, 1000000))
-    selector <- sprintf(":has(> #%s)", id)
-  }
-
-  css <- HTML(paste0(selector, " {", css_vars, "}"))
-
-  tags$style(css, id = id)
-}
-
-pulseOptions <- function(background = NULL, height = NULL, speed = NULL) {
-  if (is.null(background) && is.null(height) && is.null(speed))  {
-    return(NULL)
-  }
-
-  css_vars <- htmltools::css(
-    "--shiny-pulse-background" = background,
-    "--shiny-pulse-height" = htmltools::validateCssUnit(height),
-    "--shiny-pulse-speed" = speed
-  )
-
-  tags$style(HTML(paste0(":root {", css_vars, "}")))
-}
-
-busyIndicatorDependency <- function() {
-  htmlDependency(
-    name = "shiny-busy-indicators",
-    version = get_package_version("shiny"),
-    src = "www/shared/busy-indicators",
-    package = "shiny",
-    stylesheet = "busy-indicators.css",
-    # TODO-future: In next release make spinners and pulse opt-out
-    # head = as.character(useBusyIndicators())
-  )
-}

R/cache-disk.R

@@ -0,0 +1,567 @@
+#' 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 check that the returned object is not a
+#' `key_missing()` object, using `is.key_missing()`. 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('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 = ", ")))
+          rm_success <- file.remove(info$name[rm_idx])
+          # This maps rm_success back into the TRUEs in the rm_idx vector.
+          # If (for example) rm_idx is c(F,T,F,T,T) and rm_success is c(T,F,T),
+          # then this line modifies rm_idx to be c(F,T,F,F,T).
+          rm_idx[rm_idx] <- rm_success
+          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])
+        rm_idx[rm_idx] <- rm_success
+        info <- info[!rm_idx, ]
+      }
+
+      # 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])
+        rm_idx[rm_idx] <- rm_success
+        info <- info[!rm_idx, ]
+      }
+
+      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)
+      cat(text, sep = "\n", file = private$logfile, append = TRUE)
+    }
+  )
+)

R/cache-memory.R

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

R/cache-utils.R

@@ -1,25 +1,9 @@
-# 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
+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 (is_cache_object(cache)) {
-    return(cache)
+  if (grepl("[^a-z0-9]", key)) {
+    stop("Invalid key: ", key, ". Only lowercase letters and numbers are allowed.")
   }
-
-  stop('`cache` must either be "app", "session", or a cache object with methods, `$get`, and `$set`.')
 }

R/conditions.R

@@ -75,18 +75,6 @@ getCallNames <- function(calls) {
   })
 }
 
-# A stripped down version of getCallNames() that intentionally avoids deparsing expressions.
-# Instead, it leaves expressions to be directly `rlang::hash()` (for de-duplication), which
-# is much faster than deparsing then hashing.
-getCallNamesForHash <- function(calls) {
-  lapply(calls, function(call) {
-    name <- call[[1L]]
-    if (is.function(name)) return("<Anonymous>")
-    if (typeof(name) == "promise") return("<Promise>")
-    name
-  })
-}
-
 getLocs <- function(calls) {
   vapply(calls, function(call) {
     srcref <- attr(call, "srcref", exact = TRUE)
@@ -142,48 +130,10 @@ captureStackTraces <- function(expr) {
 #' @include globals.R
 .globals$deepStack <- NULL
 
-getCallStackDigest <- function(callStack, warn = FALSE) {
-  dg <- attr(callStack, "shiny.stack.digest", exact = TRUE)
-  if (!is.null(dg)) {
-    return(dg)
-  }
-
-  if (isTRUE(warn)) {
-    rlang::warn(
-      "Call stack doesn't have a cached digest; expensively computing one now",
-      .frequency = "once",
-      .frequency_id = "deepstack-uncached-digest-warning"
-    )
-  }
-
-  rlang::hash(getCallNamesForHash(callStack))
-}
-
-saveCallStackDigest <- function(callStack) {
-  attr(callStack, "shiny.stack.digest") <- getCallStackDigest(callStack, warn = FALSE)
-  callStack
-}
-
-# Appends a call stack to a list of call stacks, but only if it's not already
-# in the list. The list is deduplicated by digest; ideally the digests on the
-# list are cached before calling this function (you will get a warning if not).
-appendCallStackWithDedupe <- function(lst, x) {
-  digests <- vapply(lst, getCallStackDigest, character(1), warn = TRUE)
-  xdigest <- getCallStackDigest(x, warn = TRUE)
-  stopifnot(all(nzchar(digests)))
-  stopifnot(length(xdigest) == 1)
-  stopifnot(nzchar(xdigest))
-  if (xdigest %in% digests) {
-    return(lst)
-  } else {
-    return(c(lst, list(x)))
-  }
-}
-
 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)
@@ -192,14 +142,13 @@ createStackTracePromiseDomain <- function() {
         currentStack <- sys.calls()
         currentParents <- sys.parents()
         attr(currentStack, "parents") <- currentParents
-        currentStack <- saveCallStackDigest(currentStack)
         currentDeepStack <- .globals$deepStack
       }
       function(...) {
         # Fulfill time
         if (deepStacksEnabled()) {
           origDeepStack <- .globals$deepStack
-          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -216,14 +165,13 @@ createStackTracePromiseDomain <- function() {
         currentStack <- sys.calls()
         currentParents <- sys.parents()
         attr(currentStack, "parents") <- currentParents
-        currentStack <- saveCallStackDigest(currentStack)
         currentDeepStack <- .globals$deepStack
       }
       function(...) {
         # Fulfill time
         if (deepStacksEnabled()) {
           origDeepStack <- .globals$deepStack
-          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -251,7 +199,6 @@ doCaptureStack <- function(e) {
     calls <- sys.calls()
     parents <- sys.parents()
     attr(calls, "parents") <- parents
-    calls <- saveCallStackDigest(calls)
     attr(e, "stack.trace") <- calls
   }
   if (deepStacksEnabled()) {
@@ -270,7 +217,7 @@ doCaptureStack <- function(e) {
 #' @rdname stacktrace
 #' @export
 withLogErrors <- function(expr,
-  full = get_devmode_option("shiny.fullstacktrace", FALSE),
+  full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   withCallingHandlers(
@@ -281,9 +228,7 @@ 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 (cnd_inherits(cond, "shiny.silent.error")) {
-            return()
-          }
+          if (inherits(cond, "shiny.silent.error")) return()
           if (isTRUE(getOption("show.error.messages"))) {
             printError(cond, full = full, offset = offset)
           }
@@ -294,7 +239,7 @@ withLogErrors <- function(expr,
     },
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
-      if (cnd_inherits(cond, "shiny.silent.error")) return()
+      if (inherits(cond, "shiny.silent.error")) return()
       if (isTRUE(getOption("show.error.messages"))) {
         printError(cond, full = full, offset = offset)
       }
@@ -319,128 +264,176 @@ withLogErrors <- function(expr,
 #' @rdname stacktrace
 #' @export
 printError <- function(cond,
-  full = get_devmode_option("shiny.fullstacktrace", FALSE),
+  full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s",
+  
+  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s", 
     getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
-
+  
   printStackTrace(cond, full = full, offset = offset)
 }
 
 #' @rdname stacktrace
 #' @export
 printStackTrace <- function(cond,
-  full = get_devmode_option("shiny.fullstacktrace", FALSE),
+  full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
-  stackTraces <- c(
-    attr(cond, "deep.stack.trace", exact = TRUE),
-    list(attr(cond, "stack.trace", exact = TRUE))
-  )
-
-  # Stripping of stack traces is the one step where the different stack traces
-  # interact. So we need to do this in one go, instead of individually within
-  # printOneStackTrace.
-  if (!full) {
-    stripResults <- stripStackTraces(lapply(stackTraces, getCallNames))
-  } else {
-    # If full is TRUE, we don't want to strip anything
-    stripResults <- rep_len(list(TRUE), length(stackTraces))
-  }
-
-  mapply(
-    seq_along(stackTraces),
-    rev(stackTraces),
-    rev(stripResults),
-    FUN = function(i, trace, stripResult) {
-      if (is.integer(trace)) {
-        noun <- if (trace > 1L) "traces" else "trace"
-        message("[ reached getOption(\"shiny.deepstacktrace\") -- omitted ", trace, " more stack ", noun, " ]")
-      } else {
-        if (i != 1) {
-          message("From earlier call:")
-        }
-        printOneStackTrace(
-          stackTrace = trace,
-          stripResult = stripResult,
-          full = full,
-          offset = offset
-        )
-      }
-      # No mapply return value--we're just printing
-      NULL
-    },
-    SIMPLIFY = FALSE
-  )
-
-  invisible()
-}
-
-printOneStackTrace <- function(stackTrace, stripResult, full, offset) {
-  calls <- offsetSrcrefs(stackTrace, offset = offset)
-  callNames <- getCallNames(stackTrace)
-  parents <- attr(stackTrace, "parents", exact = 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 <- dropTrivialFrames(callNames)
-    calls <- calls[toKeep]
-    callNames <- callNames[toKeep]
-    parents <- parents[toKeep]
-    stripResult <- stripResult[toKeep]
+    # toKeep is a list of logical vectors, of which elements (stack frames) to keep
+    toKeep <- lapply(stackTraceCallNames, dropTrivialFrames)
+    # We apply the list of logical vector indices to each data structure
+    stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+    stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+    stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
   }
+  
+  delayedAssign("all_true", {
+    # List of logical vectors that are all TRUE, the same shape as
+    # stackTraceCallNames. Delay the evaluation so we don't create it unless
+    # we need it, but if we need it twice then we don't pay to create it twice.
+    lapply(stackTraceCallNames, function(st) {
+      rep_len(TRUE, length(st))
+    })
+  })
+  
+  # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
+  # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
+  # logical vectors.
+  toShow <- mapply(
+    if (should_strip) stripStackTraces(stackTraceCallNames) else all_true,
+    if (should_prune) lapply(stackTraceParents, pruneStackTrace) else all_true,
+    FUN = `&`,
+    SIMPLIFY = FALSE
+  )
+  
+  dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
+    st <- data.frame(
+      num = rev(which(index)),
+      call = rev(nms[index]),
+      loc = rev(getLocs(calls[index])),
+      category = rev(getCallCategories(calls[index])),
+      stringsAsFactors = FALSE
+    )
+    
+    if (i != 1) {
+      message("From earlier call:")
+    }
 
-  toShow <- rep(TRUE, length(callNames))
-  if (should_prune) {
-    toShow <- toShow & pruneStackTrace(parents)
+    if (nrow(st) == 0) {
+      message("  [No stack trace available]")
+    } else {
+      width <- floor(log10(max(st$num))) + 1
+      formatted <- paste0(
+        "  ",
+        formatC(st$num, width = width),
+        ": ",
+        mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+          if (category == "pkg")
+            crayon::silver(name)
+          else if (category == "user")
+            crayon::blue$bold(name)
+          else
+            crayon::white(name)
+        }),
+        "\n"
+      )
+      cat(file = stderr(), formatted, sep = "")
+    }
+
+    st
+  }, SIMPLIFY = FALSE)
+  
+  invisible()
+}
+
+#' @details `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))
   }
-  if (should_strip) {
-    toShow <- toShow & stripResult
+  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]
 
-  # If we're running in testthat, hide the parts of the stack trace that can
-  # vary based on how testthat was launched. It's critical that this is not
-  # happen at the same time as dropTrivialFrames, which happens before
-  # pruneStackTrace; because dropTrivialTestFrames removes calls from the top
-  # (or bottom? whichever is the oldest?) of the stack, it breaks `parents`
-  # which is based on absolute indices of calls. dropTrivialFrames gets away
-  # with this because it only removes calls from the opposite side of the stack.
-  toShow <- toShow & dropTrivialTestFrames(callNames)
+  calls <- rev(calls) # Show in traceback() order
+  index <- rev(which(toShow))
+  width <- floor(log10(max(index))) + 1
 
-  st <- data.frame(
-    num = rev(which(toShow)),
-    call = rev(callNames[toShow]),
-    loc = rev(getLocs(calls[toShow])),
-    category = rev(getCallCategories(calls[toShow])),
+  data.frame(
+    num = index,
+    call = getCallNames(calls),
+    loc = getLocs(calls),
+    category = getCallCategories(calls),
     stringsAsFactors = FALSE
   )
-
-  if (nrow(st) == 0) {
-    message("  [No stack trace available]")
-  } else {
-    width <- floor(log10(max(st$num))) + 1
-    formatted <- paste0(
-      "  ",
-      formatC(st$num, width = width),
-      ": ",
-      mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
-        if (category == "pkg")
-          cli::col_silver(name)
-        else if (category == "user")
-          cli::style_bold(cli::col_blue(name))
-        else
-          cli::col_white(name)
-      }),
-      "\n"
-    )
-    cat(file = stderr(), formatted, sep = "")
-  }
-
-  invisible(st)
 }
 
 stripStackTraces <- function(stackTraces, values = FALSE) {
@@ -466,19 +459,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))
 }
 
@@ -493,32 +486,23 @@ 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) ||
-        parents[[i]] == 0 ||
-        parents[[i]] == i) {
+    if (!is_dupe[[i]] && parents[[i]] == current_node) {
       current_node <<- i
       TRUE
     } else {
       FALSE
     }
   }, FUN.VALUE = logical(1))
-
+  
   include
 }
 
@@ -531,40 +515,13 @@ 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)
   )
 }
 
-dropTrivialTestFrames <- function(callnames) {
-  if (!identical(Sys.getenv("TESTTHAT_IS_SNAPSHOT"), "true")) {
-    return(rep_len(TRUE, length(callnames)))
-  }
-
-  hideable <- callnames %in% c(
-    "test",
-    "devtools::test",
-    "test_check",
-    "testthat::test_check",
-    "test_dir",
-    "testthat::test_dir",
-    "test_file",
-    "testthat::test_file",
-    "test_local",
-    "testthat::test_local"
-  )
-
-  firstGoodCall <- min(which(!hideable))
-  toRemove <- firstGoodCall - 1L
-
-  c(
-    rep_len(FALSE, toRemove),
-    rep_len(TRUE, length(callnames) - toRemove)
-  )
-}
-
 offsetSrcrefs <- function(calls, offset = TRUE) {
   if (offset) {
     srcrefs <- getSrcRefs(calls)
@@ -573,12 +530,48 @@ 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

@@ -1,121 +0,0 @@
-
-#' 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

@@ -1,369 +0,0 @@
-#' 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")
-}
-
-in_client_devmode <- function() {
-  # Client-side devmode enables client-side only dev features without local
-  # devmode. Currently, the main feature is the client-side error console.
-  isTRUE(getOption("shiny.client_devmode", FALSE))
-}
-
-#' @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

@@ -1,255 +0,0 @@
-#' 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.
-#'
-#' @examplesIf rlang::is_interactive() && rlang::is_installed("mirai")
-#' library(shiny)
-#' library(bslib)
-#' library(mirai)
-#'
-#' # Set background processes for running tasks
-#' daemons(1)
-#' # Reset when the app is stopped
-#' onStop(function() daemons(0))
-#'
-#' ui <- page_fluid(
-#'   titlePanel("Extended Task Demo"),
-#'   p(
-#'     'Click the button below to perform a "calculation"',
-#'     "that takes a while to perform."
-#'   ),
-#'   input_task_button("recalculate", "Recalculate"),
-#'   p(textOutput("result"))
-#' )
-#'
-#' server <- function(input, output) {
-#'   rand_task <- ExtendedTask$new(function() {
-#'     mirai(
-#'       {
-#'         # Slow operation goes here
-#'         Sys.sleep(2)
-#'         sample(1:100, 1)
-#'       }
-#'     )
-#'   })
-#'
-#'   # Make button state reflect task.
-#'   # If using R >=4.1, you can do this instead:
-#'   # rand_task <- ExtendedTask$new(...) |> bind_task_button("recalculate")
-#'   bind_task_button(rand_task, "recalculate")
-#'
-#'   observeEvent(input$recalculate, {
-#'     # Invoke the extended in an observer
-#'     rand_task$invoke()
-#'   })
-#'
-#'   output$result <- renderText({
-#'     # React to updated results when the task completes
-#'     number <- rand_task$result()
-#'     paste0("Your number is ", number, ".")
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#' @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 conjunction with the
-    #'   [\{mirai\}](https://mirai.r-lib.org) or
-    #'   [\{future\}](https://rstudio.github.io/promises/articles/promises_04_futures.html)
-    #'   package. (In short, the return value of `func` should be a
-    #'   [`mirai`][mirai::mirai()], [`Future`][future::future()], `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")
-      call <- rlang::caller_call(n = 0)
-
-      if (
-        isolate(private$rv_status()) == "running" ||
-          private$invocation_queue$size() > 0
-      ) {
-        private$invocation_queue$add(list(args = args, call = call))
-      } else {
-        private$do_invoke(args, call = call)
-      }
-      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, call = NULL) {
-      private$rv_status("running")
-      private$rv_value(NULL)
-      private$rv_error(NULL)
-
-      p <- promises::promise_resolve(
-        maskReactiveContext(do.call(private$func, args))
-      )
-
-      p <- promises::then(
-        p,
-        onFulfilled = function(value, .visible) {
-          private$on_success(list(value = value, visible = .visible))
-        },
-        onRejected = function(error) {
-          private$on_error(error, call = call)
-        }
-      )
-
-      promises::finally(p, onFinally = function() {
-        if (private$invocation_queue$size() > 0) {
-          next_call <- private$invocation_queue$remove()
-          private$do_invoke(next_call$args, next_call$call)
-        }
-      })
-
-      invisible(NULL)
-    },
-
-    on_error = function(err, call = NULL) {
-      cli::cli_warn(
-        "ERROR: An error occurred when invoking the ExtendedTask.",
-        parent = err,
-        call = call
-      )
-      private$rv_status("error")
-      private$rv_error(err)
-    },
-
-    on_success = function(value) {
-      private$rv_status("success")
-      private$rv_value(value)
-    }
-  )
-)

R/font-awesome.R

@@ -0,0 +1,445 @@
+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,27 +1,70 @@
 # 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.
-  s3_register("knitr::knit_print", "reactive")
-  s3_register("knitr::knit_print", "shiny.appobj")
-  s3_register("knitr::knit_print", "shiny.render.function")
-}
+  register_s3_method("knitr", "knit_print", "reactive")
+  register_s3_method("knitr", "knit_print", "shiny.appobj")
+  register_s3_method("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)
+  # Shiny 1.4.0 bumps jQuery 1.x to 3.x, which caused a problem
+  # with static-rendering of htmlwidgets, and htmlwidgets 1.5
+  # includes a fix for this problem
+  # https://github.com/rstudio/shiny/issues/2630
+  register_upgrade_message("htmlwidgets", 1.5)
 }

R/graph.R

@@ -1,3 +1,32 @@
+# 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
 
 
@@ -19,7 +48,7 @@ reactIdStr <- function(num) {
 #' dependencies and execution in your application.
 #'
 #' To use the reactive log visualizer, start with a fresh R session and
-#' run the command `reactlog::reactlog_enable()`; then launch your
+#' run the command `options(shiny.reactlog=TRUE)`; then launch your
 #' application in the usual way (e.g. using [runApp()]). At
 #' any time you can hit Ctrl+F3 (or for Mac users, Command+F3) in your
 #' web browser to launch the reactive log visualization.
@@ -42,20 +71,16 @@ reactIdStr <- function(num) {
 #' call `reactlogShow()` explicitly.
 #'
 #' For security and performance reasons, do not enable
-#' `options(shiny.reactlog=TRUE)` (or `reactlog::reactlog_enable()`) in
-#' production environments. When the option is enabled, it's possible
-#' for any user of your app to see at least some of the source code of
-#' your reactive expressions and observers. In addition, reactlog
-#' should be considered a memory leak as it will constantly grow and
-#' will never reset until the R session is restarted.
+#' `shiny.reactlog` in production environments. When the option is
+#' enabled, it's possible for any user of your app to see at least some
+#' of the source code of your reactive expressions and observers.
 #'
 #' @name reactlog
 NULL
 
 
-#' @describeIn reactlog Return a list of reactive information.  Can be used in
-#'   conjunction with [reactlog::reactlog_show] to later display the reactlog
-#'   graph.
+#' @describeIn reactlog Return a list of reactive information.  Can be used in conjunction with
+#'   [reactlog::reactlog_show] to later display the reactlog graph.
 #' @export
 reactlog <- function() {
   rLog$asList()
@@ -69,35 +94,19 @@ reactlogShow <- function(time = TRUE) {
   check_reactlog()
   reactlog::reactlog_show(reactlog(), time = time)
 }
-
-#' @describeIn reactlog Resets the entire reactlog stack.  Useful for debugging
-#' and removing all prior reactive history.
+#' @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() {
   rLog$reset()
 }
 
-#' @describeIn reactlog Adds "mark" entry into the reactlog stack. This is
-#' useful for programmatically adding a marked entry in the reactlog, rather
-#' than using your keyboard's key combination.
-#'
-#' For example, we can _mark_ the reactlog at the beginning of an
-#' `observeEvent`'s calculation:
-#' ```r
-#' observeEvent(input$my_event_trigger, {
-#'   # Add a mark in the reactlog
-#'   reactlogAddMark()
-#'   # Run your regular event reaction code here...
-#'   ....
-#' })
-#' ```
-#' @param session The Shiny session to assign the mark to. Defaults to the
-#' current session.
-#' @export
-reactlogAddMark <- function(session = getDefaultReactiveDomain()) {
-  rLog$userMark(session)
-}
-
 # called in "/reactlog" middleware
 renderReactlog <- function(sessionToken = NULL, time = TRUE) {
   check_reactlog()
@@ -107,15 +116,28 @@ renderReactlog <- function(sessionToken = NULL, time = TRUE) {
     time = time
   )
 }
-
 check_reactlog <- function() {
-  if (!is_installed("reactlog", reactlog_min_version)) {
-    rlang::check_installed("reactlog", reactlog_min_version)
+  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")
   }
+
+  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",
@@ -123,6 +145,7 @@ RLog <- R6Class(
   private = list(
     option = "shiny.reactlog",
     msgOption = "shiny.reactlog.console",
+
     appendEntry = function(domain, logEntry) {
       if (self$isLogging()) {
         sessionToken <- if (is.null(domain)) NULL else domain$token
@@ -137,19 +160,20 @@ RLog <- R6Class(
   public = list(
     msg = "<MessageLogger>",
     logStack = "<Stack>",
+
     noReactIdLabel = "NoCtxReactId",
     noReactId = reactIdStr("NoCtxReactId"),
     dummyReactIdLabel = "DummyReactId",
     dummyReactId = reactIdStr("DummyReactId"),
+
     asList = function() {
       ret <- self$logStack$as_list()
       attr(ret, "version") <- "1"
       ret
     },
+
     ctxIdStr = function(ctxId) {
-      if (is.null(ctxId) || identical(ctxId, "")) {
-        return(NULL)
-      }
+      if (is.null(ctxId) || identical(ctxId, "")) return(NULL)
       paste0("ctx", ctxId)
     },
     namesIdStr = function(reactId) {
@@ -164,6 +188,7 @@ RLog <- R6Class(
     keyIdStr = function(reactId, key) {
       paste0(reactId, "$", key)
     },
+
     valueStr = function(value, n = 200) {
       if (!self$isLogging()) {
         # return a placeholder string to avoid calling str
@@ -173,9 +198,10 @@ RLog <- R6Class(
         # only capture the first level of the object
         utils::capture.output(utils::str(value, max.level = 1))
       })
-      outputTxt <- paste0(output, collapse = "\n")
+      outputTxt <- paste0(output, collapse="\n")
       msg$shortenString(outputTxt, n = n)
     },
+
     initialize = function(rlogOption = "shiny.reactlog", msgOption = "shiny.reactlog.console") {
       private$option <- rlogOption
       private$msgOption <- msgOption
@@ -185,7 +211,7 @@ RLog <- R6Class(
     reset = function() {
       .globals$reactIdCounter <- 0L
 
-      self$logStack <- fastmap::faststack()
+      self$logStack <- Stack$new()
       self$msg <- MessageLogger$new(option = private$msgOption)
 
       # setup dummy and missing react information
@@ -195,6 +221,7 @@ RLog <- R6Class(
     isLogging = function() {
       isTRUE(getOption(private$option, FALSE))
     },
+
     define = function(reactId, value, label, type, domain) {
       valueStr <- self$valueStr(value)
       if (msg$hasReact(reactId)) {
@@ -225,10 +252,9 @@ RLog <- R6Class(
     defineObserver = function(reactId, label, domain) {
       self$define(reactId, value = NULL, label, "observer", domain)
     },
+
     dependsOn = function(reactId, depOnReactId, ctxId, domain) {
-      if (is.null(reactId)) {
-        return()
-      }
+      if (is.null(reactId)) return()
       ctxId <- ctxIdStr(ctxId)
       msg$log("dependsOn:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
       private$appendEntry(domain, list(
@@ -241,6 +267,7 @@ RLog <- R6Class(
     dependsOnKey = function(reactId, depOnReactId, key, ctxId, domain) {
       self$dependsOn(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
     },
+
     dependsOnRemove = function(reactId, depOnReactId, ctxId, domain) {
       ctxId <- self$ctxIdStr(ctxId)
       msg$log("dependsOnRemove:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
@@ -254,6 +281,7 @@ RLog <- R6Class(
     dependsOnKeyRemove = function(reactId, depOnReactId, key, ctxId, domain) {
       self$dependsOnRemove(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
     },
+
     createContext = function(ctxId, label, type, prevCtxId, domain) {
       ctxId <- self$ctxIdStr(ctxId)
       prevCtxId <- self$ctxIdStr(prevCtxId)
@@ -264,9 +292,10 @@ RLog <- R6Class(
         label = msg$shortenString(label),
         type = type,
         prevCtxId = prevCtxId,
-        srcref = as.vector(attr(label, "srcref")), srcfile = attr(label, "srcfile")
+        srcref = as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile")
       ))
     },
+
     enter = function(reactId, ctxId, type, domain) {
       ctxId <- self$ctxIdStr(ctxId)
       if (identical(type, "isolate")) {
@@ -309,6 +338,7 @@ RLog <- R6Class(
         ))
       }
     },
+
     valueChange = function(reactId, value, domain) {
       valueStr <- self$valueStr(value)
       msg$log("valueChange:", msg$reactStr(reactId), msg$valueStr(valueStr))
@@ -330,6 +360,8 @@ RLog <- R6Class(
     valueChangeKey = function(reactId, key, value, domain) {
       self$valueChange(self$keyIdStr(reactId, key), value, domain)
     },
+
+
     invalidateStart = function(reactId, ctxId, type, domain) {
       ctxId <- self$ctxIdStr(ctxId)
       if (identical(type, "isolate")) {
@@ -372,6 +404,7 @@ RLog <- R6Class(
         ))
       }
     },
+
     invalidateLater = function(reactId, runningCtx, millis, domain) {
       msg$log("invalidateLater: ", millis, "ms", msg$reactStr(reactId), msg$ctxStr(runningCtx))
       private$appendEntry(domain, list(
@@ -381,12 +414,14 @@ RLog <- R6Class(
         millis = millis
       ))
     },
+
     idle = function(domain = NULL) {
       msg$log("idle")
       private$appendEntry(domain, list(
         action = "idle"
       ))
     },
+
     asyncStart = function(domain = NULL) {
       msg$log("asyncStart")
       private$appendEntry(domain, list(
@@ -399,6 +434,7 @@ RLog <- R6Class(
         action = "asyncStop"
       ))
     },
+
     freezeReactiveVal = function(reactId, domain) {
       msg$log("freeze:", msg$reactStr(reactId))
       private$appendEntry(domain, list(
@@ -409,6 +445,7 @@ RLog <- R6Class(
     freezeReactiveKey = function(reactId, key, domain) {
       self$freezeReactiveVal(self$keyIdStr(reactId, key), domain)
     },
+
     thawReactiveVal = function(reactId, domain) {
       msg$log("thaw:", msg$reactStr(reactId))
       private$appendEntry(domain, list(
@@ -419,60 +456,54 @@ RLog <- R6Class(
     thawReactiveKey = function(reactId, key, domain) {
       self$thawReactiveVal(self$keyIdStr(reactId, key), domain)
     },
+
     userMark = function(domain = NULL) {
       msg$log("userMark")
       private$appendEntry(domain, list(
         action = "userMark"
       ))
     }
+
   )
 )
 
-MessageLogger <- R6Class(
+MessageLogger = R6Class(
   "MessageLogger",
   portable = FALSE,
   public = list(
     depth = 0L,
     reactCache = list(),
     option = "shiny.reactlog.console",
+
     initialize = function(option = "shiny.reactlog.console", depth = 0L) {
       if (!missing(depth)) self$depth <- depth
       if (!missing(option)) self$option <- option
     },
+
     isLogging = function() {
       isTRUE(getOption(self$option))
     },
     isNotLogging = function() {
-      !isTRUE(getOption(self$option))
+      ! isTRUE(getOption(self$option))
     },
     depthIncrement = function() {
-      if (self$isNotLogging()) {
-        return(NULL)
-      }
+      if (self$isNotLogging()) return(NULL)
       self$depth <- self$depth + 1L
     },
     depthDecrement = function() {
-      if (self$isNotLogging()) {
-        return(NULL)
-      }
+      if (self$isNotLogging()) return(NULL)
       self$depth <- self$depth - 1L
     },
     hasReact = function(reactId) {
-      if (self$isNotLogging()) {
-        return(FALSE)
-      }
+      if (self$isNotLogging()) return(FALSE)
       !is.null(self$getReact(reactId))
     },
     getReact = function(reactId, force = FALSE) {
-      if (identical(force, FALSE) && self$isNotLogging()) {
-        return(NULL)
-      }
+      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
       self$reactCache[[reactId]]
     },
     setReact = function(reactObj, force = FALSE) {
-      if (identical(force, FALSE) && self$isNotLogging()) {
-        return(NULL)
-      }
+      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
       self$reactCache[[reactObj$reactId]] <- reactObj
     },
     shortenString = function(txt, n = 250) {
@@ -487,21 +518,17 @@ MessageLogger <- R6Class(
       return(txt)
     },
     singleLine = function(txt) {
-      gsub("([^\\])\\n", "\\1\\\\n", txt)
+      gsub("[^\\]\\n", "\\\\n", txt)
     },
     valueStr = function(valueStr) {
       paste0(
-        " '", self$shortenString(self$singleLine(valueStr)), "'"
+        " '",  self$shortenString(self$singleLine(valueStr)), "'"
       )
     },
     reactStr = function(reactId) {
-      if (self$isNotLogging()) {
-        return(NULL)
-      }
+      if (self$isNotLogging()) return(NULL)
       reactInfo <- self$getReact(reactId)
-      if (is.null(reactInfo)) {
-        return(" <UNKNOWN_REACTID>")
-      }
+      if (is.null(reactInfo)) return(" <UNKNOWN_REACTID>")
       paste0(
         " ", reactInfo$reactId, ":'", self$shortenString(self$singleLine(reactInfo$label)), "'"
       )
@@ -510,15 +537,11 @@ MessageLogger <- R6Class(
       self$ctxStr(ctxId = NULL, type = type)
     },
     ctxStr = function(ctxId = NULL, type = NULL) {
-      if (self$isNotLogging()) {
-        return(NULL)
-      }
+      if (self$isNotLogging()) return(NULL)
       self$ctxPrevCtxStr(ctxId = ctxId, prevCtxId = NULL, type = type)
     },
     ctxPrevCtxStr = function(ctxId = NULL, prevCtxId = NULL, type = NULL, preCtxIdTxt = " in ") {
-      if (self$isNotLogging()) {
-        return(NULL)
-      }
+      if (self$isNotLogging()) return(NULL)
       paste0(
         if (!is.null(ctxId)) paste0(preCtxIdTxt, ctxId),
         if (!is.null(prevCtxId)) paste0(" from ", prevCtxId),
@@ -526,9 +549,7 @@ MessageLogger <- R6Class(
       )
     },
     log = function(...) {
-      if (self$isNotLogging()) {
-        return(NULL)
-      }
+      if (self$isNotLogging()) return(NULL)
       msg <- paste0(
         paste0(rep("= ", depth), collapse = ""), "- ", paste0(..., collapse = ""),
         collapse = ""
@@ -538,6 +559,5 @@ MessageLogger <- R6Class(
   )
 )
 
-on_load({
-  rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")
-})
+#' @include stack.R
+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
-#' programmatically from within the server code, you must use
+#' programatically from within the server code, you must use
 #' `updateQueryString(_yourNewQueryString_, mode = "push")`. The default
 #' `mode` for `updateQueryString` is `"replace"`, which doesn't
 #' raise any events, so any observers or reactives that depend on it will

R/html-deps.R

@@ -40,14 +40,11 @@ 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) {
-  tags <- utils::getFromNamespace("tagify", "htmltools")(tags)
-  ui <- takeSingletons(tags, session$singletons, desingleton = FALSE)$ui
+  ui <- takeSingletons(tags, session$singletons, desingleton=FALSE)$ui
   ui <- surroundSingletons(ui)
   dependencies <- lapply(
-    resolveDependencies(findDependencies(ui, tagify = FALSE)),
+    resolveDependencies(findDependencies(ui)),
     createWebDependency
   )
   names(dependencies) <- NULL

R/htmltools.R

@@ -0,0 +1,11 @@
+#' @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

@@ -20,6 +20,7 @@
 #'   `delay` milliseconds before sending an event.
 #' @seealso [brushOpts()] for brushing events.
 #' @export
+#' @keywords internal
 clickOpts <- function(id, clip = TRUE) {
   if (is.null(id))
     stop("id must not be NULL")
@@ -75,12 +76,8 @@ 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. 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 fill Fill color of the brush.
+#' @param stroke Outline color of the brush.
 #' @param opacity Opacity of the brush
 #' @param delay How long to delay (in milliseconds) when debouncing or
 #'   throttling, before sending the brush data to the server.
@@ -110,13 +107,6 @@ 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,
@@ -129,13 +119,3 @@ 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,21 +92,11 @@ 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      %||% brush$mapping$x
-  yvar      <- yvar      %||% brush$mapping$y
-  panelvar1 <- panelvar1 %||% brush$mapping$panelvar1
-  panelvar2 <- panelvar2 %||% brush$mapping$panelvar2
+  xvar      <- xvar      %OR% brush$mapping$x
+  yvar      <- yvar      %OR% brush$mapping$y
+  panelvar1 <- panelvar1 %OR% brush$mapping$panelvar1
+  panelvar2 <- panelvar2 %OR% brush$mapping$panelvar2
 
   # Filter out x and y values
   keep_rows <- rep(TRUE, nrow(df))
@@ -182,8 +172,8 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ xmax     : num 3.78
 #  $ ymin     : num 17.1
 #  $ ymax     : num 20.4
-#  $ panelvar1: chr "6"
-#  $ panelvar2: chr "0
+#  $ panelvar1: int 6
+#  $ panelvar2: int 0
 #  $ coords_css:List of 4
 #   ..$ xmin: int 260
 #   ..$ xmax: int 298
@@ -240,21 +230,11 @@ 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      %||% coordinfo$mapping$x
-  yvar      <- yvar      %||% coordinfo$mapping$y
-  panelvar1 <- panelvar1 %||% coordinfo$mapping$panelvar1
-  panelvar2 <- panelvar2 %||% coordinfo$mapping$panelvar2
+  xvar      <- xvar      %OR% coordinfo$mapping$x
+  yvar      <- yvar      %OR% coordinfo$mapping$y
+  panelvar1 <- panelvar1 %OR% coordinfo$mapping$panelvar1
+  panelvar2 <- panelvar2 %OR% coordinfo$mapping$panelvar2
 
   if (is.null(xvar))
     stop("nearPoints: not able to automatically infer `xvar` from coordinfo")
@@ -267,7 +247,6 @@ 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)
 
@@ -367,8 +346,8 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 #  $ img_css_ratio:List of 2
 #   ..$ x: num 1.25
 #   ..$ y: num 1.25
-#  $ panelvar1 : chr "6"
-#  $ panelvar2 : chr "0"
+#  $ panelvar1 : int 6
+#  $ panelvar2 : int 0
 #  $ mapping   :List of 4
 #   ..$ x        : chr "wt"
 #   ..$ y        : chr "mpg"
@@ -393,7 +372,6 @@ 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:
@@ -416,43 +394,11 @@ 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, ...) {
-  pngfun <- if ((getOption('shiny.useragg') %||% TRUE) && is_installed("ragg")) {
-    ragg::agg_png
+  # 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
   } else if (capabilities("aqua")) {
     # i.e., png(type = 'quartz')
-    grDevices::png
-  } else if ((getOption('shiny.usecairo') %||% TRUE) && is_installed("Cairo")) {
-    Cairo::CairoPNG
+    pngfun <- grDevices::png
+  } else if ((getOption('shiny.usecairo') %OR% TRUE) && is_available("Cairo")) {
+    pngfun <- Cairo::CairoPNG
   } else {
     # i.e., png(type = 'cairo')
-    grDevices::png
+    pngfun <- grDevices::png
   }
 
-  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
+  args <- rlang::list2(filename=filename, width=width, height=height, res=res, ...)
 
   # Set a smarter default for the device's bg argument (based on thematic's global state).
   # Note that, technically, this is really only needed for CairoPNG, since the other
   # devices allow their bg arg to be overridden by par(bg=...), which thematic does prior
   # to plot-time, but it shouldn't hurt to inform other the device directly as well
   if (is.null(args$bg) && isNamespaceLoaded("thematic")) {
-    args$bg <- getThematicOption("bg", "white")
+    # TODO: use :: once thematic is on CRAN
+    args$bg <- utils::getFromNamespace("thematic_get_option", "thematic")("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,35 +58,33 @@ startPNG <- function(filename, width, height, res, ...) {
   grDevices::dev.cur()
 }
 
-#' Capture a plot as a PNG file.
+#' Run a plotting function and save the output as a PNG
 #'
-#' 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.
+#' 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.
 #'
-#' @details
-#'   A `NULL` value provided to `width` or `height` is ignored (i.e., the
-#'   default `width` or `height` of the graphics device is used).
+#' For output, it will try to use the following devices, in this order:
+#' quartz (via [grDevices::png()]), then [Cairo::CairoPNG()],
+#' and finally [grDevices::png()]. This is in order of quality of
+#' output. Notably, plain `png` output on Linux and Windows may not
+#' antialias some point shapes, resulting in poor quality output.
+#'
+#' In some cases, `Cairo()` provides output that looks worse than
+#' `png()`. To disable Cairo output for an app, use
+#' `options(shiny.usecairo=FALSE)`.
 #'
 #' @param func A function that generates a plot.
 #' @param filename The name of the output file. Defaults to a temp file with
 #'   extension `.png`.
 #' @param width Width in pixels.
 #' @param height Height in pixels.
-#' @param res Resolution in pixels per inch. This value is passed to the
-#'   graphics device. Note that this affects the resolution of PNG rendering in
+#' @param res Resolution in pixels per inch. This value is passed to
+#'   [grDevices::png()]. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
-#' @param ... Arguments to be passed through to the graphics device. These can
-#'   be used to set the width, height, background color, etc.
-#'
-#' @return A path to the newly generated PNG file.
-#'
+#' @param ... Arguments to be passed through to [grDevices::png()].
+#'   These can be used to set the width, height, background color, etc.
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
@@ -97,6 +95,7 @@ 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,8 +7,6 @@
 #' @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
@@ -51,17 +49,15 @@
 #'   * 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,
-  disabled = FALSE, ...) {
+actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
 
   value <- restoreInput(id = inputId, default = NULL)
 
   tags$button(id=inputId,
-    style = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("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", class = "shiny-input-checkbox")
+  inputTag <- tags$input(id = inputId, type="checkbox")
   if (!is.null(value) && value)
     inputTag$attribs$checked <- "checked"
 
   div(class = "form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     div(class = "checkbox",
       tags$label(inputTag, tags$span(label))
     )

R/input-checkboxgroup.R

@@ -94,14 +94,10 @@ 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 = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     class = divClass,
-    # https://www.w3.org/TR/wai-aria-practices/examples/checkbox/checkbox-1/checkbox-1.html
-    role = "group",
-    `aria-labelledby` = inputLabel$attribs$id,
-    inputLabel,
+    shinyInputLabel(inputId, label),
     options
   )
 }

R/input-date.R

@@ -105,7 +105,7 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
 
   tags$div(id = inputId,
     class = "shiny-date-input form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
 
     shinyInputLabel(inputId, label),
     tags$input(type = "text",
@@ -133,15 +133,15 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
 }
 
 
+datePickerVersion <- "1.9.0"
+
 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",
+      version = datePickerVersion,
+      src = c(href = "shared/datepicker"),
+      script = "js/bootstrap-datepicker.min.js",
       # Need to enable noConflict mode. See #1346.
       head = "<script>(function() {
         var datepicker = $.fn.datepicker.noConflict();
@@ -149,13 +149,7 @@ datePickerDependency <- function(theme) {
       })();
      </script>"
     ),
-    bslib::bs_dependency_defer(datePickerCSS)
-  )
-}
-
-datePickerSass <- function() {
-  sass::sass_file(
-    system_file(package = "shiny", "www/shared/datepicker/scss/build3.scss")
+    bootstraplib::bs_dependency_defer(datePickerCSS)
   )
 }
 
@@ -163,18 +157,19 @@ 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",
+      version = datePickerVersion,
+      src = c(href = "shared/datepicker"),
       stylesheet = "css/bootstrap-datepicker3.min.css"
     ))
   }
 
-  bslib::bs_dependency(
-    input = datePickerSass(),
+  scss_file <- system.file(package = "shiny", "www/shared/datepicker/scss/build3.scss")
+
+  bootstraplib::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")
+    version = datePickerVersion,
+    cache_key_extra = utils::packageVersion("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 = css(width = validateCssUnit(width)),
+      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
 
       shinyInputLabel(inputId, label),
       # input-daterange class is needed for dropdown behavior

R/input-file.R

@@ -2,13 +2,8 @@
 #'
 #' 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.
-#'
-#' 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.
+#' Whenever a file upload completes, the corresponding input variable is set
+#' to a dataframe. See the `Server value` section.
 #'
 #' @family input elements
 #'
@@ -16,30 +11,19 @@
 #' @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()) {
@@ -72,9 +56,7 @@
 #' }
 #'
 #' @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
@@ -91,8 +73,7 @@
 #'
 #' @export
 fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
-  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected",
-  capture = NULL) {
+  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
 
   restoredValue <- restoreInput(id = inputId, default = NULL)
 
@@ -108,7 +89,6 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
 
   inputTag <- tags$input(
     id = inputId,
-    class = "shiny-input-file",
     name = inputId,
     type = "file",
     # 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/
@@ -121,12 +101,9 @@ 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 = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     shinyInputLabel(inputId, label),
 
     div(class = "input-group",

R/input-numeric.R

@@ -29,37 +29,23 @@
 #' A numeric vector of length 1.
 #'
 #' @export
-numericInput <- function(
-  inputId,
-  label,
-  value,
-  min = NA,
-  max = NA,
-  step = NA,
-  width = NULL,
-  ...,
-  updateOn = c("change", "blur")
-) {
-  rlang::check_dots_empty()
-  updateOn <- rlang::arg_match(updateOn)
+numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
+  width = NULL) {
 
   value <- restoreInput(id = inputId, default = value)
 
   # build input tag
-  inputTag <- tags$input(
-    id = inputId,
-    type = "number",
-    class = "shiny-input-number form-control",
-    value = formatNoSci(value),
-    `data-update-on` = updateOn
-  )
-  if (!is.na(min)) inputTag$attribs$min = min
-  if (!is.na(max)) inputTag$attribs$max = max
-  if (!is.na(step)) inputTag$attribs$step = step
+  inputTag <- tags$input(id = inputId, type = "number", class="form-control",
+                         value = formatNoSci(value))
+  if (!is.na(min))
+    inputTag$attribs$min = min
+  if (!is.na(max))
+    inputTag$attribs$max = max
+  if (!is.na(step))
+    inputTag$attribs$step = step
 
-  div(
-    class = "form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     shinyInputLabel(inputId, label),
     inputTag
   )

R/input-password.R

@@ -30,29 +30,12 @@
 #' shinyApp(ui, server)
 #' }
 #' @export
-passwordInput <- function(
-  inputId,
-  label,
-  value = "",
-  width = NULL,
-  placeholder = NULL,
-  ...,
-  updateOn = c("change", "blur")
-) {
-  rlang::check_dots_empty()
-  updateOn <- rlang::arg_match(updateOn)
-
-  div(
-    class = "form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+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), ";"),
     shinyInputLabel(inputId, label),
-    tags$input(
-      id = inputId,
-      type = "password",
-      class = "shiny-input-password form-control",
-      value = value,
-      placeholder = placeholder,
-      `data-update-on` = updateOn
-    )
+    tags$input(id = inputId, type="password", class="form-control", value=value,
+               placeholder = placeholder)
   )
 }

R/input-radiobuttons.R

@@ -104,14 +104,10 @@ 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 = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     class = divClass,
-    # 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,
+    shinyInputLabel(inputId, label),
     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://selectize.dev/>) instead of
+#' \pkg{selectize.js} (<https://github.com/selectize/selectize.js>) instead of
 #' the basic select input element. To use the standard HTML select input
 #' element, use `selectInput()` with `selectize=FALSE`.
 #'
@@ -106,7 +106,6 @@ 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, inputId, selectize)
@@ -117,7 +116,7 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   # return label and select tag
   res <- div(
     class = "form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     shinyInputLabel(inputId, label),
     div(selectTag)
   )
@@ -173,7 +172,7 @@ needOptgroup <- function(choices) {
 
 #' @rdname selectInput
 #' @param ... Arguments passed to `selectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}(<https://selectize.dev/docs/usage>)
+#' @param options A list of options. See the documentation of \pkg{selectize.js}
 #'   for possible options (character option values inside [base::I()] will
 #'   be treated as literal JavaScript code; see [renderDataTable()]
 #'   for details).
@@ -198,12 +197,6 @@ 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'))
@@ -211,10 +204,18 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   res <- checkAsIs(options)
 
-  deps <- list(selectizeDependency())
+  selectizeDep <- selectizeDependency()
 
   if ('drag_drop' %in% options$plugins) {
-    deps[[length(deps) + 1]] <- jqueryuiDependency()
+    selectizeDep <- c(
+      selectizeDep,
+      htmlDependency(
+        'jqueryui',
+        '1.12.1',
+        c(href = 'shared/jqueryui'),
+        script = 'jquery-ui.min.js'
+      )
+    )
   }
 
   # Insert script on same level as <select> tag
@@ -224,72 +225,56 @@ 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)),
-      HTML(toJSON(res$options))
+      if (length(res$options)) HTML(toJSON(res$options)) else '{}'
     )
   )
 
-  attachDependencies(select, deps)
+  attachDependencies(select, selectizeDep)
 }
 
 
-selectizeDependency <- function() {
-  bslib::bs_dependency_defer(selectizeDependencyFunc)
+selectizeVersion <- "0.12.4"
+
+selectizeDependency <- function(theme) {
+  list(
+    htmlDependency(
+      "selectize-js",
+      selectizeVersion,
+      src = c(href = "shared/selectize"),
+      script = c(
+        "js/selectize.min.js",
+        # Accessibility plugin for screen readers (https://github.com/SLMNBJ/selectize-plugin-a11y):
+        "accessibility/js/selectize-plugin-a11y.min.js"
+      )
+    ),
+    bootstraplib::bs_dependency_defer(selectizeCSS)
+  )
 }
 
-selectizeDependencyFunc <- function(theme) {
+selectizeCSS <- function(theme) {
   if (!is_bs_theme(theme)) {
-    return(selectizeStaticDependency(version_selectize))
+    return(htmlDependency(
+      name = "selectize-css",
+      version = selectizeVersion,
+      src = c(href = "shared/selectize"),
+      stylesheet = "css/selectize.bootstrap3.css"
+    ))
   }
 
-  bs_version <- bslib::theme_version(theme)
-
-  # 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
-  selectizeDir <- system_file(package = "shiny", "www/shared/selectize/")
-  script <- file.path(selectizeDir, selectizeScripts())
-
-  bslib::bs_dependency(
-    input = selectizeSass(bs_version),
+  scss_file <- system.file(
+    package = "shiny", "www/shared/selectize/scss",
+    if ("3" %in% bootstraplib::theme_version(theme)) {
+      "selectize.bootstrap3.scss"
+    } else {
+      "selectize.bootstrap4.scss"
+    }
+  )
+  bootstraplib::bs_dependency(
+    input = sass::sass_file(scss_file),
     theme = theme,
     name = "selectize",
-    version = version_selectize,
-    cache_key_extra = get_package_version("shiny"),
-    .dep_args = list(script = script)
-  )
-}
-
-selectizeSass <- function(bs_version) {
-  selectizeDir <- system_file(package = "shiny", "www/shared/selectize/")
-  stylesheet <- file.path(
-    selectizeDir, "scss", paste0("selectize.bootstrap", bs_version, ".scss")
-  )
-  sass::sass_file(stylesheet)
-}
-
-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"
+    version = selectizeVersion,
+    cache_key_extra = utils::packageVersion("shiny")
   )
 }
 
@@ -301,7 +286,7 @@ selectizeScripts <- function() {
 #'
 #' By default, `varSelectInput()` and `selectizeInput()` use the
 #' JavaScript library \pkg{selectize.js}
-#' (<https://selectize.dev/>) to instead of the basic
+#' (<https://github.com/selectize/selectize.js>) to instead of the basic
 #' select input element. To use the standard HTML select input element, use
 #' `selectInput()` with `selectize=FALSE`.
 #'
@@ -397,7 +382,7 @@ varSelectInput <- function(
 
 #' @rdname varSelectInput
 #' @param ... Arguments passed to `varSelectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}(<https://selectize.dev/docs/usage>)
+#' @param options A list of options. See the documentation of \pkg{selectize.js}
 #'   for possible options (character option values inside [base::I()] will
 #'   be treated as literal JavaScript code; see [renderDataTable()]
 #'   for details).

R/input-slider.R

@@ -1,24 +1,25 @@
 #' Slider Input Widget
 #'
-#' Constructs a slider widget to select a number, date, or date-time from a
-#' range.
+#' Constructs a slider widget to select a numeric value from a range.
 #'
 #' @inheritParams textInput
-#' @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 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 step Specifies the interval between each selectable value on the
-#'   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.
+#'   slider (if `NULL`, a heuristic is used to determine the step size). If
+#'   the values are dates, `step` is in days; if the values are times
+#'   (POSIXt), `step` is in seconds.
 #' @param round `TRUE` to round all values to the nearest integer;
 #'   `FALSE` if no rounding is desired; or an integer to round to that
 #'   number of digits (for example, 1 will round to the nearest 10, and -2 will
 #'   round to the nearest .01). Any rounding will be applied after snapping to
 #'   the nearest step.
+#' @param format Deprecated.
+#' @param locale Deprecated.
 #' @param ticks `FALSE` to hide tick marks, `TRUE` to show them
 #'   according to some simple heuristics.
 #' @param animate `TRUE` to show simple animation controls with default
@@ -71,15 +72,22 @@
 #' }
 #'
 #' @section Server value:
-#' A number, date, or date-time (depending on the class of `value`), or
-#' in the case of slider range, a vector of two numbers/dates/date-times.
+#' A number, or in the case of slider range, a vector of two numbers.
 #'
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
-                        round = FALSE, ticks = TRUE, animate = FALSE,
-                        width = NULL, sep = ",", pre = NULL, post = NULL,
-                        timeFormat = NULL, timezone = NULL, dragRange = TRUE) {
-  validate_slider_value(min, max, value, "sliderInput")
+                        round = FALSE, format = NULL, locale = NULL,
+                        ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
+                        pre = NULL, post = NULL, timeFormat = NULL,
+                        timezone = NULL, dragRange = TRUE) {
+  if (!missing(format)) {
+    shinyDeprecated(msg = "The `format` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
+                    version = "0.10.2.2")
+  }
+  if (!missing(locale)) {
+    shinyDeprecated(msg = "The `locale` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
+                    version = "0.10.2.2")
+  }
 
   dataType <- getSliderType(min, max, value)
 
@@ -167,7 +175,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   })
 
   sliderTag <- div(class = "form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     shinyInputLabel(inputId, label),
     do.call(tags$input, sliderProps)
   )
@@ -201,33 +209,22 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
 }
 
 
+ionRangeSliderVersion <- "2.3.1"
+
 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",
+      "ionrangeslider-javascript", ionRangeSliderVersion,
+      src = c(href = "shared/ionrangeslider"),
       script = "js/ion.rangeSlider.min.js"
     ),
     htmlDependency(
-      "strftime",
-      version_strftime,
-      src = "www/shared/strftime",
-      package = "shiny",
+      "strftime", "0.9.2",
+      src = c(href = "shared/strftime"),
       script = "strftime-min.js"
     ),
-    bslib::bs_dependency_defer(ionRangeSliderDependencyCSS)
-  )
-}
-
-ionRangeSliderDependencySass <- function() {
-  list(
-    list(accent = "$component-active-bg"),
-    sass::sass_file(
-      system_file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss")
-    )
+    bootstraplib::bs_dependency_defer(ionRangeSliderDependencyCSS)
   )
 }
 
@@ -235,19 +232,31 @@ ionRangeSliderDependencyCSS <- function(theme) {
   if (!is_bs_theme(theme)) {
     return(htmlDependency(
       "ionrangeslider-css",
-      version_ion_range_slider,
-      src = "www/shared/ionrangeslider",
-      package = "shiny",
+      ionRangeSliderVersion,
+      src = c(href = "shared/ionrangeslider"),
       stylesheet = "css/ion.rangeSlider.css"
     ))
   }
 
-  bslib::bs_dependency(
-    input = ionRangeSliderDependencySass(),
+  # Remap some variable names for ionRangeSlider's scss
+  sass_input <- list(
+    list(
+      bg = "$input-bg",
+      fg = "$input-color",
+      accent = "$component-active-bg",
+      `font-family` = "$font-family-base"
+    ),
+    sass::sass_file(
+      system.file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss")
+    )
+  )
+
+  bootstraplib::bs_dependency(
+    input = sass_input,
     theme = theme,
     name = "ionRangeSlider",
-    version = version_ion_range_slider,
-    cache_key_extra = get_package_version("shiny")
+    version = ionRangeSliderVersion,
+    cache_key_extra = utils::packageVersion("shiny")
   )
 }
 
@@ -282,37 +291,6 @@ 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](https://shiny.rstudio.com/articles/action-buttons.html) for more information (including a demo of how to "translate"
+#' article](http://shiny.rstudio.com/articles/action-buttons.html) for more information (including a demo of how to "translate"
 #' code using a `submitButton` to code using an `actionButton`).
 #'
 #' In essence, the presence of a submit button stops all inputs from
@@ -57,8 +57,8 @@ submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
   div(
     tags$button(
       type="submit",
-      class="btn btn-primary shiny-submit-button",
-      style = css(width = validateCssUnit(width)),
+      class="btn btn-primary",
+      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
       list(icon, text)
     )
   )

R/input-text.R

@@ -10,14 +10,6 @@
 #' @param placeholder A character string giving the user a hint as to what can
 #'   be entered into the control. Internet Explorer 8 and 9 do not support this
 #'   option.
-#' @param ... Ignored, included to require named arguments and for future
-#'   feature expansion.
-#' @param updateOn A character vector specifying when the input should be
-#'   updated. Options are `"change"` (default) and `"blur"`. Use `"change"` to
-#'   update the input immediately whenever the value changes. Use `"blur"`to
-#'   delay the input update until the input loses focus (the user moves away
-#'   from the input), or when Enter is pressed (or Cmd/Ctrl + Enter for
-#'   [textAreaInput()]).
 #' @return A text input control that can be added to a UI definition.
 #'
 #' @family input elements
@@ -42,31 +34,15 @@
 #' unless `value` is provided.
 #'
 #' @export
-textInput <- function(
-  inputId,
-  label,
-  value = "",
-  width = NULL,
-  placeholder = NULL,
-  ...,
-  updateOn = c("change", "blur")
-) {
-  rlang::check_dots_empty()
-  updateOn <- rlang::arg_match(updateOn)
+textInput <- function(inputId, label, value = "", width = NULL,
+  placeholder = NULL) {
 
   value <- restoreInput(id = inputId, default = value)
 
-  div(
-    class = "form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+  div(class = "form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     shinyInputLabel(inputId, label),
-    tags$input(
-      id = inputId,
-      type = "text",
-      class = "shiny-input-text form-control",
-      value = value,
-      placeholder = placeholder,
-      `data-update-on` = updateOn
-    )
+    tags$input(id = inputId, type="text", class="form-control", value=value,
+      placeholder = placeholder)
   )
 }

R/input-textarea.R

@@ -16,8 +16,6 @@
 #' @param resize Which directions the textarea box can be resized. Can be one of
 #'   `"both"`, `"none"`, `"vertical"`, and `"horizontal"`. The default, `NULL`,
 #'   will use the client browser's default setting for resizing textareas.
-#' @param autoresize If `TRUE`, the textarea will automatically resize to fit
-#'   the input text.
 #' @return A textarea input control that can be added to a UI definition.
 #'
 #' @family input elements
@@ -43,22 +41,8 @@
 #' unless `value` is provided.
 #'
 #' @export
-textAreaInput <- function(
-  inputId,
-  label,
-  value = "",
-  width = NULL,
-  height = NULL,
-  cols = NULL,
-  rows = NULL,
-  placeholder = NULL,
-  resize = NULL,
-  ...,
-  autoresize = FALSE,
-  updateOn = c("change", "blur")
-) {
-  rlang::check_dots_empty()
-  updateOn <- rlang::arg_match(updateOn)
+textAreaInput <- function(inputId, label, value = "", width = NULL, height = NULL,
+  cols = NULL, rows = NULL, placeholder = NULL, resize = NULL) {
 
   value <- restoreInput(id = inputId, default = value)
 
@@ -66,30 +50,27 @@ textAreaInput <- function(
     resize <- match.arg(resize, c("both", "none", "vertical", "horizontal"))
   }
 
-  classes <- "form-control"
-  if (autoresize) {
-    classes <- c(classes, "textarea-autoresize")
-    if (is.null(rows)) {
-      rows <- 1
-    }
-  }
+  style <- paste(
+    # The width is specified on the parent div.
+    if (!is.null(width)) paste0("width: ",  "100%",  ";"),
+    if (!is.null(height)) paste0("height: ", validateCssUnit(height), ";"),
+    if (!is.null(resize)) paste0("resize: ", resize, ";")
+  )
 
-  div(
-    class = "shiny-input-textarea form-group shiny-input-container",
-    style = css(width = validateCssUnit(width)),
+  # 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 = classes,
+      class = "form-control",
       placeholder = placeholder,
-      style = css(
-        width = if (!is.null(width)) "100%",
-        height = validateCssUnit(height),
-        resize = resize
-      ),
+      style = style,
       rows = rows,
       cols = cols,
-      `data-update-on` = updateOn,
       value
     )
   )

R/input-utils.R

@@ -41,7 +41,7 @@ normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
     if (length(choiceNames) != length(choiceValues)) {
       stop("`choiceNames` and `choiceValues` must have the same length.")
     }
-    if (any_named(choiceNames) || any_named(choiceValues)) {
+    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
       stop("`choiceNames` and `choiceValues` must not be named.")
     }
   } else {

R/insert-tab.R

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

R/insert-ui.R

@@ -1,6 +1,6 @@
 #' Insert and remove UI objects
 #'
-#' These functions allow you to dynamically add and remove arbitrary UI
+#' These functions allow you to dynamically add and remove arbirary UI
 #' into your app, whenever you want, as many times as you want.
 #' Unlike [renderUI()], the UI generated with `insertUI()` is persistent:
 #' once it's created, it stays there until removed by `removeUI()`. Each
@@ -11,7 +11,7 @@
 #' function.
 #'
 #' It's particularly useful to pair `removeUI` with `insertUI()`, but there is
-#' no restriction on what you can use it on. Any element that can be selected
+#' no restriction on what you can use on. Any element that can be selected
 #' through a jQuery selector can be removed through this function.
 #'
 #' @param selector A string that is accepted by jQuery's selector

R/jqueryui.R

@@ -76,20 +76,16 @@ absolutePanel <- function(...,
 
   style <- paste(paste(names(cssProps), cssProps, sep = ':', collapse = ';'), ';', sep='')
   divTag <- tags$div(style=style, ...)
-
-  if (identical(draggable, FALSE)) {
+  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 {
     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
@@ -103,14 +99,3 @@ 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

@@ -4,7 +4,6 @@
 #' themselves in knitr/rmarkdown documents.
 #'
 #' @name knitr_methods
-#' @keywords internal
 #' @param x Object to knit_print
 #' @param ... Additional knit_print arguments
 NULL
@@ -26,7 +25,7 @@ shiny_rmd_warning <- function() {
 
 #' @rdname knitr_methods
 knit_print.shiny.appobj <- function(x, ...) {
-  opts <- x$options %||% list()
+  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
 
@@ -63,7 +62,7 @@ knit_print.shiny.appobj <- function(x, ...) {
 #' @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)
+  output <- knitr::knit_print(tagList(x))
   attr(output, "knit_cacheable") <- FALSE
   attr(output, "knit_meta") <- append(attr(output, "knit_meta"),
                                       shiny_rmd_warning())
@@ -77,5 +76,5 @@ knit_print.reactive <- function(x, ..., inline = FALSE) {
   renderFunc <- if (inline) renderText else renderPrint
   knitr::knit_print(renderFunc({
     x()
-  }), ..., inline = inline)
+  }), inline = inline)
 }

R/map.R

@@ -1,3 +1,19 @@
+# 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,
@@ -48,12 +64,9 @@ Map <- R6Class(
   )
 )
 
-#' @export
-as.list.Map <- function(x, ...) {
-  x$values()
+as.list.Map <- function(map) {
+  map$values()
 }
-
-#' @export
-length.Map <- function(x) {
-  x$size()
+length.Map <- function(map) {
+  map$size()
 }

R/middleware.R

@@ -309,7 +309,7 @@ HandlerManager <- R6Class("HandlerManager",
     createHttpuvApp = function() {
       list(
         onHeaders = function(req) {
-          maxSize <- getOption('shiny.maxRequestSize') %||% (5 * 1024 * 1024)
+          maxSize <- getOption('shiny.maxRequestSize') %OR% (5 * 1024 * 1024)
           if (maxSize <= 0)
             return(NULL)
 
@@ -346,9 +346,9 @@ HandlerManager <- R6Class("HandlerManager",
                 ),
                 catch = function(err) {
                   httpResponse(status = 500L,
-                    content_type = "text/html; charset=UTF-8",
+                    content_type = "text/html",
                     content = as.character(htmltools::htmlTemplate(
-                      system_file("template", "error.html", package = "shiny"),
+                      system.file("template", "error.html", package = "shiny"),
                       message = conditionMessage(err)
                     ))
                   )
@@ -426,7 +426,7 @@ HandlerManager <- R6Class("HandlerManager",
 )
 
 maybeInjectAutoreload <- function(resp) {
-  if (get_devmode_option("shiny.autoreload", FALSE) &&
+  if (getOption("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/main/tests/testthat/common.R
+#   https://github.com/rstudio/promises/blob/master/tests/testthat/common.R
 # Block until all pending later tasks have executed
 wait_for_it <- function() {
   while (!later::loop_empty()) {
@@ -9,6 +9,8 @@ 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
@@ -154,7 +156,6 @@ makeExtraMethods <- function() {
     "sendInsertUI",
     "sendModal",
     "setCurrentTheme",
-    "getCurrentTheme",
     "sendNotification",
     "sendProgress",
     "sendRemoveTab",
@@ -233,9 +234,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 object.
+    #' @field cache The session cache MemoryCache.
     cache = NULL,
-    #' @field appcache The app cache object.
+    #' @field appcache The app cache MemoryCache.
     appcache = NULL,
     #' @field restoreContext Part of bookmarking support in a real
     #'   `ShinySession` but always `NULL` for a `MockShinySession`.
@@ -259,7 +260,7 @@ MockShinySession <- R6Class(
       private$file_generators <- fastmap()
 
       private$timer <- MockableTimerCallbacks$new()
-      self$progressStack <- fastmap::faststack()
+      self$progressStack <- Stack$new()
 
       self$userData <- new.env(parent=emptyenv())
 
@@ -276,8 +277,8 @@ MockShinySession <- R6Class(
       # Copy app-level options
       self$options <- getCurrentAppState()$options
 
-      self$cache <- cachem::cache_mem()
-      self$appcache <- cachem::cache_mem()
+      self$cache <- MemoryCache$new()
+      self$appcache <- MemoryCache$new()
 
       # Adds various generated noop and error-producing method implementations.
       # Note that noop methods can be configured to produce warnings by setting
@@ -457,11 +458,6 @@ 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)
           })
       })
@@ -565,26 +561,10 @@ 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.
-    #' @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()
+    unhandledError = function(e) {
+      self$close()
     },
     #' @description Freeze a value until the flush cycle completes.
     #' @param x A `ReactiveValues` object.
@@ -641,9 +621,6 @@ 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

@@ -43,10 +43,7 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #' @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,
-#'   `"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()]).
+#'   or `"l"` for large.
 #' @param easyClose If `TRUE`, the modal dialog can be dismissed by
 #'   clicking outside the dialog box, or be pressing the Escape key. If
 #'   `FALSE` (the default), the modal dialog can't be dismissed in those
@@ -154,25 +151,18 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #' }
 #' @export
 modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
-  size = c("m", "s", "l", "xl"), easyClose = FALSE, fade = TRUE) {
+  size = c("m", "s", "l"), easyClose = FALSE, fade = TRUE) {
 
   size <- match.arg(size)
 
-  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,
+  cls <- if (fade) "modal fade" else "modal"
+  div(id = "shiny-modal", class = cls, tabindex = "-1",
+    `data-backdrop` = if (!easyClose) "static",
+    `data-keyboard` = if (!easyClose) "false",
 
     div(
       class = "modal-dialog",
-      class = switch(size, s = "modal-sm", m = NULL, l = "modal-lg", xl = "modal-xl"),
+      class = switch(size, s = "modal-sm", m = NULL, l = "modal-lg"),
       div(class = "modal-content",
         if (!is.null(title)) div(class = "modal-header",
           tags$h4(class = "modal-title", title)
@@ -181,26 +171,14 @@ modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
         if (!is.null(footer)) div(class = "modal-footer", footer)
       )
     ),
-    # 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();
-      }"
-    ))
+    tags$script("$('#shiny-modal').modal().focus();")
   )
 }
 
 #' @export
 #' @rdname modalDialog
 modalButton <- function(label, icon = NULL) {
-  tags$button(
-    type = "button",
-    class = "btn btn-default",
-    `data-dismiss` = "modal",
-    `data-bs-dismiss` = "modal",
-    validateIcon(icon), label
+  tags$button(type = "button", class = "btn btn-default",
+    `data-dismiss` = "modal", validateIcon(icon), label
   )
 }

R/modules.R

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

R/progress.R

@@ -76,10 +76,8 @@ 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))
-        rlang::abort("`session` is not a ShinySession object.")
+        stop("'session' is not a ShinySession object.")
 
       private$session <- session
       private$id <- createUniqueId(8)

R/react.R

@@ -5,7 +5,7 @@ processId <- local({
   cached <- NULL
   function() {
     if (is.null(cached)) {
-      cached <<- rlang::hash(list(
+      cached <<- digest::digest(list(
         Sys.info(),
         Sys.time()
       ))
@@ -53,12 +53,10 @@ Context <- R6Class(
 
       promises::with_promise_domain(reactivePromiseDomain(), {
         withReactiveDomain(.domain, {
-          captureStackTraces({
-            env <- .getReactiveEnvironment()
-            rLog$enter(.reactId, id, .reactType, .domain)
-            on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
-            env$runWith(self, func)
-          })
+          env <- .getReactiveEnvironment()
+          rLog$enter(.reactId, id, .reactType, .domain)
+          on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
+          env$runWith(self, func)
         })
       })
     },
@@ -67,7 +65,7 @@ Context <- R6Class(
         that have been registered with onInvalidate()."
 
       if (!identical(.pid, processId())) {
-        rlang::abort("Reactive context was created in one process and invalidated from another.")
+        stop("Reactive context was created in one process and invalidated from another")
       }
 
       if (.invalidated)
@@ -89,7 +87,7 @@ Context <- R6Class(
         immediately."
 
       if (!identical(.pid, processId())) {
-        rlang::abort("Reactive context was created in one process and accessed from another.")
+        stop("Reactive context was created in one process and accessed from another")
       }
 
       if (.invalidated)
@@ -142,13 +140,9 @@ ReactiveEnvironment <- R6Class(
         if (isTRUE(getOption('shiny.suppressMissingContextError'))) {
           return(getDummyContext())
         } else {
-          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.'
-            )
-          ))
+          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.)')
         }
       }
       return(.currentContext)
@@ -208,8 +202,7 @@ getCurrentContext <- function() {
   .getReactiveEnvironment()$currentContext()
 }
 hasCurrentContext <- function() {
-  !is.null(.getReactiveEnvironment()$.currentContext) ||
-    isTRUE(getOption("shiny.suppressMissingContextError"))
+  !is.null(.getReactiveEnvironment()$.currentContext)
 }
 
 getDummyContext <- function() {
@@ -221,11 +214,13 @@ getDummyContext <- function() {
 
 wrapForContext <- function(func, ctx) {
   force(func)
-  force(ctx) # may be NULL (in the case of maskReactiveContext())
+  force(ctx)
 
   function(...) {
-    .getReactiveEnvironment()$runWith(ctx, function() {
-      func(...)
+    ctx$run(function() {
+      captureStackTraces(
+        func(...)
+      )
     })
   }
 }
@@ -234,18 +229,12 @@ reactivePromiseDomain <- function() {
   promises::new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
-
-      # ctx will be NULL if we're in a maskReactiveContext()
-      ctx <- if (hasCurrentContext()) getCurrentContext() else NULL
-
+      ctx <- getCurrentContext()
       wrapForContext(onFulfilled, ctx)
     },
     wrapOnRejected = function(onRejected) {
       force(onRejected)
-
-      # ctx will be NULL if we're in a maskReactiveContext()
-      ctx <- if (hasCurrentContext()) getCurrentContext() else NULL
-
+      ctx <- getCurrentContext()
       wrapForContext(onRejected, ctx)
     }
   )

R/reactives.R

@@ -105,7 +105,9 @@ ReactiveVal <- R6Class(
       invisible(TRUE)
     },
     freeze = function(session = getDefaultReactiveDomain()) {
-      checkReactiveDomain(session)
+      if (is.null(session)) {
+        stop("Can't freeze a reactiveVal without a reactive domain")
+      }
       rLog$freezeReactiveVal(private$reactId, session)
       session$onFlushed(function() {
         self$thaw(session)
@@ -236,23 +238,17 @@ freezeReactiveVal <- function(x) {
   }
 
   domain <- getDefaultReactiveDomain()
-  checkReactiveDomain(domain)
-
+  if (is.null(domain)) {
+    stop("freezeReactiveVal() must be called when a default reactive domain is active.")
+  }
   if (!inherits(x, "reactiveVal")) {
-    rlang::abort("`x` must be a reactiveVal.")
+    stop("x must be a reactiveVal object")
   }
 
   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(...)
@@ -326,9 +322,6 @@ 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(
@@ -406,11 +399,6 @@ ReactiveValues <- R6Class(
         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
       .values$set(key, value)
 
@@ -452,13 +440,14 @@ ReactiveValues <- R6Class(
     },
 
     names = function() {
+      nameValues <- .values$keys()
       if (!isTRUE(.hasRetrieved$names)) {
         domain <- getDefaultReactiveDomain()
-        rLog$defineNames(.reactId, .nameOrder, .label, domain)
+        rLog$defineNames(.reactId, nameValues, .label, domain)
         .hasRetrieved$names <<- TRUE
       }
       .namesDeps$register()
-      return(.nameOrder)
+      return(nameValues)
     },
 
     # Get a metadata value. Does not trigger reactivity.
@@ -506,7 +495,7 @@ ReactiveValues <- R6Class(
     },
 
     toList = function(all.names=FALSE) {
-      listValue <- .values$mget(.nameOrder)
+      listValue <- .values$values()
       if (!all.names) {
         listValue <- listValue[!grepl("^\\.", base::names(listValue))]
       }
@@ -575,9 +564,9 @@ ReactiveValues <- R6Class(
 #' @seealso [isolate()] and [is.reactivevalues()].
 #' @export
 reactiveValues <- function(...) {
-  args <- list2(...)
+  args <- list(...)
   if ((length(args) > 0) && (is.null(names(args)) || any(names(args) == "")))
-    rlang::abort("All arguments passed to reactiveValues() must be named.")
+    stop("All arguments passed to reactiveValues() must be named.")
 
   values <- .createReactiveValues(ReactiveValues$new())
 
@@ -588,7 +577,7 @@ reactiveValues <- function(...) {
 
 checkName <- function(x) {
   if (!is.character(x) || length(x) != 1) {
-    rlang::abort("Must use single string to index into reactivevalues.")
+    stop("Must use single string to index into reactivevalues")
   }
 }
 
@@ -630,14 +619,6 @@ 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))
 }
 
@@ -647,7 +628,7 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 #' @export
 `$<-.reactivevalues` <- function(x, name, value) {
   if (.subset2(x, 'readonly')) {
-    rlang::abort(paste0("Can't modify read-only reactive value '", name, "'"))
+    stop("Attempted to assign value to a read-only reactivevalues object")
   }
   checkName(name)
   .subset2(x, 'impl')$set(.subset2(x, 'ns')(name), value)
@@ -659,12 +640,12 @@ is.reactivevalues <- function(x) inherits(x, 'reactivevalues')
 
 #' @export
 `[.reactivevalues` <- function(values, name) {
-  rlang::abort("Can't index reactivevalues with `[`.")
+  stop("Single-bracket indexing of reactivevalues object is not allowed.")
 }
 
 #' @export
 `[<-.reactivevalues` <- function(values, name, value) {
-  rlang::abort("Can't index reactivevalues with `[`.")
+  stop("Single-bracket indexing of reactivevalues object is not allowed.")
 }
 
 #' @export
@@ -680,15 +661,16 @@ names.reactivevalues <- function(x) {
 
 #' @export
 `names<-.reactivevalues` <- function(x, value) {
-  rlang::abort("Can't assign names to reactivevalues.")
+  stop("Can't assign names to reactivevalues object")
 }
 
 #' @export
 as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
-  shinyDeprecated(
-    "0.4.0", "as.list.reactivevalues()", "reactiveValuesToList()",
-    details = "Please see ?reactiveValuesToList for more information."
-  )
+  shinyDeprecated("reactiveValuesToList",
+    msg = paste("'as.list.reactivevalues' is deprecated. ",
+      "Use reactiveValuesToList instead.",
+      "\nPlease see ?reactiveValuesToList for more information.",
+      sep = ""))
 
   reactiveValuesToList(x, all.names)
 }
@@ -803,7 +785,9 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
 #' @export
 freezeReactiveValue <- function(x, name) {
   domain <- getDefaultReactiveDomain()
-  checkReactiveDomain(domain)
+  if (is.null(domain)) {
+    stop("freezeReactiveValue() must be called when a default reactive domain is active.")
+  }
 
   domain$freezeValue(x, name)
   invisible()
@@ -835,10 +819,9 @@ Observable <- R6Class(
                           domain = getDefaultReactiveDomain(),
                           ..stacktraceon = TRUE) {
       if (length(formals(func)) > 0)
-        rlang::abort(c(
-          "Can't make a reactive expression from a function that takes arguments.",
-          "Only functions without parameters can become reactive expressions."
-        ))
+        stop("Can't make a reactive expression from a function that takes one ",
+             "or more parameters; only functions without parameters can be ",
+             "reactive.")
 
       # This is to make sure that the function labels that show in the profiler
       # and in stack traces doesn't contain whitespace. See
@@ -882,7 +865,8 @@ Observable <- R6Class(
         invisible(.value)
     },
     format = function() {
-      simpleExprToFunction(fn_body(.origFunc), "reactive")
+      label <- sprintf('reactive(%s)', paste(deparse(body(.origFunc)), collapse='\n'))
+      strsplit(label, "\n")[[1]]
     },
     .updateValue = function() {
       ctx <- Context$new(.domain, .label, type = 'observable',
@@ -951,78 +935,53 @@ Observable <- R6Class(
 #' See the [Shiny tutorial](https://shiny.rstudio.com/tutorial/) for
 #' more information about reactive expressions.
 #'
-#' @param x For `is.reactive()`, an object to test. For `reactive()`, an
-#'   expression. When passing in a [`rlang::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 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 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
 #' })
-#' # View the values from the R console with isolate()
-#' isolate(reactiveB())
-#' # 2
+#'
+#' # Can use quoted expressions
+#' reactiveC <- reactive(quote({ values$A + 2 }), quoted = TRUE)
 #'
 #' # 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.
+#' expr_q <- quote({ values$A + 3 })
+#' reactiveD <- reactive(expr_q, quoted = TRUE)
+#'
+#' # View the values from the R console with isolate()
+#' isolate(reactiveB())
 #' 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
-) {
-  check_dots_empty()
-
-  func <- installExprFunction(x, "func", env, quoted, wrappedWithLabel = FALSE)
+reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
+                     domain = getDefaultReactiveDomain(),
+                     ..stacktraceon = TRUE) {
+  fun <- exprToFunction(x, env, quoted)
   # Attach a label and a reference to the original user source for debugging
-  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")
-  )
+  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"))
 }
 
 # Given the srcref to a reactive expression, attempts to figure out what the
@@ -1091,15 +1050,7 @@ execCount <- function(x) {
   else if (inherits(x, 'Observer'))
     return(x$.execCount)
   else
-    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
+    stop('Unexpected argument to execCount')
 }
 
 # Observer ------------------------------------------------------------------
@@ -1131,10 +1082,8 @@ Observer <- R6Class(
                           domain = getDefaultReactiveDomain(),
                           autoDestroy = TRUE, ..stacktraceon = TRUE) {
       if (length(formals(observerFunc)) > 0)
-        rlang::abort(c(
-          "Can't make an observer from a function that takes arguments.",
-          "Only functions without arguments can become observers."
-        ))
+        stop("Can't make an observer from a function that takes parameters; ",
+             "only functions without parameters can be reactive.")
       if (grepl("\\s", label, perl = TRUE)) {
         funcLabel <- "<observer>"
       } else {
@@ -1213,13 +1162,13 @@ Observer <- R6Class(
             # validation = function(e) NULL,
             # shiny.output.cancel = function(e) NULL
 
-            if (cnd_inherits(e, "shiny.silent.error")) {
+            if (inherits(e, "shiny.silent.error")) {
               return()
             }
 
             printError(e)
             if (!is.null(.domain)) {
-              .domain$unhandledError(e, close = TRUE)
+              .domain$unhandledError(e)
             }
           },
           finally = .domain$decrementBusyCount
@@ -1345,7 +1294,12 @@ Observer <- R6Class(
 #'
 #' @param x An expression (quoted or unquoted). Any return value will be
 #'   ignored.
-#' @inheritParams reactive
+#' @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 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.
@@ -1359,8 +1313,6 @@ 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{
@@ -1404,43 +1356,29 @@ Observer <- R6Class(
 #'   print(values$A + 1)
 #' })
 #'
-#' # To store expressions for later conversion to observe, use rlang::quo()
-#' myquo <- rlang::quo({ print(values$A + 3) })
-#' obsC <- rlang::inject(observe(!!myquo))
+#' # Can use quoted expressions
+#' obsC <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
 #'
-#' # (Legacy) Can use quoted expressions
-#' obsD <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
+#' # To store expressions for later conversion to observe, use quote()
+#' expr_q <- quote({ print(values$A + 3) })
+#' obsD <- observe(expr_q, 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)
-{
-  check_dots_empty()
+observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
+                    suspended=FALSE, priority=0,
+                    domain=getDefaultReactiveDomain(), autoDestroy = TRUE,
+                    ..stacktraceon = TRUE) {
 
-  func <- installExprFunction(x, "func", env, quoted)
-  label <- funcToLabel(func, "observe", label)
+  fun <- exprToFunction(x, env, quoted)
+  if (is.null(label))
+    label <- sprintf('observe(%s)', paste(deparse(body(fun)), collapse='\n'))
 
-  o <- Observer$new(
-    func,
-    label = label,
-    suspended = suspended,
-    priority = priority,
-    domain = domain,
-    autoDestroy = autoDestroy,
-    ..stacktraceon = ..stacktraceon
-  )
+  o <- Observer$new(fun, label=label, suspended=suspended, priority=priority,
+                    domain=domain, autoDestroy=autoDestroy,
+                    ..stacktraceon=..stacktraceon)
   invisible(o)
 }
 
@@ -1833,7 +1771,6 @@ 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
@@ -1841,7 +1778,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
     # firing and hold onto resources.
     if (re_finalized) {
       o$destroy()
-      rm(o, envir = env)
+      rm(o, envir = parent.env(environment()))
       return()
     }
 
@@ -1926,7 +1863,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' @export
 reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...) {
   filePath <- coerceToFunc(filePath)
-  extraArgs <- list2(...)
+  extraArgs <- list(...)
 
   reactivePoll(
     intervalMillis, session,
@@ -2045,11 +1982,7 @@ maskReactiveContext <- function(expr) {
 
 #' Event handler
 #'
-#' 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()]).
+#' Respond to "event-like" reactive inputs, values, and expressions.
 #'
 #' Shiny's reactive programming framework is primarily designed for calculated
 #' values (reactive expressions) and side-effect-causing actions (observers)
@@ -2071,17 +2004,13 @@ 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. Note that
-#' `observeEvent()` is equivalent to using `observe() %>% bindEvent()` and as of
-#' Shiny 1.6.0, we recommend the latter.
+#' function that should be called whenever the event occurs.
 #'
 #' 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. Note that
-#' `eventReactive()` is equivalent to using `reactive() %>% bindEvent()` and as of
-#' Shiny 1.6.0, we recommend the latter.
+#' in response to the given event.
 #'
 #' @section ignoreNULL and ignoreInit:
 #'
@@ -2115,7 +2044,6 @@ 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`}{
@@ -2155,30 +2083,23 @@ 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 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 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 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.
@@ -2190,8 +2111,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 event expression
-#'   is `NULL`. See Details.
+#'   calculated, in the case of `eventReactive`) when the input 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
@@ -2200,7 +2121,6 @@ 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
@@ -2209,7 +2129,7 @@ maskReactiveContext <- function(expr) {
 #' @seealso [actionButton()]
 #'
 #' @examples
-#' ## Only run examples in interactive R sessions
+#' ## Only run this example in interactive R sessions
 #' if (interactive()) {
 #'
 #'   ## App 1: Sample usage
@@ -2228,12 +2148,6 @@ 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, {
@@ -2253,12 +2167,6 @@ 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)
 #'     }
 #'   )
 #'
@@ -2285,36 +2193,42 @@ 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)
-{
-  check_dots_empty()
+  ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE) {
 
-  eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
-  handlerQ <- exprToQuo(handlerExpr, handler.env, handler.quoted)
+  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)
 
-  label <- quoToLabel(eventQ, "observeEvent", label)
+  handlerFunc <- exprToFunction(handlerExpr, handler.env, handler.quoted)
+  handlerFunc <- wrapFunctionLabel(handlerFunc, "observeEventHandler", ..stacktraceon = TRUE)
 
-  handler <- inject(observe(
-    !!handlerQ,
-    label = label,
-    suspended = suspended,
-    priority = priority,
-    domain = domain,
-    autoDestroy = TRUE,
-    ..stacktraceon = TRUE
-  ))
+  initialized <- FALSE
 
-  o <- inject(bindEvent(
-    ignoreNULL = ignoreNULL,
-    ignoreInit = ignoreInit,
-    once = once,
-    label = label,
-    !!eventQ,
-    x = handler
-  ))
+  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)
 
   invisible(o)
 }
@@ -2324,24 +2238,34 @@ 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)
-{
-  check_dots_empty()
+  ignoreNULL = TRUE, ignoreInit = FALSE) {
 
-  eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
-  valueQ <- exprToQuo(valueExpr, value.env, value.quoted)
+  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)
 
-  label <- quoToLabel(eventQ, "eventReactive", label)
+  handlerFunc <- exprToFunction(valueExpr, value.env, value.quoted)
+  handlerFunc <- wrapFunctionLabel(handlerFunc, "eventReactiveHandler", ..stacktraceon = TRUE)
 
-  invisible(inject(bindEvent(
-    ignoreNULL = ignoreNULL,
-    ignoreInit = ignoreInit,
-    label = label,
-    !!eventQ,
-    x = reactive(!!valueQ, domain = domain, label = 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))
 }
 
 isNullEvent <- function(value) {
@@ -2399,7 +2323,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 the time
+#' will invalidate regularly, at a rate equal to or slower than than the time
 #' window.
 #'
 #' `ooo-oo-oo---- => o--o--o--o---`
@@ -2482,11 +2406,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
-      try(r(), silent = TRUE)
+      r()
       return()
     }
     # This ensures r() is still tracked after firstRun
-    try(r(), silent = TRUE)
+    r()
 
     # The value (or possibly millis) changed. Start or reset the timer.
     v$when <- getDomainTimeMs(domain) + millis()
@@ -2501,7 +2425,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 %||% 0) %% 999999999 + 1
+      v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
       v$when <- NULL
     } else {
       invalidateLater(v$when - now)
@@ -2519,7 +2443,7 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
   # commenting it out and studying the unit test failure that results.
   primer <- observe({
     primer$destroy()
-    try(er(), silent = TRUE)
+    er()
   }, label = "debounce primer", domain = domain, priority = priority)
 
   er
@@ -2561,7 +2485,7 @@ throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
   }
 
   # Responsible for tracking when f() changes.
-  observeEvent(try(r(), silent = TRUE), {
+  observeEvent(r(), {
     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/documentation/updateReexports.R`: do not edit by hand
-# Please call `source('tools/documentation/updateReexports.R')` from the root folder to update`
+# Generated by `./tools/updateReexports.R`: do not edit by hand
+# Please call `source('tools/updateReexports.R') from the root folder to update`
 ####
 
 
@@ -90,20 +90,17 @@ 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
@@ -116,9 +113,6 @@ htmltools::tagHasAttribute
 #' @export
 htmltools::tagGetAttribute
 
-
-# htmltools tagAppendChild.Rd --------------------------------------------------
-
 #' @importFrom htmltools tagAppendChild
 #' @export
 htmltools::tagAppendChild

R/render-cached-plot.R

@@ -1,7 +1,6 @@
 #' Plot output with cached images
 #'
-#' 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()].
+#' Renders a reactive plot, with plot images cached to disk.
 #'
 #' `expr` is an expression that generates a plot, similar to that in
 #' `renderPlot`. Unlike with `renderPlot`, this expression does not
@@ -9,7 +8,7 @@
 #' changes.
 #'
 #' `cacheKeyExpr` is an expression which, when evaluated, returns an object
-#' which will be serialized and hashed using the [rlang::hash()]
+#' which will be serialized and hashed using the [digest::digest()]
 #' function to generate a string that will be used as a cache key. This key is
 #' used to identify the contents of the plot: if the cache key is the same as a
 #' previous time, it assumes that the plot is the same and can be retrieved from
@@ -33,7 +32,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
-#' [rlang::hash()] function.
+#' [digest::digest()] function.
 #'
 #' Internally, the result from `cacheKeyExpr` is combined with the name of
 #' the output (if you assign it to `output$plot1`, it will be combined
@@ -41,6 +40,95 @@
 #' 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
@@ -48,7 +136,6 @@
 #'
 #'
 #' @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.
@@ -59,13 +146,16 @@
 #'   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. 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()].
+#' @seealso See [renderPlot()] for the regular, non-cached version of
+#'   this function. For more about configuring caches, see
+#'   [memoryCache()] and [diskCache()].
 #'
 #'
 #' @examples
@@ -156,7 +246,7 @@
 #'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
 #'       },
 #'       cacheKeyExpr = { list(input$n) },
-#'       cache = cachem::cache_mem()
+#'       cache = memoryCache()
 #'     )
 #'     output$plot2 <- renderCachedPlot({
 #'         Sys.sleep(2)  # Add an artificial delay
@@ -165,7 +255,7 @@
 #'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
 #'       },
 #'       cacheKeyExpr = { list(input$n) },
-#'       cache = cachem::cache_mem()
+#'       cache = memoryCache()
 #'     )
 #'   }
 #' )
@@ -176,22 +266,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 = cachem::cache_mem(max_size = 20e6, max_age = 3600))
+#' shinyOptions(cache = memoryCache(max_size = 20e6, max_age = 3600))
 #'
 #' # At the top of app.R, this set the application-scoped cache to be a disk
 #' # cache that can be shared among multiple concurrent R processes, and is
 #' # deleted when the system reboots.
-#' shinyOptions(cache = cachem::cache_disk(file.path(dirname(tempdir()), "myapp-cache")))
+#' shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
 #'
 #' # At the top of app.R, this set the application-scoped cache to be a disk
 #' # cache that can be shared among multiple concurrent R processes, and
 #' # persists on disk across reboots.
-#' shinyOptions(cache = cachem::cache_disk("./myapp-cache"))
+#' shinyOptions(cache = diskCache("./myapp-cache"))
 #'
 #' # At the top of the server function, this set the session-scoped cache to be
 #' # a memory cache that is 5 MB in size.
 #' server <- function(input, output, session) {
-#'   shinyOptions(cache = cachem::cache_mem(max_size = 5e6))
+#'   shinyOptions(cache = memoryCache(max_size = 5e6))
 #'
 #'   output$plot <- renderCachedPlot(
 #'     ...,
@@ -213,29 +303,275 @@ renderCachedPlot <- function(expr,
   height = NULL
 ) {
 
-  expr <- substitute(expr)
-  if (!is_quosure(expr)) {
-    expr <- new_quosure(expr, env = parent.frame())
-  }
+  # 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())
 
-  cacheKeyExpr <- substitute(cacheKeyExpr)
-  if (!is_quosure(cacheKeyExpr)) {
-    cacheKeyExpr <- new_quosure(cacheKeyExpr, env = parent.frame())
-  }
+  args <- list(...)
 
   if (!is.null(width) || !is.null(height)) {
     warning("Unused argument(s) 'width' and/or 'height'. ",
             "'sizePolicy' is used instead.")
   }
 
-  inject(
-    bindCache(
-      renderPlot(!!expr, res = res, alt = alt, outputArgs = outputArgs, ...),
-      !!cacheKeyExpr,
-      sizePolicy = sizePolicy,
-      cache = cache
+  cacheKeyExpr <- substitute(cacheKeyExpr)
+  # The real cache key we'll use also includes width, height, res, pixelratio.
+  # This is just the part supplied by the user.
+  userCacheKey <- reactive(cacheKeyExpr, env = parent.frame(), quoted = TRUE, label = "userCacheKey")
+
+  ensureCacheSetup <- function() {
+    # For our purposes, cache objects must support these methods.
+    isCacheObject <- function(x) {
+      # Use tryCatch in case the object does not support `$`.
+      tryCatch(
+        is.function(x$get) && is.function(x$set),
+        error = function(e) FALSE
+      )
+    }
+
+    if (isCacheObject(cache)) {
+      # If `cache` is already a cache object, do nothing
+      return()
+
+    } else if (identical(cache, "app")) {
+      cache <<- getShinyOption("cache")
+
+    } else if (identical(cache, "session")) {
+      cache <<- session$cache
+
+    } else {
+      stop('`cache` must either be "app", "session", or a cache object with methods, `$get`, and `$set`.')
+    }
+  }
+
+  # The width and height of the plot to draw, given from sizePolicy. These
+  # values get filled by an observer below.
+  fitDims <- reactiveValues(width = NULL, height = NULL)
+
+  # Make sure alt param to be reactive function
+  if (is.reactive(alt))
+    altWrapper <- alt
+  else if (is.function(alt))
+    altWrapper <- reactive({ alt() })
+  else
+    altWrapper <- function() { alt }
+
+  resizeObserver <- NULL
+  ensureResizeObserver <- function() {
+    if (!is.null(resizeObserver))
+      return()
+
+    # Given the actual width/height of the image in the browser, this gets the
+    # width/height from sizePolicy() and pushes those values into `fitDims`.
+    # It's done this way so that the `fitDims` only change (and cause
+    # invalidations) when the rendered image size changes, and not every time
+    # the browser's <img> tag changes size.
+    doResizeCheck <- function() {
+      width  <- session$clientData[[paste0('output_', outputName, '_width')]]
+      height <- session$clientData[[paste0('output_', outputName, '_height')]]
+
+      if (is.null(width)) width <- 0
+      if (is.null(height)) height <- 0
+
+      rect <- sizePolicy(c(width, height))
+      fitDims$width  <- rect[1]
+      fitDims$height <- rect[2]
+    }
+
+    # Run it once immediately, then set up the observer
+    isolate(doResizeCheck())
+
+    resizeObserver <<- observe(doResizeCheck())
+  }
+
+  # Vars to store session and output, so that they can be accessed from
+  # the plotObj() reactive.
+  session <- NULL
+  outputName <- NULL
+
+
+  drawReactive <- reactive(label = "plotObj", {
+    hybrid_chain(
+      # Depend on the user cache key, even though we don't use the value. When
+      # it changes, it can cause the drawReactive to re-execute. (Though
+      # drawReactive will not necessarily re-execute --- it must be called from
+      # renderFunc, which happens only if there's a cache miss.)
+      userCacheKey(),
+      function(userCacheKeyValue) {
+        # Get width/height, but don't depend on them.
+        isolate({
+          width  <- fitDims$width
+          height <- fitDims$height
+          # Make sure alt text to be reactive function
+          alt <- altWrapper()
+        })
+
+        pixelratio <- session$clientData$pixelratio %OR% 1
+
+        do.call("drawPlot", c(
+          list(
+            name = outputName,
+            session = session,
+            func = isolatedFunc,
+            width = width,
+            height = height,
+            alt = alt,
+            pixelratio = pixelratio,
+            res = res
+          ),
+          args
+        ))
+      },
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        fitDims$width
+        fitDims$height
+
+        # Propagate the error
+        stop(reason)
+      }
     )
-  )
+  })
+
+
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned.
+  renderFunc <- function(shinysession, name, ...) {
+    outputName <<- name
+    session <<- shinysession
+    ensureCacheSetup()
+    ensureResizeObserver()
+
+    hybrid_chain(
+      # This use of the userCacheKey() sets up the reactive dependency that
+      # causes plot re-draw events. These may involve pulling from the cache,
+      # replaying a display list, or re-executing user code.
+      userCacheKey(),
+      function(userCacheKeyResult) {
+        width  <- fitDims$width
+        height <- fitDims$height
+        alt <- altWrapper()
+        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,
+            alt = alt,
+            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,
+              alt = alt,
+              pixelratio = pixelratio
+            )
+          }
+        )
+      },
+      function(possiblyAsyncResult) {
+        hybrid_chain(possiblyAsyncResult, function(result) {
+          width      <- result$width
+          height     <- result$height
+          alt        <- result$alt
+          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,
+                alt,
+                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,19 +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 [plotPNG()]. Note that this affects the resolution of PNG
+#'   passed to [grDevices::png()]. Note that this affects the resolution of PNG
 #'   rendering in R; it won't change the actual ppi of the browser.
-#' @param 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()].
+#' @param alt Alternate text for the HTML `<img>` tag
+#'   if it cannot be displayed or viewed (i.e., the user uses a screen reader).
+#'   In addition to a character string, the value may be a reactive expression
+#'   (or a function referencing reactive values) that returns a character string.
+#'   NULL or "" is not recommended because those should be limited to decorative images
+#'   (the default is "Plot object").
+#' @param ... Arguments to be passed through to [grDevices::png()].
 #'   These can be used to set the width, height, background color, etc.
-#' @inheritParams renderUI
+#' @param env The environment in which to evaluate `expr`.
+#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
+#'   is useful if you want to save an expression in a variable.
 #' @param execOnResize If `FALSE` (the default), then when a plot is
 #'   resized, Shiny will *replay* the plot drawing commands with
 #'   [grDevices::replayPlot()] instead of re-executing `expr`.
@@ -58,18 +58,13 @@
 #'   interactive R Markdown document.
 #' @export
 renderPlot <- function(expr, width = 'auto', height = 'auto', res = 72, ...,
-                       alt = NA,
+                       alt = "Plot object",
                        env = parent.frame(), quoted = FALSE,
                        execOnResize = FALSE, outputArgs = list()
 ) {
-
-  func <- installExprFunction(
-    expr, "func", env, quoted,
-    label = "renderPlot",
-    # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
-    # is called
-    ..stacktraceon = TRUE
-  )
+  # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
+  # is called
+  installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
 
   args <- list(...)
 
@@ -94,9 +89,7 @@ renderPlot <- function(expr, width = 'auto', height = 'auto', res = 72, ...,
   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() {
+  getDims <- function() {
     width <- widthWrapper()
     height <- heightWrapper()
 
@@ -115,7 +108,6 @@ 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
@@ -126,7 +118,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 %||% 1
+        pixelratio <- session$clientData$pixelratio %OR% 1
         do.call("drawPlot", c(
           list(
             name = outputName,
@@ -153,19 +145,15 @@ 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.
-  # 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) {
-
+  renderFunc <- function(shinysession, name, ...) {
     outputName <<- name
     session <<- shinysession
-    if (is.null(getDims)) getDims <<- get_dims
 
     hybrid_chain(
       drawReactive(),
       function(result) {
         dims <- getDims()
-        pixelratio <- session$clientData$pixelratio %||% 1
+        pixelratio <- session$clientData$pixelratio %OR% 1
         result <- do.call("resizeSavedPlot", c(
           list(name, shinysession, result, dims$width, dims$height, altWrapper(), pixelratio, res),
           args
@@ -183,19 +171,12 @@ renderPlot <- function(expr, width = 'auto', height = 'auto', res = 72, ...,
   outputFunc <- plotOutput
   if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)
 
-  markedFunc <- markRenderFunction(
-    outputFunc,
-    renderFunc,
-    outputArgs,
-    cacheHint = list(userExpr = installedFuncExpr(func), res = res)
-  )
-  class(markedFunc) <- c("shiny.renderPlot", class(markedFunc))
-  markedFunc
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
 }
 
 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)) {
+  if (result$img$width == width && result$img$height == height &&
+      result$pixelratio == pixelratio && result$res == res) {
     return(result)
   }
 
@@ -215,7 +196,7 @@ resizeSavedPlot <- function(name, session, result, width, height, alt, pixelrati
     src = session$fileUrl(name, outfile, contentType = "image/png"),
     width = width,
     height = height,
-    alt = result$alt,
+    alt = alt,
     coordmap = coordmap,
     error = attr(coordmap, "error", exact = TRUE)
   )
@@ -256,9 +237,8 @@ drawPlot <- function(name, session, func, width, height, alt, pixelratio, res, .
       promises::with_promise_domain(domain, {
         hybrid_chain(
           func(),
-          function(value) {
-            res <- withVisible(value)
-            if (res$visible) {
+          function(value, .visible) {
+            if (.visible) {
               # A modified version of print.ggplot which returns the built ggplot object
               # as well as the gtable grob. This overrides the ggplot::print.ggplot
               # method, but only within the context of renderPlot. The reason this needs
@@ -266,8 +246,6 @@ drawPlot <- function(name, session, func, width, height, alt, pixelratio, res, .
               # addition to ggplot, and there's a print method for that class, that we
               # won't override that method. https://github.com/rstudio/shiny/issues/841
               print.ggplot <- custom_print.ggplot
-              # For compatibility with ggplot2 >v4.0.0
-              `print.ggplot2::ggplot` <- custom_print.ggplot
 
               # Use capture.output to squelch printing to the actual console; we
               # are only interested in plot output
@@ -278,7 +256,7 @@ drawPlot <- function(name, session, func, width, height, alt, 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(res$value))
+                result <- ..stacktraceon..(print(value))
                 # TODO jcheng 2017-04-11: Verify above ..stacktraceon..
               })
               result
@@ -293,7 +271,6 @@ drawPlot <- function(name, session, func, width, height, alt, 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
             )
           }
@@ -308,10 +285,10 @@ drawPlot <- function(name, session, func, width, height, alt, 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,
+        alt = alt,
         coordmap = result$coordmap,
         # Get coordmap error message if present
         error = attr(result$coordmap, "error", exact = TRUE)
@@ -345,24 +322,6 @@ 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)
@@ -614,7 +573,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 <- get_package_version("ggplot2")
+  ggplot_ver <- utils::packageVersion("ggplot2")
 
   if (ggplot_ver > "2.2.1") {
     find_panel_info_api(b)
@@ -634,10 +593,6 @@ 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.
@@ -654,8 +609,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) %NA_OR% coord$xlog %NA_OR% NULL,
-      y = get_log_base(yscale$trans) %NA_OR% coord$ylog %NA_OR% NULL
+      x = get_log_base(xscale$trans) %OR% coord$xlog %OR% NULL,
+      y = get_log_base(yscale$trans) %OR% coord$ylog %OR% NULL
     )
   }
 

R/render-table.R

@@ -1,12 +1,10 @@
 #' Table Output
 #'
-#' @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()].
+#' Creates a reactive table that is suitable for assigning to an `output`
+#' slot.
 #'
-#' See [renderDataTable()] for data frames that are too big to fit on a single
-#' page.
+#' The corresponding HTML output tag should be `div` and have the CSS
+#' class name `shiny-html-output`.
 #'
 #' @param expr An expression that returns an R object that can be used with
 #'   [xtable::xtable()].
@@ -42,37 +40,21 @@
 #'   (i.e. they either evaluate to `NA` or `NaN`).
 #' @param ... Arguments to be passed through to [xtable::xtable()]
 #'   and [xtable::print.xtable()].
-#' @inheritParams renderUI
+#' @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 [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())
-{
-  func <- installExprFunction(expr, "func", env, quoted, label = "renderTable")
+                        outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
   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/main.tar.gz')
+#'   runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
 #'
 #'   # Can run an app from a subdirectory in the archive
-#'   runUrl("https://github.com/rstudio/shiny_example/archive/main.zip",
+#'   runUrl("https://github.com/rstudio/shiny_example/archive/master.zip",
 #'     subdir = "inst/shinyapp/")
 #' }
 runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
@@ -121,8 +121,7 @@ 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 `"HEAD"`, which means the default branch on GitHub, typically
-#'   `"main"` or `"master"`.
+#'   Defaults to `"master"`.
 #' @export
 #' @examples
 #' ## Only run this example in interactive R sessions
@@ -134,7 +133,7 @@ runGist <- function(gist, destdir = NULL, ...) {
 #'   runGitHub("shiny_example", "rstudio", subdir = "inst/shinyapp/")
 #' }
 runGitHub <- function(repo, username = getOption("github.user"),
-                      ref = "HEAD", subdir = NULL, destdir = NULL, ...) {
+                      ref = "master", subdir = NULL, destdir = NULL, ...) {
 
   if (grepl('/', repo)) {
     res <- strsplit(repo, '/')[[1]]

R/runapp.R

@@ -22,13 +22,10 @@
 #' @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.
+#'   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. The value of this parameter can also be a
+#'   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
@@ -86,7 +83,8 @@
 #' @export
 runApp <- function(appDir=getwd(),
                    port=getOption('shiny.port'),
-                   launch.browser = getOption('shiny.launch.browser', interactive()),
+                   launch.browser=getOption('shiny.launch.browser',
+                                            interactive()),
                    host=getOption('shiny.host', '127.0.0.1'),
                    workerId="", quiet=FALSE,
                    display.mode=c("auto", "normal", "showcase"),
@@ -144,8 +142,8 @@ runApp <- function(appDir=getwd(),
   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))
+  if (is.null(getShinyOption("cache"))) {
+    shinyOptions(cache = MemoryCache$new())
   }
 
   # Extract appOptions (which is a list) and store them as shinyOptions, for
@@ -304,8 +302,7 @@ runApp <- function(appDir=getwd(),
           # 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)) {
+          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
             break
           }
         }
@@ -445,20 +442,8 @@ stopApp <- function(returnValue = invisible()) {
 #' @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
-#'   `"auto"`, which uses the value of `DisplayMode` in the example's
-#'   `DESCRIPTION` file. Set to `"showcase"` to show the app code and
-#'   description with the running app, or `"normal"` to see the example without
+#'   `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
@@ -474,46 +459,33 @@ stopApp <- function(returnValue = invisible()) {
 #'   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
-  )
-
+runExample <- function(example=NA,
+                       port=getOption("shiny.port"),
+                       launch.browser=getOption('shiny.launch.browser',
+                                                interactive()),
+                       host=getOption('shiny.host', '127.0.0.1'),
+                       display.mode=c("auto", "normal", "showcase")) {
+  examplesDir <- system.file('examples', package='shiny')
   dir <- resolve(examplesDir, example)
-
   if (is.null(dir)) {
-    valid_examples <- sprintf(
-      'Valid examples in {%s}: "%s"',
-      package,
-      paste(list.files(examplesDir), collapse = '", "')
-    )
-
     if (is.na(example)) {
-      message(valid_examples)
-      return(invisible())
+      errFun <- message
+      errMsg <- ''
+    }
+    else {
+      errFun <- stop
+      errMsg <- paste('Example', example, 'does not exist. ')
     }
 
-    stop("Example '", example, "' does not exist. ", valid_examples)
+    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)
   }
-
-  runApp(dir, port = port, host = host, launch.browser = launch.browser,
-         display.mode = display.mode)
 }
 
 #' Run a gadget

R/serializers.R

@@ -5,6 +5,7 @@
 #'   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,9 +1,5 @@
-# Create a Map object for input handlers and register the defaults.
-# This is assigned in .onLoad time.
-inputHandlers <- NULL
-on_load({
-  inputHandlers <- Map$new()
-})
+# Create a map for input handlers and register the defaults.
+inputHandlers <- Map$new()
 
 #' Register an Input Handler
 #'
@@ -45,12 +41,12 @@ on_load({
 #' })
 #'
 #' ## 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()] [applyInputHandlers()]
+#' @seealso [removeInputHandler()]
 #' @export
 registerInputHandler <- function(type, fun, force=FALSE){
   if (inputHandlers$containsKey(type) && !force){
@@ -129,117 +125,115 @@ 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))
 
-    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)
-  })
+# 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))
 
-
-  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)
     })
-    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)
-    }
-  })
-
+  })), nrow = length(data[[1]]), ncol = length(data))
+  return(m)
+})
+
+
+registerInputHandler("shiny.number", function(val, ...){
+  ifelse(is.null(val), NA, val)
+})
+
+registerInputHandler("shiny.password", function(val, shinysession, name) {
+  # Mark passwords as not serializable
+  setSerializer(name, serializerUnserializable)
+  val
+})
+
+registerInputHandler("shiny.date", function(val, ...){
+  # First replace NULLs with NA, then convert to Date vector
+  datelist <- ifelse(lapply(val, is.null), NA, val)
+
+  res <- NULL
+  tryCatch({
+      res <- as.Date(unlist(datelist))
+    },
+    error = function(e) {
+      # It's possible for client to send a string like "99999-01-01", which
+      # as.Date can't handle.
+      warning(e$message)
+      res <<- as.Date(rep(NA, length(datelist)))
+    }
+  )
+
+  res
+})
+
+registerInputHandler("shiny.datetime", function(val, ...){
+  # First replace NULLs with NA, then convert to POSIXct vector
+  times <- lapply(val, function(x) {
+    if (is.null(x)) NA
+    else x
+  })
+  as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
+})
+
+registerInputHandler("shiny.action", function(val, shinysession, name) {
+  # mark up the action button value with a special class so we can recognize it later
+  class(val) <- c(class(val), "shinyActionButtonValue")
+  val
+})
+
+registerInputHandler("shiny.file", function(val, shinysession, name) {
+  # This function is only used when restoring a Shiny fileInput. When a file is
+  # uploaded the usual way, it takes a different code path and won't hit this
+  # function.
+  if (is.null(val))
+    return(NULL)
+
+  # The data will be a named list of lists; convert to a data frame.
+  val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
+
+  # `val$datapath` should be a filename without a path, for security reasons.
+  if (basename(val$datapath) != val$datapath) {
+    stop("Invalid '/' found in file input path.")
+  }
+
+  # Prepend the persistent dir
+  oldfile <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+
+  # Copy the original file to a new temp dir, so that a restored session can't
+  # modify the original.
+  newdir <- file.path(tempdir(), createUniqueId(12))
+  dir.create(newdir)
+  val$datapath <- file.path(newdir, val$datapath)
+  file.copy(oldfile, val$datapath)
+
+  # Need to mark this input value with the correct serializer. When a file is
+  # uploaded the usual way (instead of being restored), this occurs in
+  # session$`@uploadEnd`.
+  setSerializer(name, serializerFileInput)
+
+  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
+
+  val
+})
+
+
+# to be used with !!!answer
+registerInputHandler("shiny.symbolList", function(val, ...) {
+  if (is.null(val)) {
+    list()
+  } else {
+    lapply(val, as.symbol)
+  }
+})
+# to be used with !!answer
+registerInputHandler("shiny.symbol", function(val, ...) {
+  if (is.null(val) || identical(val, "")) {
+    NULL
+  } else {
+    as.symbol(val)
+  }
 })

R/server-resource-paths.R

@@ -80,7 +80,7 @@ addResourcePath <- function(prefix, directoryPath) {
 
   # If a shiny app is currently running, dynamically register this path with
   # the corresponding httpuv server object.
-  if (!is.null(getShinyOption("server", default = NULL)))
+  if (!is.null(getShinyOption("server")))
   {
     getShinyOption("server")$setStaticPath(.list = stats::setNames(normalizedPath, prefix))
   }

R/server.R

@@ -1,12 +1,7 @@
 #' @include server-input-handlers.R
 
-appsByToken <- NULL
-appsNeedingFlush <- NULL
-on_load({
-  appsByToken <- Map$new()
-  appsNeedingFlush <- Map$new()
-})
-
+appsByToken <- Map$new()
+appsNeedingFlush <- Map$new()
 
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
@@ -34,9 +29,7 @@ registerClient <- function(client) {
 
 #' Define Server Functionality
 #'
-#' @description `r lifecycle::badge("superseded")`
-#'
-#' @description Defines the server-side logic of the Shiny application. This generally
+#' 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.
@@ -54,7 +47,7 @@ registerClient <- function(client) {
 #' optional `session` parameter, which is used when greater control is
 #' needed.
 #'
-#' See the [tutorial](https://shiny.rstudio.com/tutorial/) for more
+#' See the [tutorial](http://rstudio.github.com/shiny/tutorial/) for more
 #' on how to write a server function.
 #'
 #' @param func The server function for this application. See the details section
@@ -83,17 +76,6 @@ registerClient <- function(client) {
 #' @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)
 }
@@ -127,16 +109,13 @@ decodeMessage <- function(data) {
   return(mainMessage)
 }
 
-autoReloadCallbacks <- NULL
-on_load({
-  autoReloadCallbacks <- Callbacks$new()
-})
+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
@@ -158,7 +137,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       }
 
       if (identical(ws$request$PATH_INFO, "/autoreload/")) {
-        if (!get_devmode_option("shiny.autoreload", FALSE)) {
+        if (!getOption("shiny.autoreload", FALSE)) {
           ws$close()
           return(TRUE)
         }
@@ -339,7 +318,7 @@ argsForServerFunc <- function(serverFunc, session) {
 getEffectiveBody <- function(func) {
   if (is.null(func))
     NULL
-  else if (isS4(func) && inherits(func, "functionWithTrace"))
+  else if (isS4(func) && class(func) == "functionWithTrace")
     body(func@original)
   else
     body(func)
@@ -393,7 +372,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
   )

R/shiny-options.R

@@ -65,20 +65,16 @@ getShinyOption <- function(name, default = NULL) {
 #'   changes are detected, all connected Shiny sessions are reloaded. This
 #'   allows for fast feedback loops when tweaking Shiny UI.
 #'
-#'   Monitoring for changes is no longer expensive, thanks to the \pkg{watcher}
-#'   package, but this feature is still intended only for development.
+#'   Since monitoring for changes is expensive (we simply poll for last
+#'   modified times), this feature is intended only for development.
 #'
 #'   You can customize the file patterns Shiny will monitor by setting the
-#'   shiny.autoreload.pattern option. For example, to monitor only `ui.R`:
-#'   `options(shiny.autoreload.pattern = glob2rx("ui.R"))`. 
+#'   shiny.autoreload.pattern option. For example, to monitor only ui.R:
+#'   `options(shiny.autoreload.pattern = glob2rx("ui.R"))`
 #'
-#'   As mentioned above, Shiny no longer polls watched files for changes.
-#'   Instead, using \pkg{watcher}, Shiny is notified of file changes as they
-#'   occur. These changes are batched together within a customizable latency
-#'   period. You can adjust this period by setting
-#'   `options(shiny.autoreload.interval = 2000)` (in milliseconds). This value
-#'   converted to seconds and passed to the `latency` argument of
-#'   [watcher::watcher()]. The default latency is 250ms.}
+#'   The default polling interval is 500 milliseconds. You can change this
+#'   by setting e.g. `options(shiny.autoreload.interval = 2000)` (every
+#'   two seconds).}
 #' \item{shiny.deprecation.messages (defaults to `TRUE`)}{This controls whether messages for
 #'   deprecated functions in Shiny will be printed. See
 #'   [shinyDeprecated()] for more information.}
@@ -92,17 +88,12 @@ 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 `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.}
+#' 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.}
 #' \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
@@ -117,7 +108,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 stack trace printed
+#'   generic error message is printed instead (the error and strack trace printed
 #'   to the console remain unchanged). If you want to sanitize errors in general, but you DO want a
 #'   particular error `e` to get displayed to the user, then set this option
 #'   to `TRUE` and use `stop(safeError(e))` for errors you want the
@@ -134,9 +125,6 @@ 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),
@@ -145,21 +133,9 @@ getShinyOption <- function(name, default = NULL) {
 #'   messages).}
 #' \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')
-### start shiny.client_devmode is primarily for niche, internal shinylive usage
-# ' \item{shiny.client_devmode (defaults to `FALSE`)}{If `TRUE`, enables client-
-# '  side devmode features. Currently the primary feature is the client-side
-# '  error console.}
-### end shiny.client_devmode
+#' \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.}
 #' }
 #'
 #'
@@ -189,14 +165,13 @@ getShinyOption <- function(name, default = NULL) {
 #'   `shinyOptions()`.
 #'
 #'   \describe{ \item{cache}{A caching object that will be used by
-#'   [renderCachedPlot()]. If not specified, a [cachem::cache_mem()] will be
-#'   used.} }
+#'   [renderCachedPlot()]. If not specified, a [memoryCache()] will be used.} }
 #'
 #' @param ... Options to set, with the form `name = value`.
 #' @aliases shiny-options
 #' @export
 shinyOptions <- function(...) {
-  newOpts <- list2(...)
+  newOpts <- list(...)
 
   if (length(newOpts) > 0) {
     # If we're within a session, modify at the session level.

R/shiny-package.R

@@ -1,43 +0,0 @@
-# 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/shiny.R

@@ -1,4 +1,4 @@
-#' @include utils.R
+#' @include utils.R stack.R
 NULL
 
 #' Web Application Framework for R
@@ -8,7 +8,7 @@ NULL
 #' prebuilt widgets make it possible to build beautiful, responsive, and
 #' powerful applications with minimal effort.
 #'
-#' The Shiny tutorial at <https://shiny.rstudio.com/tutorial/> explains
+#' The Shiny tutorial at <http://shiny.rstudio.com/tutorial/> explains
 #' the framework in depth, walks you through building a simple application, and
 #' includes extensive annotated examples.
 #'
@@ -16,7 +16,17 @@ NULL
 #'
 #' @name shiny-package
 #' @aliases shiny
-"_PACKAGE"
+#' @docType package
+#' @import htmltools httpuv xtable digest R6 mime
+NULL
+
+# It's necessary to Depend on methods so Rscript doesn't fail. It's necessary
+# to import(methods) in NAMESPACE so R CMD check doesn't complain. This
+# approach isn't foolproof because Rscript -e pkgname::func() doesn't actually
+# cause methods to be attached, but it's not a problem for shiny::runApp()
+# since we call require(shiny) as part of loading the app.
+#' @import methods
+NULL
 
 createUniqueId <- function(bytes, prefix = "", suffix = "") {
   withPrivateSeed({
@@ -32,12 +42,8 @@ createUniqueId <- function(bytes, prefix = "", suffix = "") {
 }
 
 toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
-  auto_unbox = TRUE,
-  # Shiny has had a legacy value of 16 significant digits
-  # We can use `I(16)` mixed with the default behavior in jsonlite's `use_signif=`
-  # https://github.com/jeroen/jsonlite/commit/728efa9
-  digits = getOption("shiny.json.digits", I(16)), use_signif = is(digits, "AsIs"),
-  force = TRUE, POSIXt = "ISO8601", UTC = TRUE,
+  auto_unbox = TRUE, digits = getOption("shiny.json.digits", 16),
+  use_signif = TRUE, force = TRUE, POSIXt = "ISO8601", UTC = TRUE,
   rownames = FALSE, keep_vec_names = TRUE, strict_atomic = TRUE) {
 
   if (strict_atomic) {
@@ -188,24 +194,14 @@ workerId <- local({
 #'   session is actually connected.
 #' }
 #' \item{request}{
-#'   An environment that implements the [Rook
-#'   specification](https://github.com/jeffreyhorner/Rook#the-environment) for
-#'   HTTP requests. This is the request that was used to initiate the websocket
-#'   connection (as opposed to the request that downloaded the web page for the
-#'   app).
+#'   An environment that implements the Rook specification for HTTP requests.
+#'   This is the request that was used to initiate the websocket connection
+#'   (as opposed to the request that downloaded the web page for the app).
 #' }
 #' \item{userData}{
 #'   An environment for app authors and module/package authors to store whatever
 #'   session-specific data they want.
 #' }
-#' \item{user}{
-#'   User's log-in information. Useful for identifying users on hosted platforms
-#'   such as RStudio Connect and Shiny Server.
-#' }
-#' \item{groups}{
-#'   The `user`'s relevant group information. Useful for determining what
-#'   privileges the user should or shouldn't have.
-#' }
 #' \item{resetBrush(brushId)}{
 #'   Resets/clears the brush with the given `brushId`, if it exists on
 #'   any `imageOutput` or `plotOutput` in the app.
@@ -214,7 +210,7 @@ workerId <- local({
 #'   Sends a custom message to the web page. `type` must be a
 #'   single-element character vector giving the type of message, while
 #'   `message` can be any jsonlite-encodable value. Custom messages
-#'   have no meaning to Shiny itself; they are used solely to convey information
+#'   have no meaning to Shiny itself; they are used soley to convey information
 #'   to custom JavaScript logic in the browser. You can do this by adding
 #'   JavaScript code to the browser that calls
 #'   \code{Shiny.addCustomMessageHandler(type, function(message){...})}
@@ -273,18 +269,6 @@ workerId <- local({
 #'   character vector, as in `input=c("x", "y")`. The format can be
 #'   "rds" or "json".
 #' }
-#' \item{setCurrentTheme(theme)}{
-#'   Sets the current [bootstrapLib()] theme, which updates the value of
-#'   [getCurrentTheme()], invalidates `session$getCurrentTheme()`, and calls
-#'   function(s) registered with [registerThemeDependency()] with provided
-#'   `theme`. If those function calls return [htmltools::htmlDependency()]s with
-#'   `stylesheet`s, then those stylesheets are "refreshed" (i.e., the new
-#'   stylesheets are inserted on the page and the old ones are disabled and
-#'   removed).
-#' }
-#' \item{getCurrentTheme()}{
-#'   A reactive read of the current [bootstrapLib()] theme.
-#' }
 #'
 #' @name session
 NULL
@@ -293,7 +277,7 @@ NULL
 #'
 #' The `NS` function creates namespaced IDs out of bare IDs, by joining
 #' them using `ns.sep` as the delimiter. It is intended for use in Shiny
-#' modules. See <https://shiny.rstudio.com/articles/modules.html>.
+#' modules. See <http://shiny.rstudio.com/articles/modules.html>.
 #'
 #' Shiny applications use IDs to identify inputs and outputs. These IDs must be
 #' unique within an application, as accidentally using the same input/output ID
@@ -310,7 +294,7 @@ NULL
 #' @param id The id string to be namespaced (optional).
 #' @return If `id` is missing, returns a function that expects an id string
 #'   as its only argument and returns that id with the namespace prepended.
-#' @seealso <https://shiny.rstudio.com/articles/modules.html>
+#' @seealso <http://shiny.rstudio.com/articles/modules.html>
 #' @export
 NS <- function(namespace, id = NULL) {
   if (length(namespace) == 0)
@@ -348,8 +332,8 @@ ShinySession <- R6Class(
     websocket = 'ANY',
     invalidatedOutputValues = 'Map',
     invalidatedOutputErrors = 'Map',
-    inputMessageQueue = 'fastqueue',     # A list of inputMessages to send when flushed
-    cycleStartActionQueue = 'fastqueue', # A list of actions to perform to start a cycle
+    inputMessageQueue = list(), # A list of inputMessages to send when flushed
+    cycleStartActionQueue = list(), # A list of actions to perform to start a cycle
     .outputs = list(),          # Keeps track of all the output observer objects
     .outputOptions = list(),     # Options for each of the output observer objects
     progressKeys = 'character',
@@ -362,7 +346,6 @@ ShinySession <- R6Class(
     flushCallbacks = 'Callbacks',
     flushedCallbacks = 'Callbacks',
     inputReceivedCallbacks = 'Callbacks',
-    unhandledErrorCallbacks = 'Callbacks',
     bookmarkCallbacks = 'Callbacks',
     bookmarkedCallbacks = 'Callbacks',
     restoreCallbacks = 'Callbacks',
@@ -377,7 +360,6 @@ ShinySession <- R6Class(
     currentOutputName = NULL,        # Name of the currently-running output
     outputInfo = list(),             # List of information for each output
     testSnapshotUrl = character(0),
-    currentThemeDependency = NULL,   # ReactiveVal for taking dependency on theme
 
     sendResponse = function(requestMsg, value) {
       if (is.null(requestMsg$tag)) {
@@ -409,7 +391,7 @@ ShinySession <- R6Class(
     sendMessage = function(...) {
       # This function is a wrapper for $write
       msg <- list(...)
-      if (any_unnamed(msg)) {
+      if (anyUnnamed(msg)) {
         stop("All arguments to sendMessage must be named.")
       }
       private$write(toJSON(msg))
@@ -483,36 +465,7 @@ ShinySession <- R6Class(
           # The format of the response that will be sent back. Defaults to
           # "json" unless requested otherwise. The only other valid value is
           # "rds".
-          format <- params$format %||% "json"
-          # Machines can test their snapshot under different locales.
-          # R CMD check runs under the `C` locale.
-          # However, before this parameter, existing snapshots were most likely not
-          #   under the `C` locale is would cause failures. This parameter allows
-          #   users to opt-in to the `C` locale.
-          # From ?sort:
-          #   However, there are some caveats with the radix sort:
-          #     If ‘x’ is a ‘character’ vector, all elements must share the
-          #   same encoding. Only UTF-8 (including ASCII) and Latin-1
-          #   encodings are supported. Collation always follows the "C"
-          #   locale.
-          # {shinytest2} will always set `sortC=1`
-          # {shinytest} does not have `sortC` functionality.
-          #    Users should set `options(shiny.snapshotsortc = TRUE)` within their app.
-          # The sortingMethod should always be `radix` going forward.
-          sortMethod <-
-            if (!is.null(params$sortC)) {
-              if (params$sortC != "1") {
-                stop("The `sortC` parameter can only be `1` or not supplied")
-              }
-              "radix"
-            } else {
-              # Allow users to set an option for {shinytest2}.
-              if (isTRUE(getShinyOption("snapshotsortc", default = FALSE))) {
-                "radix"
-              } else {
-                "auto"
-              }
-            }
+          format <- params$format %OR% "json"
 
           values <- list()
 
@@ -555,7 +508,7 @@ ShinySession <- R6Class(
               }
             )
 
-            values$input <- sortByName(values$input, method = sortMethod)
+            values$input <- sortByName(values$input)
           }
 
           if (!is.null(params$output)) {
@@ -583,7 +536,7 @@ ShinySession <- R6Class(
               }
             )
 
-            values$output <- sortByName(values$output, method = sortMethod)
+            values$output <- sortByName(values$output)
           }
 
           if (!is.null(params$export)) {
@@ -604,7 +557,7 @@ ShinySession <- R6Class(
               )
             }
 
-            values$export <- sortByName(values$export, method = sortMethod)
+            values$export <- sortByName(values$export)
           }
 
           # Make sure input, output, and export are all named lists (at this
@@ -643,22 +596,23 @@ ShinySession <- R6Class(
     # function has been set, return the identity function.
     getSnapshotPreprocessOutput = function(name) {
       fun <- attr(private$.outputs[[name]], "snapshotPreprocess", exact = TRUE)
-      fun %||% identity
+      fun %OR% identity
     },
 
     # Get the snapshotPreprocessInput function for an input name. If no preprocess
     # function has been set, return the identity function.
     getSnapshotPreprocessInput = function(name) {
       fun <- private$.input$getMeta(name, "shiny.snapshot.preprocess")
-      fun %||% identity
+      fun %OR% identity
     },
 
     # See cycleStartAction
     startCycle = function() {
       # TODO: This should check for busyCount == 0L, and remove the checks from
       # the call sites
-      if (private$cycleStartActionQueue$size() > 0) {
-        head <- private$cycleStartActionQueue$remove()
+      if (length(private$cycleStartActionQueue) > 0) {
+        head <- private$cycleStartActionQueue[[1L]]
+        private$cycleStartActionQueue <- private$cycleStartActionQueue[-1L]
 
         # After we execute the current cycleStartAction (head), there may be
         # more items left on the queue. If the current busyCount > 0, then that
@@ -677,7 +631,7 @@ ShinySession <- R6Class(
         # busyCount, it's possible we're calling startCycle spuriously; that's
         # OK, it's essentially a no-op in that case.
         on.exit({
-          if (private$busyCount == 0L && private$cycleStartActionQueue$size() > 0L) {
+          if (private$busyCount == 0L && length(private$cycleStartActionQueue) > 0L) {
             later::later(function() {
               if (private$busyCount == 0L) {
                 private$startCycle()
@@ -715,8 +669,6 @@ ShinySession <- R6Class(
       self$closed <- FALSE
       # TODO: Put file upload context in user/app-specific dir if possible
 
-      private$inputMessageQueue     <- fastmap::fastqueue()
-      private$cycleStartActionQueue <- fastmap::fastqueue()
       private$invalidatedOutputValues <- Map$new()
       private$invalidatedOutputErrors <- Map$new()
       private$fileUploadContext <- FileUploadContext$new()
@@ -724,11 +676,10 @@ ShinySession <- R6Class(
       private$flushCallbacks <- Callbacks$new()
       private$flushedCallbacks <- Callbacks$new()
       private$inputReceivedCallbacks <- Callbacks$new()
-      private$unhandledErrorCallbacks <- Callbacks$new()
       private$.input      <- ReactiveValues$new(dedupe = FALSE, label = "input")
       private$.clientData <- ReactiveValues$new(dedupe = TRUE, label = "clientData")
       private$timingRecorder <- ShinyServerTimingRecorder$new()
-      self$progressStack <- fastmap::faststack()
+      self$progressStack <- Stack$new()
       self$files <- Map$new()
       self$downloads <- Map$new()
       self$userData <- new.env(parent = emptyenv())
@@ -745,7 +696,7 @@ ShinySession <- R6Class(
       # Copy app-level options
       self$options <- getCurrentAppState()$options
 
-      self$cache <- cachem::cache_mem(max_size = 200 * 1024^2)
+      self$cache <- MemoryCache$new()
 
       private$bookmarkCallbacks <- Callbacks$new()
       private$bookmarkedCallbacks <- Callbacks$new()
@@ -755,13 +706,6 @@ ShinySession <- R6Class(
       private$testMode <- getShinyOption("testmode", default = FALSE)
       private$enableTestSnapshot()
 
-      # This `withReactiveDomain` is used only to satisfy the reactlog, so that
-      # it knows to scope this reactiveVal to this session.
-      # https://github.com/rstudio/shiny/pull/3182
-      withReactiveDomain(self,
-        private$currentThemeDependency <- reactiveVal(0, label = "Theme Counter")
-      )
-
       private$registerSessionEndCallbacks()
 
       if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
@@ -861,7 +805,7 @@ ShinySession <- R6Class(
             dots <- eval(substitute(alist(...)))
           }
 
-          if (any_unnamed(dots))
+          if (anyUnnamed(dots))
             stop("exportTestValues: all arguments must be named.")
 
           names(dots) <- ns(names(dots))
@@ -949,7 +893,7 @@ ShinySession <- R6Class(
 
         # Copy `values` from scopeState to state, adding namespace
         if (length(scopeState$values) != 0) {
-          if (any_unnamed(scopeState$values)) {
+          if (anyUnnamed(scopeState$values)) {
             stop("All scope values in must be named.")
           }
 
@@ -1045,21 +989,8 @@ ShinySession <- R6Class(
       new data from the client."
       return(private$inputReceivedCallbacks$register(callback))
     },
-    onUnhandledError = function(callback) {
-      "Registers the callback to be invoked when an unhandled error occurs."
-      return(private$unhandledErrorCallbacks$register(callback))
-    },
-    unhandledError = function(e, close = TRUE) {
-      "Call the global and session unhandled error handlers and then close the
-       session if the error is fatal."
-      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()
+    unhandledError = function(e) {
+      self$close()
     },
     close = function() {
       if (!self$closed) {
@@ -1163,14 +1094,7 @@ ShinySession <- R6Class(
                   structure(list(), class = "try-error", condition = cond)
                 } else if (inherits(cond, "shiny.output.cancel")) {
                   structure(list(), class = "cancel-output")
-                } else if (inherits(cond, "shiny.output.progress")) {
-                  structure(list(), class = "progress-output")
-                } else if (cnd_inherits(cond, "shiny.silent.error")) {
-                  # The error condition might have been chained by
-                  # foreign code, e.g. dplyr. Find the original error.
-                  while (!inherits(cond, "shiny.silent.error")) {
-                    cond <- cond$parent
-                  }
+                } else if (inherits(cond, "shiny.silent.error")) {
                   # Don't let shiny.silent.error go through the normal stop
                   # path of try, because we don't want it to print. But we
                   # do want to try to return the same looking result so that
@@ -1183,7 +1107,6 @@ ShinySession <- R6Class(
                       "logs or contact the app author for",
                       "clarification."))
                   }
-                  self$unhandledError(cond, close = FALSE)
                   invisible(structure(list(), class = "try-error", condition = cond))
                 }
               }
@@ -1194,33 +1117,6 @@ ShinySession <- R6Class(
               # client knows that progress is over.
               self$requestFlush()
 
-              if (inherits(value, "progress-output")) {
-                # This is the case where an output needs to compute for longer
-                # than this reactive flush. We put the output into progress mode
-                # (i.e. adding .recalculating) with a special flag that means
-                # the progress indication should not be cleared until this
-                # specific output receives a new value or error.
-                self$showProgress(name, persistent=TRUE)
-
-                # It's conceivable that this output already ran successfully
-                # within this reactive flush, in which case we could either show
-                # the new output while simultaneously making it .recalculating;
-                # or we squelch the new output and make whatever output is in
-                # the client .recalculating. I (jcheng) decided on the latter as
-                # it seems more in keeping with what we do with these kinds of
-                # intermediate output values/errors in general, i.e. ignore them
-                # and wait until we have a final answer. (Also kind of feels
-                # like a bug in the app code if you routinely have outputs that
-                # are executing successfully, only to be invalidated again
-                # within the same reactive flush--use priority to fix that.)
-                private$invalidatedOutputErrors$remove(name)
-                private$invalidatedOutputValues$remove(name)
-
-                # It's important that we return so that the existing output in
-                # the client remains untouched.
-                return()
-              }
-
               private$sendMessage(recalculating = list(
                 name = name, status = 'recalculated'
               ))
@@ -1262,10 +1158,7 @@ ShinySession <- R6Class(
           private$.outputOptions[[name]] <- list()
       }
       else {
-        rlang::abort(c(
-          paste0("Unexpected ", class(func)[[1]], " object for output$", name),
-          i = "Did you forget to use a render function?"
-        ))
+        stop(paste("Unexpected", class(func), "output for", name))
       }
     },
     getOutput = function(name) {
@@ -1295,7 +1188,7 @@ ShinySession <- R6Class(
           length(private$progressKeys) != 0 ||
           length(private$invalidatedOutputValues) != 0 ||
           length(private$invalidatedOutputErrors) != 0 ||
-          private$inputMessageQueue$size() != 0
+          length(private$inputMessageQueue) != 0
         )
       }
 
@@ -1327,8 +1220,8 @@ ShinySession <- R6Class(
         private$invalidatedOutputValues <- Map$new()
         errors <- as.list(private$invalidatedOutputErrors)
         private$invalidatedOutputErrors <- Map$new()
-        inputMessages <- private$inputMessageQueue$as_list()
-        private$inputMessageQueue$reset()
+        inputMessages <- private$inputMessageQueue
+        private$inputMessageQueue <- list()
 
         if (isTRUE(private$testMode)) {
           private$storeOutputValues(mergeVectors(values, errors))
@@ -1346,36 +1239,30 @@ ShinySession <- R6Class(
     # does not guarantee) inputs and reactive values from changing underneath
     # async observers as they run.
     cycleStartAction = function(callback) {
-      private$cycleStartActionQueue$add(callback)
+      private$cycleStartActionQueue <- c(private$cycleStartActionQueue, list(callback))
       # If no observers are running in this session, we're safe to proceed.
       # Otherwise, startCycle() will be called later, via decrementBusyCount().
       if (private$busyCount == 0L) {
         private$startCycle()
       }
     },
-    showProgress = function(id, persistent=FALSE) {
+    showProgress = function(id) {
       'Send a message to the client that recalculation of the output identified
       by \\code{id} is in progress. There is currently no mechanism for
       explicitly turning off progress for an output component; instead, all
-      progress is implicitly turned off when flushOutput is next called.
-
-      You can use persistent=TRUE if the progress for this output component
-      should stay on beyond the flushOutput (or any subsequent flushOutputs); in
-      that case, progress is only turned off (and the persistent flag cleared)
-      when the output component receives a value or error, or, if
-      showProgress(id, persistent=FALSE) is called and a subsequent flushOutput
-      occurs.'
+      progress is implicitly turned off when flushOutput is next called.'
 
       # If app is already closed, be sure not to show progress, otherwise we
       # will get an error because of the closed websocket
       if (self$closed)
         return()
 
-      if (!id %in% private$progressKeys) {
-        private$progressKeys <- c(private$progressKeys, id)
-      }
+      if (id %in% private$progressKeys)
+        return()
 
-      self$sendProgress('binding', list(id = id, persistent = persistent))
+      private$progressKeys <- c(private$progressKeys, id)
+
+      self$sendProgress('binding', list(id = id))
     },
     sendProgress = function(type, message) {
       private$sendMessage(
@@ -1393,41 +1280,16 @@ ShinySession <- R6Class(
       )
     },
 
-    getCurrentTheme = function() {
-      private$currentThemeDependency()
-      getCurrentTheme()
-    },
-
     setCurrentTheme = function(theme) {
       # This function does three things: (1) sets theme as the current
       # bootstrapTheme, (2) re-executes any registered theme dependencies, and
       # (3) sends the resulting dependencies to the client.
 
-      if (!is_bs_theme(theme)) {
-        stop("`session$setCurrentTheme()` expects a `bslib::bs_theme()` object.", call. = FALSE)
-      }
-
-      # Switching Bootstrap versions has weird & complex consequences
-      # for the JS logic, so we forbid it
-      current_version <- bslib::theme_version(getCurrentTheme())
-      next_version <- bslib::theme_version(theme)
-      if (!identical(current_version, next_version)) {
-        stop(
-          "session$setCurrentTheme() cannot be used to change the Bootstrap version ",
-          "from ", current_version, " to ", next_version, ". ",
-          "Try using `bs_theme(version = ", next_version, ")` for initial theme.",
-          call. = FALSE
-        )
-      }
-
       # Note that this will automatically scope to the session.
-      setCurrentTheme(theme)
-
-      # Invalidate
-      private$currentThemeDependency(isolate(private$currentThemeDependency()) + 1)
+      shinyOptions(bootstrapTheme = theme)
 
       # Call any theme dependency functions and make sure we get a list of deps back
-      funcs <- getShinyOption("themeDependencyFuncs", default = list())
+      funcs <- getShinyOption("themeDependencyFuncs")
       deps <- lapply(funcs, function(func) {
         deps <- func(theme)
         if (length(deps) == 0) return(NULL)
@@ -1483,7 +1345,8 @@ ShinySession <- R6Class(
     sendInputMessage = function(inputId, message) {
       data <- list(id = inputId, message = message)
 
-      private$inputMessageQueue$add(data)
+      # Add to input message queue
+      private$inputMessageQueue[[length(private$inputMessageQueue) + 1]] <- data
       # Needed so that Shiny knows to actually flush the input message queue
       self$requestFlush()
     },
@@ -1516,97 +1379,82 @@ ShinySession <- R6Class(
         return(NULL)
       }
 
-      if (!is.null(private$outputInfo[[name]])) {
-        return(private$outputInfo[[name]])
-      }
-
-      # The following code will only run the first time this function has been
-      # called for this output.
-
-      tmp_info <- list(name = name)
+      tmp_info <- private$outputInfo[[name]] %OR% list(name = name)
 
       # cd_names() returns names of all items in clientData, without taking a
       # reactive dependency. It is a function and it's memoized, so that we do
       # the (relatively) expensive isolate(names(...)) call only when needed,
       # and at most one time in this function.
-      cd_names <- isolate(names(self$clientData))
+      .cd_names <- NULL
+      cd_names <- function() {
+        if (is.null(.cd_names)) {
+          .cd_names <<- isolate(names(self$clientData))
+        }
+        .cd_names
+      }
+
+      # If we don't already have width for this output info, see if it's
+      # present, and if so, add it.
+
+      # Note that all the following clientData values (which are reactiveValues)
+      # are wrapped in reactive() so that users can take a dependency on particular
+      # output info (i.e., just depend on width/height, or just depend on bg, fg, etc).
+      # To put it another way, if getCurrentOutputInfo() simply returned a list of values
+      # from self$clientData, than anything that calls getCurrentOutputInfo() would take
+      # a reactive dependency on all of these values.
+      if (! ("width" %in% names(tmp_info)) ) {
+        width_name  <- paste0("output_", name, "_width")
+        if (width_name %in% cd_names()) {
+          tmp_info$width <- reactive({
+            self$clientData[[width_name]]
+          })
+        }
+      }
+
+      if (! ("height" %in% names(tmp_info)) ) {
+        height_name  <- paste0("output_", name, "_height")
+        if (height_name %in% cd_names()) {
+          tmp_info$height <- reactive({
+            self$clientData[[height_name]]
+          })
+        }
+      }
 
       # parseCssColors() currently errors out if you hand it any NAs
       # This'll make sure we're always working with a string (and if
       # that string isn't a valid CSS color, will return NA)
       # https://github.com/rstudio/htmltools/issues/161
       parse_css_colors <- function(x) {
-        htmltools::parseCssColors(x %||% "", mustWork = FALSE)
+        htmltools::parseCssColors(x %OR% "", mustWork = FALSE)
       }
 
-
-      # This function conditionally adds an item to tmp_info (for "width", it
-      # would create tmp_info$width). It is added _if_ there is an entry in
-      # clientData like "output_foo_width", where "foo" is the name of the
-      # output. The first time `tmp_info$width()` is called, it creates a
-      # reactive expression that reads `clientData$output_foo_width`, saves it,
-      # then invokes that reactive. On subsequent calls, the reactive already
-      # exists, so it simply invokes it.
-      #
-      # The reason it creates the reactive only on first use is so that it
-      # doesn't spuriously create reactives.
-      #
-      # This function essentially generalizes the code below for names other
-      # than just "width".
-      #
-      # width_name <- paste0("output_", name, "_width")
-      # if (width_name %in% cd_names()) {
-      #   width_r <- NULL
-      #   tmp_info$width <- function() {
-      #     if (is.null(width_r)) {
-      #       width_r <<- reactive({
-      #         parse_css_colors(self$clientData[[width_name]])
-      #       })
-      #     }
-      #
-      #     width_r()
-      #   }
-      # }
-      add_conditional_reactive <- function(prop, wrapfun = identity) {
-        force(prop)
-        force(wrapfun)
-
-        prop_name <- paste0("output_", name, "_", prop)
-
-        # Only add tmp_info$width if clientData has "output_foo_width"
-        if (prop_name %in% cd_names) {
-          r <- NULL
-
-          # Turn it into a function that creates a reactive on the first
-          # invocation of getCurrentOutputInfo()$width() and saves it; future
-          # invocations of getCurrentOutputInfo()$width() use the existing
-          # reactive and save it.
-          tmp_info[[prop]] <<- function() {
-            if (is.null(r)) {
-              r <<- reactive(label = prop_name, {
-                wrapfun(self$clientData[[prop_name]])
-              })
-            }
-
-            r()
-          }
-        }
+      bg <- paste0("output_", name, "_bg")
+      if (bg %in% cd_names()) {
+        tmp_info$bg <- reactive({
+          parse_css_colors(self$clientData[[bg]])
+        })
       }
 
+      fg <- paste0("output_", name, "_fg")
+      if (fg %in% cd_names()) {
+        tmp_info$fg <- reactive({
+          parse_css_colors(self$clientData[[fg]])
+        })
+      }
 
-      # Note that all the following clientData values (which are reactiveValues)
-      # are wrapped in reactive() so that users can take a dependency on
-      # particular output info (i.e., just depend on width/height, or just
-      # depend on bg, fg, etc). To put it another way, if getCurrentOutputInfo()
-      # simply returned a list of values from self$clientData, than anything
-      # that calls getCurrentOutputInfo() would take a reactive dependency on
-      # all of these values.
-      add_conditional_reactive("width")
-      add_conditional_reactive("height")
-      add_conditional_reactive("bg",     parse_css_colors)
-      add_conditional_reactive("fg",     parse_css_colors)
-      add_conditional_reactive("accent", parse_css_colors)
-      add_conditional_reactive("font")
+      accent <- paste0("output_", name, "_accent")
+      if (accent %in% cd_names()) {
+        tmp_info$accent <- reactive({
+          parse_css_colors(self$clientData[[accent]])
+        })
+      }
+
+      font <- paste0("output_", name, "_font")
+      if (font %in% cd_names()) {
+        tmp_info$font <- reactive({
+          self$clientData[[font]]
+        })
+      }
 
       private$outputInfo[[name]] <- tmp_info
       private$outputInfo[[name]]
@@ -1623,7 +1471,7 @@ ShinySession <- R6Class(
       # Warn if trying to enable save-to-server bookmarking on a version of SS,
       # SSP, or Connect that doesn't support it.
       if (store == "server" && inShinyServer() &&
-          is.null(getShinyOption("save.interface", default = NULL)))
+          is.null(getShinyOption("save.interface")))
       {
         showNotification(
           "This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.",
@@ -1791,7 +1639,7 @@ ShinySession <- R6Class(
         dots <- eval(substitute(alist(...)))
       }
 
-      if (any_unnamed(dots))
+      if (anyUnnamed(dots))
         stop("exportTestValues: all arguments must be named.")
 
       # Create a named list where each item is a list with an expression and
@@ -1804,7 +1652,7 @@ ShinySession <- R6Class(
     },
 
     getTestSnapshotUrl = function(input = TRUE, output = TRUE, export = TRUE,
-                                  format = "json", sortC = FALSE) {
+                                  format = "json") {
       reqString <- function(group, value) {
         if (isTRUE(value))
           paste0(group, "=1")
@@ -1818,7 +1666,6 @@ ShinySession <- R6Class(
         reqString("input", input),
         reqString("output", output),
         reqString("export", export),
-        reqString("sortC", sortC),
         paste0("format=", format),
         sep = "&"
       )
@@ -2024,7 +1871,7 @@ ShinySession <- R6Class(
         tmpdata <- tempfile(fileext = ext)
         return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() {
           promises::with_promise_domain(reactivePromiseDomain(), {
-            captureStackTraces({
+            promises::with_promise_domain(createStackTracePromiseDomain(), {
               self$incrementBusyCount()
               hybrid_chain(
                 # ..stacktraceon matches with the top-level ..stacktraceoff..
@@ -2040,17 +1887,15 @@ ShinySession <- R6Class(
                   }
                   return(httpResponse(
                     200,
-                    download$contentType %||% getContentType(filename),
+                    download$contentType %OR% getContentType(filename),
                     # owned=TRUE means tmpdata will be deleted after response completes
                     list(file=tmpdata, owned=TRUE),
                     c(
                       'Content-Disposition' = ifelse(
                         dlmatches[3] == '',
-                        paste0(
-                          'attachment; filename="',
-                          gsub('(["\\\\])', '\\\\\\1', filename),
-                          '"'
-                        ),
+                        'attachment; filename="' %.%
+                          gsub('(["\\\\])', '\\\\\\1', filename) %.%  # yes, that many \'s
+                          '"',
                         'attachment'
                       ),
                       'Cache-Control'='no-cache')))
@@ -2218,6 +2063,16 @@ ShinySession <- R6Class(
         })
       }
     }
+  ),
+  active = list(
+    session = function() {
+      shinyDeprecated(
+        msg = paste("Attempted to access deprecated shinysession$session object.",
+                    "Please just access the shinysession object directly."),
+        version = "0.11.1"
+      )
+      self
+    }
   )
 )
 
@@ -2254,7 +2109,7 @@ ShinySession <- R6Class(
   if (getOption("shiny.allowoutputreads", FALSE)) {
     .subset2(x, 'impl')$getOutput(name)
   } else {
-    rlang::abort(paste0("Can't read output '", name, "'"))
+    stop("Reading from shinyoutput object is not allowed.")
   }
 }
 
@@ -2263,12 +2118,12 @@ ShinySession <- R6Class(
 
 #' @export
 `[.shinyoutput` <- function(values, name) {
-  rlang::abort("Can't index shinyoutput with `[`.")
+  stop("Single-bracket indexing of shinyoutput object is not allowed.")
 }
 
 #' @export
 `[<-.shinyoutput` <- function(values, name, value) {
-  rlang::abort("Can't index shinyoutput with `[[`.")
+  stop("Single-bracket indexing of shinyoutput object is not allowed.")
 }
 
 #' Set options for an output object.
@@ -2385,89 +2240,23 @@ getCurrentOutputInfo <- function(session = getDefaultReactiveDomain()) {
 
 #' Add callbacks for Shiny session events
 #'
-#' @description
 #' These functions are for registering callbacks on Shiny session events.
-#' `onFlush` registers a function that will be called before Shiny flushes the
-#' reactive system. `onFlushed` registers a function that will be called after
-#' Shiny flushes the reactive system. `onUnhandledError` registers a function to
-#' be called when an unhandled error occurs before the session is closed.
-#' `onSessionEnded` registers a function to be called after the client has
-#' disconnected.
+#' `onFlush` registers a function that will be called before Shiny flushes
+#' the reactive system. `onFlushed` registers a function that will be
+#' called after Shiny flushes the reactive system. `onSessionEnded`
+#' registers a function to be called after the client has disconnected.
 #'
 #' These functions should be called within the application's server function.
 #'
 #' All of these functions return a function which can be called with no
 #' arguments to cancel the registration.
 #'
-#' @section Unhandled Errors:
-#' Unhandled errors are errors that aren't otherwise handled by Shiny or by the
-#' application logic. In other words, they are errors that will either cause the
-#' application to crash or will result in "Error" output in the UI.
-#'
-#' You can use `onUnhandledError()` to register a function that will be called
-#' when an unhandled error occurs. This function will be called with the error
-#' object as its first argument. If the error is fatal and will result in the
-#' session closing, the error condition will have the `shiny.error.fatal` class.
-#'
-#' Note that the `onUnhandledError()` callbacks cannot be used to prevent the
-#' app from closing or to modify the error condition. Instead, they are intended
-#' to give you an opportunity to log the error or perform other cleanup
-#' operations.
-#'
 #' @param fun A callback function.
 #' @param once Should the function be run once, and then cleared, or should it
 #'   re-run each time the event occurs. (Only for `onFlush` and
 #'   `onFlushed`.)
 #' @param session A shiny session object.
 #'
-#' @examplesIf interactive()
-#' library(shiny)
-#'
-#' ui <- fixedPage(
-#'   markdown(c(
-#'     "Set the number to 8 or higher to cause an error",
-#'     "in the `renderText()` output."
-#'   )),
-#'   sliderInput("number", "Number", 0, 10, 4),
-#'   textOutput("text"),
-#'   hr(),
-#'   markdown(c(
-#'     "Click the button below to crash the app with an unhandled error",
-#'     "in an `observe()` block."
-#'   )),
-#'   actionButton("crash", "Crash the app!")
-#' )
-#'
-#' log_event <- function(level, ...) {
-#'   ts <- strftime(Sys.time(), " [%F %T] ")
-#'   message(level, ts, ...)
-#' }
-#'
-#' server <- function(input, output, session) {
-#'   log_event("INFO", "Session started")
-#'
-#'   onUnhandledError(function(err) {
-#'     # log the unhandled error
-#'     level <- if (inherits(err, "shiny.error.fatal")) "FATAL" else "ERROR"
-#'     log_event(level, conditionMessage(err))
-#'   })
-#'
-#'   onStop(function() {
-#'     log_event("INFO", "Session ended")
-#'   })
-#'
-#'   observeEvent(input$crash, stop("Oops, an unhandled error happened!"))
-#'
-#'   output$text <- renderText({
-#'     if (input$number > 7) {
-#'       stop("that's too high!")
-#'     }
-#'     sprintf("You picked number %d.", input$number)
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#'
 #' @export
 onFlush <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
   session$onFlush(fun, once = once)
@@ -2488,27 +2277,6 @@ onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) {
   session$onSessionEnded(fun)
 }
 
-.globals$onUnhandledErrorCallbacks <- NULL
-on_load({
-  .globals$onUnhandledErrorCallbacks <- Callbacks$new()
-})
-
-#' @rdname onFlush
-#' @export
-onUnhandledError <- function(fun, session = getDefaultReactiveDomain()) {
-  if (!is.function(fun) || length(formals(fun)) == 0) {
-    rlang::abort(
-      "The unhandled error callback must be a function that takes an error object as its first argument."
-    )
-  }
-
-  if (is.null(session)) {
-    .globals$onUnhandledErrorCallbacks$register(fun)
-  } else {
-    session$onUnhandledError(fun)
-  }
-}
-
 
 flushPendingSessions <- function() {
   lapply(appsNeedingFlush$values(), function(shinysession) {
@@ -2707,19 +2475,3 @@ markdown <- function(mds, extensions = TRUE, .noWS = NULL, ...) {
   html <- rlang::exec(commonmark::markdown_html, glue::trim(mds), extensions = extensions, ...)
   htmltools::HTML(html, .noWS = .noWS)
 }
-
-
-# Check that an object is a ShinySession object, and give an informative error.
-# The default label is the caller function's name.
-validate_session_object <- function(session, label = as.character(sys.call(sys.parent())[[1]])) {
-  if (missing(session) ||
-      !inherits(session, c("ShinySession", "MockShinySession", "session_proxy")))
-  {
-    stop(call. = FALSE,
-      sprintf(
-        "`session` must be a 'ShinySession' object. Did you forget to pass `session` to `%s()`?",
-        label
-      )
-    )
-  }
-}

R/shinyapp.R

@@ -113,10 +113,7 @@ shinyApp <- function(ui, server, onStart=NULL, options=list(),
 #' @export
 shinyAppDir <- function(appDir, options=list()) {
   if (!utils::file_test('-d', appDir)) {
-    rlang::abort(
-      paste0("No Shiny application exists at the path \"", appDir, "\""),
-      class = "invalidShinyAppDir"
-    )
+    stop("No Shiny application exists at the path \"", appDir, "\"")
   }
 
   # In case it's a relative path, convert to absolute (so we're not adversely
@@ -128,10 +125,7 @@ shinyAppDir <- function(appDir, options=list()) {
   } else if (file.exists.ci(appDir, "app.R")) {
     shinyAppDir_appR("app.R", appDir, options = options)
   } else {
-    rlang::abort(
-      "App dir must contain either app.R or server.R.",
-      class = "invalidShinyAppDir"
-    )
+    stop("App dir must contain either app.R or server.R.")
   }
 }
 
@@ -162,29 +156,11 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     sharedEnv <- globalenv()
   }
 
-  # To enable hot-reloading of support files, this function is called
-  # whenever the UI or Server func source is updated. To avoid loading
-  # support files 2x, we follow the last cache update trigger timestamp.
-  autoload_r_support_if_needed <- local({
-    autoload_last_loaded <- -1
-    function() {
-      if (!isTRUE(getOption("shiny.autoload.r", TRUE))) return()
-      
-      last_cache_trigger <- cachedAutoReloadLastChanged$get()
-      if (identical(autoload_last_loaded, last_cache_trigger)) return()
-
-      loadSupport(appDir, renv = sharedEnv, globalrenv = globalenv())
-
-      autoload_last_loaded <<- last_cache_trigger
-    }
-  })
-
   # uiHandlerSource is a function that returns an HTTP handler for serving up
   # ui.R as a webpage. The "cachedFuncWithFile" call makes sure that the closure
   # we're creating here only gets executed when ui.R's contents change.
   uiHandlerSource <- cachedFuncWithFile(appDir, "ui.R", case.sensitive = FALSE,
     function(uiR) {
-      autoload_r_support_if_needed()
       if (file.exists(uiR)) {
         # If ui.R contains a call to shinyUI (which sets .globals$ui), use that.
         # If not, then take the last expression that's returned from ui.R.
@@ -211,11 +187,10 @@ 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) {
-      autoload_r_support_if_needed()
       # If server.R contains a call to shinyServer (which sets .globals$server),
       # use that. If not, then take the last expression that's returned from
       # server.R.
@@ -251,9 +226,10 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
+    # TODO: we should support hot reloading on global.R and R/*.R changes.
     if (getOption("shiny.autoload.r", TRUE)) {
-      autoload_r_support_if_needed()
-    } else {
+      loadSupport(appDir, renv=sharedEnv, globalrenv=globalenv())
+    }  else {
       if (file.exists(file.path.ci(appDir, "global.R")))
         sourceUTF8(file.path.ci(appDir, "global.R"))
     }
@@ -304,81 +280,37 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
-  if (!get_devmode_option("shiny.autoreload", FALSE)) {
+  if (!getOption("shiny.autoreload", FALSE)) {
     return(function(){})
   }
 
-  filePattern <- getOption(
-    "shiny.autoreload.pattern",
-    ".*\\.(r|html?|js|css|png|jpe?g|gif)$"
-  )
+  filePattern <- getOption("shiny.autoreload.pattern",
+    ".*\\.(r|html?|js|css|png|jpe?g|gif)$")
 
-  
-  if (is_installed("watcher")) {
-    check_for_update <- function(paths) {
-      paths <- grep(
-        filePattern,
-        paths,
-        ignore.case = TRUE,
-        value = TRUE
-      )
-      
-      if (length(paths) == 0) {
-        return()
-      }
-      
-      cachedAutoReloadLastChanged$set()
+  lastValue <- NULL
+  observeLabel <- paste0("File Auto-Reload - '", basename(dir), "'")
+  obs <- observe(label = observeLabel, {
+    files <- sort_c(
+      list.files(dir, pattern = filePattern, recursive = TRUE, ignore.case = TRUE)
+    )
+    times <- file.info(files)$mtime
+    names(times) <- files
+
+    if (is.null(lastValue)) {
+      # First run
+      lastValue <<- times
+    } else if (!identical(lastValue, times)) {
+      # We've changed!
+      lastValue <<- times
       autoReloadCallbacks$invoke()
     }
-    
-    # [garrick, 2025-02-20] Shiny <= v1.10.0 used `invalidateLater()` with an
-    # autoreload.interval in ms. {watcher} instead uses a latency parameter in
-    # seconds, which serves a similar purpose and that I'm keeping for backcompat.
-    latency <- getOption("shiny.autoreload.interval", 250) / 1000
-    watcher <- watcher::watcher(dir, check_for_update, latency = latency)
-    watcher$start()
-    onStop(watcher$stop)
-  } else {
-    # Fall back to legacy observer behavior
-    if (!is_false(getOption("shiny.autoreload.legacy_warning", TRUE))) {
-      cli::cli_warn(
-        c(
-          "Using legacy autoreload file watching. Please install {.pkg watcher} for a more performant autoreload file watcher.",
-          "i" = "Set {.run options(shiny.autoreload.legacy_warning = FALSE)} to suppress this warning."
-        ),
-        .frequency = "regularly",
-        .frequency_id = "shiny.autoreload.legacy_warning"
-      )
-    }
 
-    lastValue <- NULL
-    observeLabel <- paste0("File Auto-Reload - '", basename(dir), "'")
-    watcher <- observe(label = observeLabel, {
-      files <- sort_c(
-        list.files(dir, pattern = filePattern, recursive = TRUE, ignore.case = TRUE)
-      )
-      times <- file.info(files)$mtime
-      names(times) <- files
-  
-      if (is.null(lastValue)) {
-        # First run
-        lastValue <<- times
-      } else if (!identical(lastValue, times)) {
-        # We've changed!
-        lastValue <<- times
-        cachedAutoReloadLastChanged$set()
-        autoReloadCallbacks$invoke()
-      }
-  
-      invalidateLater(getOption("shiny.autoreload.interval", 500))
-    })
-  
-    onStop(watcher$destroy)
-  
-    watcher$destroy
-  }
+    invalidateLater(getOption("shiny.autoreload.interval", 500))
+  })
 
-  invisible(watcher)
+  onStop(obs$destroy)
+
+  obs$destroy
 }
 
 #' Load an app's supporting R files
@@ -401,7 +333,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 environment in which the files in the `R/` directory should
+#' @param renv The environmeny in which the files in the `R/` directory should
 #'   be evaluated.
 #' @param globalrenv The environment in which `global.R` should be evaluated. If
 #'   `NULL`, `global.R` will not be evaluated at all.
@@ -427,12 +359,10 @@ 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:
@@ -447,27 +377,6 @@ 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
@@ -483,6 +392,8 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
       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.
@@ -527,7 +438,7 @@ 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
@@ -647,7 +558,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 %||% list()
+  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
 

R/shinyui.R

@@ -14,11 +14,7 @@ NULL
 #' # now we can just write "static" content without withMathJax()
 #' div("more math here $$\\sqrt{2}$$")
 withMathJax <- function(...) {
-  path <- paste0(
-    getOption("shiny.mathjax.url", "https://mathjax.rstudio.com/latest/MathJax.js"),
-    "?",
-    getOption("shiny.mathjax.config", "config=TeX-AMS-MML_HTMLorMML")
-  )
+  path <- 'https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
   tagList(
     tags$head(
       singleton(tags$script(src = path, type = 'text/javascript'))
@@ -43,7 +39,7 @@ renderPage <- function(ui, showcase=0, testMode=FALSE) {
 
     # Put the body into the default template
     ui <- htmlTemplate(
-      system_file("template", "default.html", package = "shiny"),
+      system.file("template", "default.html", package = "shiny"),
       lang = lang,
       body = ui,
       # this template is a complete HTML document
@@ -51,116 +47,72 @@ renderPage <- function(ui, showcase=0, testMode=FALSE) {
     )
   }
 
+  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 <- c(
-    list(jqueryDependency()),
+    list(jquery()),
     shinyDependencies()
   )
 
   if (testMode) {
     # Add code injection listener if in test mode
     shiny_deps[[length(shiny_deps) + 1]] <-
-      htmlDependency(
-        "shiny-testmode",
-        get_package_version("shiny"),
-        src = "www/shared",
-        package = "shiny",
-        script = "shiny-testmode.js",
-        all_files = FALSE
-      )
+      htmlDependency("shiny-testmode", utils::packageVersion("shiny"),
+                     c(href="shared"), script = "shiny-testmode.js")
   }
 
-  if (in_devmode() || in_client_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)
   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() {
+  version <- utils::packageVersion("shiny")
   list(
-    bslib::bs_dependency_defer(shinyDependencyCSS),
-    busyIndicatorDependency(),
+    bootstraplib::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
+      version = version,
+      src = c(href = "shared"),
+      script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js"
     )
   )
 }
 
-shinyDependencySass <- function(bs_version) {
-  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"))
-  lapply(scss_files, sass::sass_file)
-}
-
 shinyDependencyCSS <- function(theme) {
-  version <- get_package_version("shiny")
+  version <- utils::packageVersion("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
+      src = c(href = "shared"),
+      stylesheet = "shiny.min.css"
     ))
   }
 
-  bs_version <- bslib::theme_version(theme)
+  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 = shinyDependencySass(bs_version),
+  bootstraplib::bs_dependency(
+    input = scss_files,
     theme = theme,
     name = "shiny-sass",
     version = version,
@@ -170,30 +122,17 @@ shinyDependencyCSS <- function(theme) {
 
 #' Create a Shiny UI handler
 #'
-#' @description `r lifecycle::badge("superseded")`
-#'
-#' @description Historically this function was used in ui.R files to register a user
+#' 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 interface definition
+#' @param ui A user interace definition
 #' @return The user interface definition, without modifications or side effects.
 #' @keywords internal
 #' @export
 shinyUI <- function(ui) {
-  if (in_devmode()) {
-    shinyDeprecated(
-      "0.10.0", "shinyUI()",
-      details = paste0(
-        "When removing `shinyUI()`, ",
-        "ensure that the last expression returned from ui.R is a user interface ",
-        "normally supplied to `shinyUI(ui)`."
-      )
-    )
-  }
-
   .globals$ui <- list(ui)
   ui
 }
@@ -204,7 +143,7 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
 
   allowed_methods <- "GET"
   if (is.function(ui)) {
-    allowed_methods <- attr(ui, "http_methods_supported", exact = TRUE) %||% allowed_methods
+    allowed_methods <- attr(ui, "http_methods_supported", exact = TRUE) %OR% allowed_methods
   }
 
   function(req) {

R/shinywrappers.R

@@ -1,123 +1,34 @@
-utils::globalVariables('func', add = TRUE)
+utils::globalVariables('func')
 
 #' Mark a function as a 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.
+#' Should be called by implementers of `renderXXX` functions in order to
+#' mark their return values as Shiny render functions, and to provide a hint to
+#' Shiny regarding what UI function is most commonly used with this type of
+#' render function. This can be used in R Markdown documents to create complete
+#' output widgets out of just the render function.
 #'
 #' @param uiFunc A function that renders Shiny UI. Must take a single argument:
 #'   an output ID.
 #' @param renderFunc A function that is suitable for assigning to a Shiny output
 #'   slot.
 #' @param outputArgs A list of arguments to pass to the `uiFunc`. Render
-#'   functions should include `outputArgs = list()` in their own parameter list,
-#'   and pass through the value to `markRenderFunction`, to allow app authors to
-#'   customize outputs. (Currently, this is only supported for dynamically
-#'   generated UIs, such as those created by Shiny code snippets embedded in R
-#'   Markdown documents).
-#' @param cacheHint One of `"auto"`, `FALSE`, or some other information to
-#'   identify this instance for caching using [bindCache()]. If `"auto"`, it
-#'   will try to automatically infer caching information. If `FALSE`, do not
-#'   allow caching for the object. Some render functions (such as [renderPlot])
-#'   contain internal state that makes them unsuitable for caching.
-#' @param cacheWriteHook Used if the render function is passed to `bindCache()`.
-#'   This is an optional callback function to invoke before saving the value
-#'   from the render function to the cache. This function must accept one
-#'   argument, the value returned from `renderFunc`, and should return the value
-#'   to store in the cache.
-#' @param cacheReadHook Used if the render function is passed to `bindCache()`.
-#'   This is an optional callback function to invoke after reading a value from
-#'   the cache (if there is a cache hit). The function will be passed one
-#'   argument, the value retrieved from the cache. This can be useful when some
-#'   side effect needs to occur for a render function to behave correctly. For
-#'   example, some render functions call [createWebDependency()] so that Shiny
-#'   is able to serve JS and CSS resources.
+#'   functions should include `outputArgs = list()` in their own parameter
+#'   list, and pass through the value to `markRenderFunction`, to allow
+#'   app authors to customize outputs. (Currently, this is only supported for
+#'   dynamically generated UIs, such as those created by Shiny code snippets
+#'   embedded in R Markdown documents).
 #' @return The `renderFunc` function, with annotations.
-#'
-#' @seealso [createRenderFunction()]
 #' @export
-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)
-
+markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
   # a mutable object that keeps track of whether `useRenderFunction` has been
   # executed (this usually only happens when rendering Shiny code snippets in
   # an interactive R Markdown document); its initial value is FALSE
   hasExecuted <- Mutable$new()
   hasExecuted$set(FALSE)
 
-  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(...) {
+  origRenderFunc <- renderFunc
+  renderFunc <- function(...) {
     # if the user provided something through `outputArgs` BUT the
     # `useRenderFunction` was not executed, then outputArgs will be ignored,
     # so throw a warning to let user know the correct usage
@@ -130,20 +41,15 @@ markRenderFunction <- function(
       # stop warning from happening again for the same object
       hasExecuted$set(TRUE)
     }
-    if (is.null(formals(renderFunc))) renderFunc()
-    else renderFunc(...)
+    if (is.null(formals(origRenderFunc))) origRenderFunc()
+    else origRenderFunc(...)
   }
 
-  structure(
-    wrappedRenderFunc,
-    class          = c("shiny.render.function", "function"),
-    outputFunc     = uiFunc,
-    outputArgs     = outputArgs,
-    hasExecuted    = hasExecuted,
-    cacheHint      = cacheHint,
-    cacheWriteHook = cacheWriteHook,
-    cacheReadHook  = cacheReadHook
-  )
+  structure(renderFunc,
+            class       = c("shiny.render.function", "function"),
+            outputFunc  = uiFunc,
+            outputArgs  = outputArgs,
+            hasExecuted = hasExecuted)
 }
 
 #' @export
@@ -151,27 +57,7 @@ print.shiny.render.function <- function(x, ...) {
   cat_line("<shiny.render.function>")
 }
 
-#' 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).
+#' Implement render functions
 #'
 #' @param func A function without parameters, that returns user data. If the
 #'   returned value is a promise, then the render function will proceed in async
@@ -184,99 +70,34 @@ 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.
-#' @inheritParams markRenderFunction
+#' @param outputArgs A list of arguments to pass to the `outputFunc`.
+#'   Render functions should include `outputArgs = list()` in their own
+#'   parameter list, and pass through the value as this argument, to allow app
+#'   authors to customize outputs. (Currently, this is only supported for
+#'   dynamically generated UIs, such as those created by Shiny code snippets
+#'   embedded in R Markdown documents).
 #' @return An annotated render function, ready to be assigned to an
 #'   `output` slot.
 #'
-#' @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,
-  cacheHint = "auto",
-  cacheWriteHook = NULL,
-  cacheReadHook = NULL
+  func, transform = function(value, session, name, ...) value,
+  outputFunc = NULL, outputArgs = NULL
 ) {
+
   renderFunc <- function(shinysession, name, ...) {
     hybrid_chain(
       func(),
-      function(value) {
-        transform(value, shinysession, name, ...)
+      function(value, .visible) {
+        transform(setVisible(value, .visible), shinysession, name, ...)
       }
     )
   }
 
-  # 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)
+  if (!is.null(outputFunc))
+    markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+  else
+    renderFunc
 }
 
 useRenderFunction <- function(renderFunc, inline = FALSE) {
@@ -319,22 +140,6 @@ 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
 #'
@@ -383,13 +188,13 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #' The corresponding HTML output tag should be `div` or `img` and have
 #' the CSS class name `shiny-image-output`.
 #'
-#' @seealso 
-#' * For more details on how the images are generated, and how to control
+#' @seealso For more details on how the images are generated, and how to control
 #'   the output, see [plotPNG()].
-#' * Use [outputOptions()] to set general output options for an image output.
 #'
 #' @param expr An expression that returns a list.
-#' @inheritParams renderUI
+#' @param env The environment in which to evaluate `expr`.
+#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
+#'   is useful if you want to save an expression in a variable.
 #' @param deleteFile Should the file in `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`;
@@ -468,10 +273,9 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #'
 #' shinyApp(ui, server)
 #' }
-renderImage <- function(expr, env = parent.frame(), quoted = FALSE,
-                        deleteFile, outputArgs=list())
-{
-  func <- installExprFunction(expr, "func", env, quoted, label = "renderImage")
+renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
+                        deleteFile, outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
   # missing() must be used directly within the function with the given arg
   if (missing(deleteFile)) {
@@ -520,7 +324,7 @@ renderImage <- function(expr, env = parent.frame(), quoted = FALSE,
       }
 
       # If contentType not specified, autodetect based on extension
-      contentType <- imageinfo$contentType %||% getContentType(imageinfo$src)
+      contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
 
       # Extra values are everything in imageinfo except 'src' and 'contentType'
       extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
@@ -529,10 +333,7 @@ renderImage <- function(expr, env = parent.frame(), quoted = FALSE,
       c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
         extra_attr)
     },
-    imageOutput,
-    outputArgs,
-    cacheHint = FALSE
-  )
+    imageOutput, outputArgs)
 }
 
 # TODO: If we ever take a dependency on fs, it'd be great to replace this with
@@ -593,19 +394,19 @@ isTemp <- function(path, tempDir = tempdir(), mustExist) {
 #' function return [invisible()].
 #'
 #' @param expr An expression to evaluate.
-#' @inheritParams renderUI
+#' @param env The environment in which to evaluate `expr`. For expert use only.
+#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
+#'   is useful if you want to save an expression in a variable.
 #' @param width Width of printed output.
 #' @param outputArgs A list of arguments to be passed through to the implicit
 #'   call to [verbatimTextOutput()] or [textOutput()] when the functions are
 #'   used in an interactive RMarkdown document.
 #'
 #' @example res/text-example.R
-#' @seealso [outputOptions()]
 #' @export
 renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
-                        width = getOption('width'), outputArgs=list())
-{
-  func <- installExprFunction(expr, "func", env, quoted, label = "renderPrint")
+                        width = getOption('width'), outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
   # Set a promise domain that sets the console width
   #   and captures output
@@ -618,12 +419,12 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
       {
         promises::with_promise_domain(domain, func())
       },
-      function(value) {
-        res <- withVisible(value)
-        if (res$visible) {
-          cat(file = domain$conn, paste(utils::capture.output(res$value, append = TRUE), collapse = "\n"))
+      function(value, .visible) {
+        if (.visible) {
+          cat(file = domain$conn, paste(utils::capture.output(value, append = TRUE), collapse = "\n"))
         }
-        paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
+        res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
+        res
       },
       finally = function() {
         close(domain$conn)
@@ -631,15 +432,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     )
   }
 
-  markRenderFunction(
-    verbatimTextOutput,
-    renderFunc,
-    outputArgs,
-    cacheHint = list(
-      label = "renderPrint",
-      origUserExpr = installedFuncExpr(func)
-    )
-  )
+  markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
 }
 
 createRenderPrintPromiseDomain <- function(width) {
@@ -687,18 +480,16 @@ createRenderPrintPromiseDomain <- function(width) {
 #'   element.
 #' @export
 #' @rdname renderPrint
-renderText <- function(expr, env = parent.frame(), quoted = FALSE,
+renderText <- function(expr, env=parent.frame(), quoted=FALSE,
                        outputArgs=list(), sep=" ") {
-
-  func <- installExprFunction(expr, "func", env, quoted, label = "renderText")
+  installExprFunction(expr, "func", env, quoted)
 
   createRenderFunction(
     func,
     function(value, session, name, ...) {
       paste(utils::capture.output(cat(value, sep=sep)), collapse="\n")
     },
-    textOutput,
-    outputArgs
+    textOutput, outputArgs
   )
 }
 
@@ -711,18 +502,14 @@ 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.
-#' @template param-env
-#' @templateVar x expr
-#' @templateVar env env
-#' @templateVar quoted quoted
-#' @template param-quoted
-#' @templateVar x expr
-#' @templateVar quoted quoted
+#' @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 [uiOutput()] when `renderUI` is used in an
 #'   interactive R Markdown document.
 #'
-#' @seealso [uiOutput()], [outputOptions()]
+#' @seealso [uiOutput()]
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -743,10 +530,9 @@ renderText <- function(expr, env = parent.frame(), quoted = FALSE,
 #' shinyApp(ui, server)
 #' }
 #'
-renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
-                     outputArgs = list())
-{
-  func <- installExprFunction(expr, "func", env, quoted, label = "renderUI")
+renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
+                     outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
   createRenderFunction(
     func,
@@ -756,8 +542,7 @@ renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
 
       processDeps(result, shinysession)
     },
-    uiOutput,
-    outputArgs
+    uiOutput, outputArgs
   )
 }
 
@@ -780,10 +565,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](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.
+#'   [content type](http://en.wikipedia.org/wiki/Internet_media_type), for
+#'   example `"text/csv"` or `"image/png"`. If `NULL` or
+#'   `NA`, the content type will be guessed based on the filename
+#'   extension, or `application/octet-stream` if the extension is unknown.
 #' @param outputArgs A list of arguments to be passed through to the implicit
 #'   call to [downloadButton()] when `downloadHandler` is used
 #'   in an interactive R Markdown document.
@@ -812,50 +597,38 @@ renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
 #'
 #' shinyApp(ui, server)
 #' }
-#'
-#' @seealso
-#' * The download handler, like other outputs, is suspended (disabled) by
-#'   default for download buttons and links that are hidden. Use 
-#'   [outputOptions()] to control this behavior, e.g. to set 
-#'   `suspendWhenHidden = FALSE` if the download is initiated by 
-#'   programmatically clicking on the download button using JavaScript.
 #' @export
-downloadHandler <- function(filename, content, contentType=NULL, outputArgs=list()) {
+downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()) {
   renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
   }
   snapshotExclude(
-    markRenderFunction(downloadButton, renderFunc, outputArgs, cacheHint = FALSE)
+    markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
   )
 }
 
-#' Table output with the JavaScript DataTables library
+#' Table output with the JavaScript library DataTables
 #'
-#' @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.
+#' 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.
 #'
+#' 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.  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.
+#'   or a function to return such a 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.
+#'   instance to be available (<http://datatables.net/extensions/>).
 #' @param escape Whether to escape HTML entities in the table: `TRUE` means
 #'   to escape the whole table, and `FALSE` means not to escape it.
 #'   Alternatively, you can specify numeric column indices or column names to
@@ -863,8 +636,17 @@ downloadHandler <- function(filename, content, contentType=NULL, 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
@@ -889,62 +671,11 @@ downloadHandler <- function(filename, content, contentType=NULL, outputArgs=list
 #'     }
 #'   )
 #' }
-#' @keywords internal
 renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             callback = 'function(oTable) {}', escape = TRUE,
                             env = parent.frame(), quoted = FALSE,
-                            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")
+                            outputArgs=list()) {
+  installExprFunction(expr, "func", env, quoted)
 
   renderFunc <- function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
@@ -978,8 +709,7 @@ legacyRenderDataTable <- function(expr, options = NULL, searchDelay = 500,
     )
   }
 
-  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs,
-    cacheHint = FALSE)
+  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
 
   renderFunc <- snapshotPreprocessOutput(renderFunc, function(value) {
     # Remove the action field so that it's not saved in test snapshots. It
@@ -997,7 +727,7 @@ legacyRenderDataTable <- 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
@@ -1032,3 +762,64 @@ 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,40 +32,26 @@ licenseLink <- function(licenseName) {
 showcaseHead <- function() {
 
   deps  <- list(
-    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
-    )
+    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")
   )
 
   mdfile <- file.path.ci(getwd(), 'Readme.md')
-  html <- tagList(
+  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"),
     if (file.exists(mdfile))
-      tags$script(type="text/markdown", id="showcase-markdown-content",
+      script(type="text/markdown", id="showcase-markdown-content",
         paste(readUTF8(mdfile), collapse="\n"))
     else ""
-  )
+  ))
 
   return(attachDependencies(html, deps))
 }
@@ -97,7 +83,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", "data-bs-toggle"="tab", paste0(prefix, file)))
+           "data-toggle"="tab", paste0(prefix, file)))
     )
   })
 }
@@ -106,7 +92,7 @@ navTabsDropdown <- function(files) {
   if (length(files) > 0) {
     with(tags,
       li(role="presentation", class="dropdown",
-        a(class="dropdown-toggle", `data-toggle`="dropdown", `data-bs-toggle`="dropdown", href="#",
+        a(class="dropdown-toggle", `data-toggle`="dropdown", href="#",
           role="button", `aria-haspopup`="true", `aria-expanded`="false",
           "www", span(class="caret")
         ),
@@ -148,7 +134,7 @@ showcaseCodeTabs <- function(codeLicense) {
     a(id="showcase-code-position-toggle",
       class="btn btn-default btn-sm",
       onclick="toggleCodePosition()",
-      icon("level-up-alt"),
+      icon("level-up"),
       "show with app"),
     ul(class="nav nav-tabs",
        navTabsHelper(rFiles),

R/stack.R

@@ -0,0 +1,70 @@
+# 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

@@ -1,200 +0,0 @@
-# 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.R

@@ -158,7 +158,8 @@ print.shiny_runtests <- function(x, ..., reporter = "summary") {
 
 
   if (any(x$pass)) {
-    cli::cat_bullet("Success", bullet = "tick", bullet_col = "green")
+    # TODO in future... use clisymbols::symbol$tick and crayon green
+    cat("* Success\n")
     mapply(
       x$file,
       x$pass,
@@ -170,8 +171,9 @@ print.shiny_runtests <- function(x, ..., reporter = "summary") {
       }
     )
   }
-  if (!all(x$pass)) {
-    cli::cat_bullet("Failure", bullet = "cross", bullet_col = "red")
+  if (any(!x$pass)) {
+    # TODO in future... use clisymbols::symbol$cross and crayon red
+    cat("* Failure\n")
     mapply(
       x$file,
       x$pass,

R/update-input.R

@@ -34,14 +34,8 @@
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateTextInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL, placeholder = NULL) {
-  validate_session_object(session)
-
-  message <- dropNulls(list(
-    label = processDeps(label, session), 
-    value = value, 
-    placeholder = placeholder
-  ))
+updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeholder = NULL) {
+  message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
   session$sendInputMessage(inputId, message)
 }
 
@@ -112,13 +106,8 @@ updateTextAreaInput <- updateTextInput
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL) {
-  validate_session_object(session)
-
-  message <- dropNulls(list(
-    label = processDeps(label, session),
-    value = value
-  ))
+updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
+  message <- dropNulls(list(label=label, value=value))
   session$sendInputMessage(inputId, message)
 }
 
@@ -126,8 +115,6 @@ updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, l
 #' Change the label or icon of an action button on the client
 #'
 #' @template update-input
-#' @param disabled If `TRUE`, the button will not be clickable; if `FALSE`, it
-#'   will be.
 #' @inheritParams actionButton
 #'
 #' @seealso [actionButton()]
@@ -157,13 +144,13 @@ updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, l
 #'       label = "New label",
 #'       icon = icon("calendar"))
 #'
-#'     # Leaves goButton2's label unchanged and
+#'     # Leaves goButton2's label unchaged and
 #'     # removes its icon
 #'     updateActionButton(session, "goButton2",
 #'       icon = character(0))
 #'
 #'     # Leaves goButton3's icon, if it exists,
-#'     # unchanged and changes its label
+#'     # unchaged and changes its label
 #'     updateActionButton(session, "goButton3",
 #'       label = "New label 3")
 #'
@@ -178,22 +165,14 @@ updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, l
 #' }
 #' @rdname updateActionButton
 #' @export
-updateActionButton <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL, disabled = NULL) {
-  validate_session_object(session)
-
+updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
   if (!is.null(icon)) icon <- as.character(validateIcon(icon))
-  message <- dropNulls(list(
-    label = processDeps(label, session),
-    icon = icon,
-    disabled = disabled
-  ))
+  message <- dropNulls(list(label=label, icon=icon))
   session$sendInputMessage(inputId, message)
 }
 #' @rdname updateActionButton
 #' @export
-updateActionLink <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL) {
-  updateActionButton(session, inputId = inputId, label = processDeps(label, session), icon = icon)
-}
+updateActionLink <- updateActionButton
 
 
 #' Change the value of a date input on the client
@@ -227,21 +206,14 @@ updateActionLink <- function(session = getDefaultReactiveDomain(), inputId, labe
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateDateInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL,
-                            min = NULL, max = NULL)
-{
-  validate_session_object(session)
+updateDateInput <- function(session, inputId, label = NULL, value = NULL,
+                            min = NULL, max = NULL) {
 
   value <- dateYMD(value, "value")
   min   <- dateYMD(min, "min")
   max   <- dateYMD(max, "max")
 
-  message <- dropNulls(list(
-    label = processDeps(label, session),
-    value = value,
-    min = min,
-    max = max
-  ))
+  message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
 }
 
@@ -279,11 +251,9 @@ updateDateInput <- function(session = getDefaultReactiveDomain(), inputId, label
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateDateRangeInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL,
+updateDateRangeInput <- function(session, inputId, label = NULL,
                                  start = NULL, end = NULL, min = NULL,
-                                 max = NULL)
-{
-  validate_session_object(session)
+                                 max = NULL) {
 
   start <- dateYMD(start, "start")
   end <- dateYMD(end, "end")
@@ -291,7 +261,7 @@ updateDateRangeInput <- function(session = getDefaultReactiveDomain(), inputId,
   max <- dateYMD(max, "max")
 
   message <- dropNulls(list(
-    label = processDeps(label, session),
+    label = label,
     value = dropNulls(list(start = start, end = end)),
     min = min,
     max = max
@@ -303,7 +273,7 @@ updateDateRangeInput <- function(session = getDefaultReactiveDomain(), inputId,
 #' Change the selected tab on the client
 #'
 #' @param session The `session` object passed to function given to
-#'   `shinyServer`. Default is `getDefaultReactiveDomain()`.
+#'   `shinyServer`.
 #' @param inputId The id of the `tabsetPanel`, `navlistPanel`,
 #' or `navbarPage` object.
 #' @inheritParams tabsetPanel
@@ -339,9 +309,7 @@ updateDateRangeInput <- function(session = getDefaultReactiveDomain(), inputId,
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateTabsetPanel <- function(session = getDefaultReactiveDomain(), inputId, selected = NULL) {
-  validate_session_object(session)
-
+updateTabsetPanel <- function(session, inputId, selected = NULL) {
   message <- dropNulls(list(value = selected))
   session$sendInputMessage(inputId, message)
 }
@@ -389,17 +357,12 @@ updateNavlistPanel <- updateTabsetPanel
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateNumericInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL,
-  min = NULL, max = NULL, step = NULL) {
-
-  validate_session_object(session)
+updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
+    min = NULL, max = NULL, step = NULL) {
 
   message <- dropNulls(list(
-    label = processDeps(label, session),
-    value = formatNoSci(value),
-    min = formatNoSci(min),
-    max = formatNoSci(max),
-    step = formatNoSci(step)
+    label = label, value = formatNoSci(value),
+    min = formatNoSci(min), max = formatNoSci(max), step = formatNoSci(step)
   ))
   session$sendInputMessage(inputId, message)
 }
@@ -441,28 +404,9 @@ updateNumericInput <- function(session = getDefaultReactiveDomain(), inputId, la
 #'   )
 #' }
 #' @export
-updateSliderInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL,
+updateSliderInput <- function(session, 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)
@@ -479,7 +423,7 @@ updateSliderInput <- function(session = getDefaultReactiveDomain(), inputId, lab
   }
 
   message <- dropNulls(list(
-    label = processDeps(label, session),
+    label = label,
     value = formatNoSci(value),
     min = formatNoSci(min),
     max = formatNoSci(max),
@@ -495,8 +439,6 @@ updateSliderInput <- function(session = getDefaultReactiveDomain(), inputId, lab
 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)
@@ -510,11 +452,7 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
     ))
   }
 
-  message <- dropNulls(list(
-    label = processDeps(label, session), 
-    options = options, 
-    value = selected
-  ))
+  message <- dropNulls(list(label = label, options = options, value = selected))
 
   session$sendInputMessage(inputId, message)
 }
@@ -558,12 +496,9 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateCheckboxGroupInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL,
+updateCheckboxGroupInput <- function(session, inputId, label = NULL,
   choices = NULL, selected = NULL, inline = FALSE,
-  choiceNames = NULL, choiceValues = NULL)
-{
-  validate_session_object(session)
-
+  choiceNames = NULL, choiceValues = NULL) {
   updateInputOptions(session, inputId, label, choices, selected,
                      inline, "checkbox", choiceNames, choiceValues)
 }
@@ -604,12 +539,9 @@ updateCheckboxGroupInput <- function(session = getDefaultReactiveDomain(), input
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateRadioButtons <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, choices = NULL,
+updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
                                selected = NULL, inline = FALSE,
-                               choiceNames = NULL, choiceValues = NULL)
-{
-  validate_session_object(session)
-
+                               choiceNames = NULL, choiceValues = NULL) {
   # you must select at least one radio button
   if (is.null(selected)) {
     if (!is.null(choices)) selected <- choices[[1]]
@@ -659,19 +591,12 @@ updateRadioButtons <- function(session = getDefaultReactiveDomain(), inputId, la
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateSelectInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, choices = NULL,
-                              selected = NULL)
-{
-  validate_session_object(session)
-
+updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
+                              selected = NULL) {
   choices <- if (!is.null(choices)) choicesWithNames(choices)
   if (!is.null(selected)) selected <- as.character(selected)
   options <- if (!is.null(choices)) selectOptions(choices, selected, inputId, FALSE)
-  message <- dropNulls(list(
-    label = processDeps(label, session), 
-    options = options, 
-    value = selected
-  ))
+  message <- dropNulls(list(label = label, options = options, value = selected))
   session$sendInputMessage(inputId, message)
 }
 
@@ -682,12 +607,9 @@ updateSelectInput <- function(session = getDefaultReactiveDomain(), inputId, lab
 #'   `choices` into the page at once (i.e., only use the client-side
 #'   version of \pkg{selectize.js})
 #' @export
-updateSelectizeInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, choices = NULL,
+updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
                                  selected = NULL, options = list(),
-                                 server = FALSE)
-{
-  validate_session_object(session)
-
+                                 server = FALSE) {
   if (length(options)) {
     res <- checkAsIs(options)
     cfg <- tags$script(
@@ -800,15 +722,12 @@ updateSelectizeInput <- function(session = getDefaultReactiveDomain(), inputId,
 #' @rdname updateSelectInput
 #' @inheritParams varSelectInput
 #' @export
-updateVarSelectInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, data = NULL, selected = NULL) {
-  validate_session_object(session)
-
+updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL) {
   if (is.null(data)) {
     choices <- NULL
   } else {
     choices <- colnames(data)
   }
-
   updateSelectInput(
     session = session,
     inputId = inputId,
@@ -819,11 +738,7 @@ updateVarSelectInput <- function(session = getDefaultReactiveDomain(), inputId,
 }
 #' @rdname updateSelectInput
 #' @export
-updateVarSelectizeInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL,
-                                    data = NULL, selected = NULL, options = list(), server = FALSE)
-{
-  validate_session_object(session)
-
+updateVarSelectizeInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL, options = list(), server = FALSE) {
   if (is.null(data)) {
     choices <- NULL
   } else {

R/utils-lang.R

@@ -1,249 +0,0 @@
-# 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 [`rlang::enquo0()`] to not unquote
-#'   the object too early. See [`rlang::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,11 +2,6 @@
 #' @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
@@ -118,6 +113,24 @@ 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))]
@@ -131,6 +144,34 @@ 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) {
@@ -141,16 +182,12 @@ 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 (any_unnamed(a) || any_unnamed(b)) {
+  if (anyUnnamed(a) || anyUnnamed(b)) {
     stop("Vectors must be either NULL or have names for all elements")
   }
 
@@ -162,27 +199,15 @@ 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, method = "auto") {
-  if (any_unnamed(x))
+sortByName <- function(x) {
+  if (anyUnnamed(x))
     stop("All items must be named")
 
   # Special case for empty vectors/lists, and NULL
   if (length(x) == 0)
     return(x)
 
-  # 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)]
+  x[order(names(x))]
 }
 
 # Sort a vector. If a character vector, sort using C locale, which is consistent
@@ -195,7 +220,6 @@ 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.
@@ -393,6 +417,120 @@ 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.
@@ -484,7 +622,7 @@ shinyCallingHandlers <- function(expr) {
   withCallingHandlers(captureStackTraces(expr),
     error = function(e) {
       # Don't intercept shiny.silent.error (i.e. validation errors)
-      if (cnd_inherits(e, "shiny.silent.error"))
+      if (inherits(e, "shiny.silent.error"))
         return()
 
       handle <- getOption('shiny.error')
@@ -493,6 +631,38 @@ 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
@@ -770,45 +940,22 @@ formatNoSci <- function(x) {
   format(x, scientific = FALSE, digits = 15)
 }
 
-# A simple getter/setting to track the last time the auto-reload process
-# updated. This value is used by `cachedFuncWithFile()` when auto-reload is
-# enabled to reload app/ui/server files when watched supporting files change.
-cachedAutoReloadLastChanged <- local({
-  last_update <- 0
-
-  list(
-    set = function() {
-      last_update <<- as.integer(Sys.time())
-      invisible(last_update)
-    },
-    get = function() {
-      last_update
-    }
-  )
-})
-
 # Returns a function that calls the given func and caches the result for
 # subsequent calls, unless the given file's mtime changes.
 cachedFuncWithFile <- function(dir, file, func, case.sensitive = FALSE) {
-  dir <- normalizePath(dir, mustWork = TRUE)
-
+  dir <- normalizePath(dir, mustWork=TRUE)
+  mtime <- NA
   value <- NULL
-  last_mtime_file <- NA
-  last_autoreload <- 0
-
   function(...) {
-    fname <- if (case.sensitive) { 
-      file.path(dir, file) 
-    } else {
+    fname <- if (case.sensitive)
+      file.path(dir, file)
+    else
       file.path.ci(dir, file)
-    }
 
     now <- file.info(fname)$mtime
-    autoreload <- last_autoreload < cachedAutoReloadLastChanged$get()
-    if (autoreload || !identical(last_mtime_file, now)) {
+    if (!identical(mtime, now)) {
       value <<- func(fname, ...)
-      last_mtime_file <<- now
-      last_autoreload <<- cachedAutoReloadLastChanged$get()
+      mtime <<- now
     }
     value
   }
@@ -964,39 +1111,52 @@ reactiveStop <- function(message = "", class = NULL) {
 
 #' Validate input values and other conditions
 #'
-#' @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.
+#' 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.
 #'
-#' If you use `validate()` in a [reactive()] validation failures will
-#' automatically propagate to outputs that use the reactive.
+#' 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.
 #'
-#' @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.
+#' 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:
 #'
-#' 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")
+#' \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 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
@@ -1011,7 +1171,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #'
 #' ui <- fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
-#'   selectizeInput('in2', 'Select a state', choices = c("", state.name)),
+#'   selectizeInput('in2', 'Select a state', choices = state.name),
 #'   plotOutput('plot')
 #' )
 #'
@@ -1029,7 +1189,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #'
 #' }
 validate <- function(..., errorClass = character(0)) {
-  results <- sapply(list2(...), function(x) {
+  results <- sapply(list(...), function(x) {
     # Detect NULL or NA
     if (is.null(x))
       return(NA_character_)
@@ -1073,7 +1233,7 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 
 #' Check for required values
 #'
-#' Ensure that values are available (["truthy"][isTruthy]) before proceeding
+#' Ensure that values are available ("truthy"--see Details) before proceeding
 #' with a calculation or action. If any of the given values is not truthy, the
 #' operation is stopped by raising a "silent" exception (not logged by Shiny,
 #' nor displayed in the Shiny app's UI).
@@ -1082,13 +1242,11 @@ 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:
 #'
-#' ```
-#' rv <- reactiveValues(state = FALSE)
+#' \preformatted{rv <- reactiveValues(state = FALSE)
 #' r <- reactive({
 #'   req(input$a, input$b, rv$state)
 #'   # Code that uses input$a, input$b, and/or rv$state...
-#' })
-#' ```
+#' })}
 #'
 #' In this example, if `r()` is called and any of `input$a`,
 #' `input$b`, and `rv$state` are `NULL`, `FALSE`, `""`,
@@ -1097,29 +1255,62 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #'
 #' The second is to use it to wrap an expression that must be truthy:
 #'
-#' ```
-#' output$plot <- renderPlot({
+#' \preformatted{output$plot <- renderPlot({
 #'   if (req(input$plotType) == "histogram") {
 #'     hist(dataset())
 #'   } else if (input$plotType == "scatter") {
 #'     qplot(dataset(), aes(x = x, y = y))
 #'   }
-#' })
-#' ```
+#' })}
 #'
 #' In this example, `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.
 #'
-#' @section Using `req(FALSE)`:
+#' **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)`**
 #'
 #' 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 advantage to this, except perhaps ease of readability
+#' chain now. There is no advantange to this, except perhaps ease of readibility
 #' if you have a complicated condition to check for (or perhaps if you'd like to
 #' divide your condition into nested `if` statements).
 #'
-#' @section Using `cancelOutput = TRUE`:
+#' **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
@@ -1137,10 +1328,8 @@ 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. 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.
+#'   whatever state it happens to be in.
+#' @param x An expression whose truthiness value we want to determine
 #' @return The first value that was passed in.
 #' @export
 #' @examples
@@ -1172,8 +1361,6 @@ 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")
       }
@@ -1232,47 +1419,23 @@ cancelOutput <- function() {
 #
 # Can be used to facilitate short-circuit eval on dots.
 dotloop <- function(fun_, ...) {
-  for (i in seq_len(nargs() - 1)) {
+  for (i in 1:(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 (is.null(x))
-    return(FALSE)
   if (inherits(x, 'try-error'))
     return(FALSE)
+
   if (!is.atomic(x))
     return(TRUE)
+
+  if (is.null(x))
+    return(FALSE)
   if (length(x) == 0)
     return(FALSE)
   if (all(is.na(x)))
@@ -1340,7 +1503,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 ',
-            'https://shiny.rstudio.com/articles/unicode.html for more info.')
+            'http://shiny.rstudio.com/articles/unicode.html for more info.')
     return('UTF-8-BOM')
   }
   x <- readChar(file, size, useBytes = TRUE)
@@ -1424,19 +1587,14 @@ URLencode <- function(value, reserved = FALSE) {
   if (reserved) encodeURIComponent(value) else encodeURI(value)
 }
 
-# Make sure user-supplied dates are either NULL or can be coerced to a
-# yyyy-mm-dd formatted string. If a date is specified, this function returns a
-# string for consistency across locales. Also, `as.Date()` is used to coerce
-# strings to date objects so that strings like "2016-08-9" are expanded to
-# "2016-08-09". If any of the values result in error or NA, then the input
-# `date` is returned unchanged.
+# Make user-supplied dates are either NULL or can be coerced
+# to a yyyy-mm-dd formatted string. If a date is specified, this
+# function returns a string for consistency across locales.
+# Also, `as.Date()` is used to coerce strings to date objects
+# so that strings like "2016-08-9" are expanded to "2016-08-09"
 dateYMD <- function(date = NULL, argName = "value") {
   if (!length(date)) return(NULL)
-  tryCatch({
-      res <- format(as.Date(date), "%Y-%m-%d")
-      if (any(is.na(res))) stop()
-      date <- res
-    },
+  tryCatch(date <- format(as.Date(date), "%Y-%m-%d"),
     error = function(e) {
       warning(
         "Couldn't coerce the `", argName,
@@ -1452,40 +1610,25 @@ 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, dots = TRUE) {
+wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
   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)
 
-  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())
-  }
+  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))
+  ))
 
-  # Preserve the original function that was passed in; is used for caching.
-  attr(relabelWrapper, "wrappedFunc") <- func
   relabelWrapper
 }
 
@@ -1545,23 +1688,19 @@ 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(valueWithVisible(result), ..., catch = catch, finally = finally)
+            p <- promise_chain(setVisible(result), ..., catch = catch, finally = finally)
             runFinally <- FALSE
             p
           } else {
-            result <- Reduce(
-              function(v, func) {
-                if (v$visible) {
-                  withVisible(func(v$value))
-                } else {
-                  withVisible(func(invisible(v$value)))
-                }
-              },
-              list(...),
-              result
-            )
+            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)
 
-            valueWithVisible(result)
+            setVisible(result)
           }
         })
       },
@@ -1582,12 +1721,23 @@ hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
   }
 }
 
-# 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)
-}
+# Returns `value` with either `invisible()` applied or not, depending on the
+# value of `visible`.
+#
+# If the `visible` is missing, then `value` should be a list as returned from
+# `withVisible()`, and that visibility will be applied.
+setVisible <- function(value, visible) {
+  if (missing(visible)) {
+    visible <- value$visible
+    value <- value$value
+  }
 
+  if (!visible) {
+    invisible(value)
+  } else {
+    (value)
+  }
+}
 
 createVarPromiseDomain <- function(env, name, value) {
   force(env)
@@ -1632,10 +1782,7 @@ getSliderType <- function(min, max, value) {
     else                            "number"
   }))
   if (length(type) > 1) {
-    rlang::abort(c(
-      "Type mismatch for `min`, `max`, and `value`.",
-      "All values must either be numeric, Date, or POSIXt."
-    ))
+    stop("Type mismatch for `min`, `max`, and `value`. Each must be Date, POSIXt, or number.")
   }
   type[[1]]
 }
@@ -1736,20 +1883,12 @@ findEnclosingApp <- function(path = ".") {
   }
 }
 
-# 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
+# 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)
   }
-
-  FALSE
+  installed && isTRUE(utils::packageVersion(package) >= version)
 }

R/version_bs_date_picker.R

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

R/version_ion_range_slider.R

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

R/version_jquery.R

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

R/version_jqueryui.R

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

R/version_selectize.R

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