chore(license): Change license from GPL-3 to MIT (#4339)

* Change license from GPL-3 to MIT

Updated the project license from GPL-3 to MIT in DESCRIPTION, LICENSE, LICENSE.md, README.md, and package.json. Added LICENSE.md with the MIT license text and updated .Rbuildignore to exclude LICENSE.md from builds.

* `npm run build` (GitHub Actions)

* Update LICENSE and add LICENSE.note

Replaced the LICENSE file content with a summary including year and copyright holder. Moved detailed third-party license information to a new LICENSE.note file.

* Remove R check log file

Deleted the ..Rcheck/00check.log file, likely to clean up generated or temporary files from the repository.

.Rbuildignore

@@ -12,7 +12,7 @@
 ^\.travis\.yml$
 ^staticdocs$
 ^tools$
-^srcjs$
+^srcts$
 ^CONTRIBUTING.md$
 ^cran-comments.md$
 ^.*\.o$
@@ -21,3 +21,17 @@
 ^TODO-promises.md$
 ^manualtests$
 ^\.github$
+^\.vscode$
+^\.madgerc$
+^package\.json$
+^tsconfig\.json$
+^package-lock\.json$
+^node_modules$
+^coverage$
+^.ignore$
+^eslint\.config\.mjs$
+^_dev$
+^.claude$
+^README-npm\.md$
+^CRAN-SUBMISSION$
+^LICENSE\.md$

.gitattributes

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

.github/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://community.rstudio.com/c/shiny.
+about : The issue tracker is not for questions -- please ask questions at https://forum.posit.co/tags/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.
+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.
 

.github/shiny-workflows/routine.sh

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

.github/workflows/rituals.yaml

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

.gitignore

@@ -9,7 +9,16 @@
 shinyapps/
 README.html
 .*.Rnb.cached
-tools/yarn-error.log
+/_dev/
+.sass_cache_keys
+
+# TypeScript
+/node_modules/
+.cache
+coverage/
+madge.svg
+
 
 # GHA remotes installation
 .github/r-depends.rds
+.claude/settings.local.json

.madgerc

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

.vscode/extensions.json

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

.vscode/settings.json

@@ -0,0 +1,23 @@
+{
+  "search.exclude": {
+  },
+  "prettier.prettierPath": "./node_modules/prettier",
+  "typescript.enablePromptUseWorkspaceTsdk": true,
+  "[r]": {
+    "files.trimTrailingWhitespace": true,
+    "files.insertFinalNewline": true,
+    "editor.formatOnSave": false,
+  },
+  "[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,
+},
+}

DESCRIPTION

@@ -1,120 +1,130 @@
-Package: shiny
 Type: Package
+Package: shiny
 Title: Web Application Framework for R
-Version: 1.6.0.9000
+Version: 1.12.1.9000
 Authors@R: c(
-    person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
-    person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
-    person("JJ", "Allaire", role = "aut", email = "jj@rstudio.com"),
-    person("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("Winston", "Chang", , "winston@posit.co", role = "aut",
+           comment = c(ORCID = "0000-0002-1576-2126")),
+    person("Joe", "Cheng", , "joe@posit.co", role = "aut"),
+    person("JJ", "Allaire", , "jj@posit.co", role = "aut"),
+    person("Carson", "Sievert", , "carson@posit.co", role = c("aut", "cre"),
+           comment = c(ORCID = "0000-0002-4958-2844")),
+    person("Barret", "Schloerke", , "barret@posit.co", role = "aut",
+           comment = c(ORCID = "0000-0001-9986-114X")),
+    person("Garrick", "Aden-Buie", , "garrick@adenbuie.com", role = "aut",
+           comment = c(ORCID = "0000-0002-7111-0077")),
+    person("Yihui", "Xie", , "yihui@posit.co", role = "aut"),
+    person("Jeff", "Allen", role = "aut"),
+    person("Jonathan", "McPherson", , "jonathan@posit.co", role = "aut"),
     person("Alan", "Dipert", role = "aut"),
     person("Barbara", "Borges", role = "aut"),
-    person(family = "RStudio", role = "cph"),
-    person(family = "jQuery Foundation", role = "cph",
-    comment = "jQuery library and jQuery UI library"),
-    person(family = "jQuery contributors", role = c("ctb", "cph"),
-    comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
-    person(family = "jQuery UI contributors", role = c("ctb", "cph"),
-    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
+    person("Posit Software, PBC", role = c("cph", "fnd"),
+           comment = c(ROR = "03wc8by49")),
+    person(, "jQuery Foundation", role = "cph",
+           comment = "jQuery library and jQuery UI library"),
+    person(, "jQuery contributors", role = c("ctb", "cph"),
+           comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
+    person(, "jQuery UI contributors", role = c("ctb", "cph"),
+           comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
     person("Mark", "Otto", role = "ctb",
-    comment = "Bootstrap library"),
+           comment = "Bootstrap library"),
     person("Jacob", "Thornton", role = "ctb",
-    comment = "Bootstrap library"),
-    person(family = "Bootstrap contributors", role = "ctb",
-    comment = "Bootstrap library"),
-    person(family = "Twitter, Inc", role = "cph",
-    comment = "Bootstrap library"),
+           comment = "Bootstrap library"),
+    person(, "Bootstrap contributors", role = "ctb",
+           comment = "Bootstrap library"),
+    person(, "Twitter, Inc", role = "cph",
+           comment = "Bootstrap library"),
     person("Prem Nawaz", "Khan", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
+           comment = "Bootstrap accessibility plugin"),
     person("Victor", "Tsaran", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
+           comment = "Bootstrap accessibility plugin"),
     person("Dennis", "Lembree", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
+           comment = "Bootstrap accessibility plugin"),
     person("Srinivasu", "Chakravarthula", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
+           comment = "Bootstrap accessibility plugin"),
     person("Cathy", "O'Connor", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
-    person(family = "PayPal, Inc", role = "cph",
-    comment = "Bootstrap accessibility plugin"),
+           comment = "Bootstrap accessibility plugin"),
+    person(, "PayPal, Inc", role = "cph",
+           comment = "Bootstrap accessibility plugin"),
     person("Stefan", "Petre", role = c("ctb", "cph"),
-    comment = "Bootstrap-datepicker library"),
+           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"),
+           comment = "Bootstrap-datepicker library"),
     person("Brian", "Reavis", role = c("ctb", "cph"),
-    comment = "selectize.js library"),
+           comment = "selectize.js library"),
     person("Salmen", "Bejaoui", role = c("ctb", "cph"),
-    comment = "selectize-plugin-a11y library"),
+           comment = "selectize-plugin-a11y library"),
     person("Denis", "Ineshin", role = c("ctb", "cph"),
-    comment = "ion.rangeSlider library"),
+           comment = "ion.rangeSlider library"),
     person("Sami", "Samhuri", role = c("ctb", "cph"),
-    comment = "Javascript strftime library"),
-    person(family = "SpryMedia Limited", role = c("ctb", "cph"),
-    comment = "DataTables library"),
-    person("John", "Fraser", role = c("ctb", "cph"),
-    comment = "showdown.js library"),
-    person("John", "Gruber", role = c("ctb", "cph"),
-    comment = "showdown.js library"),
+           comment = "Javascript strftime library"),
+    person(, "SpryMedia Limited", role = c("ctb", "cph"),
+           comment = "DataTables library"),
     person("Ivan", "Sagalaev", role = c("ctb", "cph"),
-    comment = "highlight.js library"),
-    person(family = "R Core Team", role = c("ctb", "cph"),
-    comment = "tar implementation from R")
-    )
+           comment = "highlight.js library"),
+    person("R Core Team", role = c("ctb", "cph"),
+           comment = "tar implementation from R")
+  )
 Description: Makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
     outputs and extensive prebuilt widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
-License: GPL-3 | file LICENSE
-Depends:
-    R (>= 3.0.2),
-    methods
-Imports:
-    utils,
-    grDevices,
-    httpuv (>= 1.5.2),
-    mime (>= 0.3),
-    jsonlite (>= 0.9.16),
-    xtable,
-    htmltools (>= 0.5.0.9001),
-    R6 (>= 2.0),
-    sourcetools,
-    later (>= 1.0.0),
-    promises (>= 1.1.0),
-    tools,
-    crayon,
-    rlang (>= 0.4.10),
-    fastmap (>= 1.0.0),
-    withr,
-    commonmark (>= 1.7),
-    glue (>= 1.3.2),
-    bslib (>= 0.2.2.9002),
-    cachem,
-    ellipsis,
-    lifecycle (>= 0.2.0)
-Suggests:
-    datasets,
-    Cairo (>= 1.5-5),
-    testthat (>= 3.0.0),
-    knitr (>= 1.6),
-    markdown,
-    rmarkdown,
-    ggplot2,
-    reactlog (>= 1.0.0),
-    magrittr,
-    shinytest (>= 1.4.0.9003),
-    yaml,
-    future,
-    dygraphs,
-    ragg,
-    showtext,
-    sass
-URL: https://shiny.rstudio.com/
+License: MIT + file LICENSE
+URL: https://shiny.posit.co/, https://github.com/rstudio/shiny
 BugReports: https://github.com/rstudio/shiny/issues
+Depends:
+    methods,
+    R (>= 3.0.2)
+Imports:
+    bslib (>= 0.6.0),
+    cachem (>= 1.1.0),
+    cli,
+    commonmark (>= 2.0.0),
+    fastmap (>= 1.1.1),
+    fontawesome (>= 0.4.0),
+    glue (>= 1.3.2),
+    grDevices,
+    htmltools (>= 0.5.4),
+    httpuv (>= 1.5.2),
+    jsonlite (>= 0.9.16),
+    later (>= 1.0.0),
+    lifecycle (>= 0.2.0),
+    mime (>= 0.3),
+    otel,
+    promises (>= 1.5.0),
+    R6 (>= 2.0),
+    rlang (>= 0.4.10),
+    sourcetools,
+    tools,
+    utils,
+    withr,
+    xtable
+Suggests:
+    Cairo (>= 1.5-5),
+    coro (>= 1.1.0),
+    datasets,
+    DT,
+    dygraphs,
+    future,
+    ggplot2,
+    knitr (>= 1.6),
+    magrittr,
+    markdown,
+    mirai,
+    otelsdk (>= 0.2.0),
+    ragg,
+    reactlog (>= 1.0.0),
+    rmarkdown,
+    sass,
+    showtext,
+    testthat (>= 3.2.1),
+    watcher,
+    yaml
+Config/Needs/check: shinytest2
+Config/testthat/edition: 3
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.3
 Collate:
     'globals.R'
     'app-state.R'
@@ -122,7 +132,6 @@ Collate:
     'bind-cache.R'
     'bind-event.R'
     'bookmark-state-local.R'
-    'stack.R'
     'bookmark-state.R'
     'bootstrap-deprecated.R'
     'bootstrap-layout.R'
@@ -130,12 +139,14 @@ Collate:
     'map.R'
     'utils.R'
     'bootstrap.R'
+    'busy-indicators-spinners.R'
+    'busy-indicators.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'
@@ -172,6 +183,15 @@ Collate:
     'modal.R'
     'modules.R'
     'notifications.R'
+    'otel-attr-srcref.R'
+    'otel-collect.R'
+    'otel-enable.R'
+    'otel-error.R'
+    'otel-label.R'
+    'otel-reactive-update.R'
+    'otel-session.R'
+    'otel-shiny.R'
+    'otel-with.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
@@ -192,15 +212,18 @@ Collate:
     'shinywrappers.R'
     'showcase.R'
     'snapshot.R'
+    'staticimports.R'
     'tar.R'
     'test-export.R'
     'test-server.R'
     'test.R'
     'update-input.R'
     'utils-lang.R'
+    'utils-tags.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.1.1
-Encoding: UTF-8
-Roxygen: list(markdown = TRUE)
-RdMacros: lifecycle
-Config/testthat/edition: 3

LICENSE.md

@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2025 shiny authors
+
+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.

NAMESPACE

@@ -19,6 +19,7 @@ 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)
@@ -43,6 +44,7 @@ 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)
@@ -53,6 +55,7 @@ S3method(str,reactivevalues)
 export("conditionStackTrace<-")
 export(..stacktraceoff..)
 export(..stacktraceon..)
+export(ExtendedTask)
 export(HTML)
 export(MockShinySession)
 export(NS)
@@ -75,6 +78,7 @@ export(br)
 export(browserViewer)
 export(brushOpts)
 export(brushedPoints)
+export(busyIndicatorOptions)
 export(callModule)
 export(captureStackTraces)
 export(checkboxGroupInput)
@@ -103,7 +107,6 @@ export(enableBookmarking)
 export(eventReactive)
 export(exportTestValues)
 export(exprToFunction)
-export(extractStackTrace)
 export(fileInput)
 export(fillCol)
 export(fillPage)
@@ -114,7 +117,6 @@ export(fixedRow)
 export(flowLayout)
 export(fluidPage)
 export(fluidRow)
-export(formatStackTrace)
 export(freezeReactiveVal)
 export(freezeReactiveValue)
 export(getCurrentOutputInfo)
@@ -163,6 +165,7 @@ export(isTruthy)
 export(isolate)
 export(key_missing)
 export(loadSupport)
+export(localOtelCollect)
 export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
@@ -190,6 +193,7 @@ export(onRestore)
 export(onRestored)
 export(onSessionEnded)
 export(onStop)
+export(onUnhandledError)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -207,21 +211,18 @@ 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,7 +265,6 @@ export(shinyUI)
 export(showBookmarkUrlModal)
 export(showModal)
 export(showNotification)
-export(showReactLog)
 export(showTab)
 export(sidebarLayout)
 export(sidebarPanel)
@@ -320,6 +320,7 @@ export(updateTextInput)
 export(updateVarSelectInput)
 export(updateVarSelectizeInput)
 export(urlModal)
+export(useBusyIndicators)
 export(validate)
 export(validateCssUnit)
 export(varSelectInput)
@@ -329,6 +330,7 @@ export(verticalLayout)
 export(wellPanel)
 export(withLogErrors)
 export(withMathJax)
+export(withOtelCollect)
 export(withProgress)
 export(withReactiveDomain)
 export(withTags)
@@ -339,8 +341,6 @@ import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
-importFrom(ellipsis,check_dots_empty)
-importFrom(ellipsis,check_dots_unnamed)
 importFrom(fastmap,fastmap)
 importFrom(fastmap,is.key_missing)
 importFrom(fastmap,key_missing)
@@ -385,22 +385,32 @@ 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,hybrid_then)
+importFrom(promises,is.promise)
 importFrom(promises,is.promising)
-importFrom(promises,promise)
+importFrom(promises,new_promise_domain)
 importFrom(promises,promise_reject)
 importFrom(promises,promise_resolve)
+importFrom(promises,with_promise_domain)
 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)
@@ -408,10 +418,15 @@ 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,8 +10,7 @@
 #' 2: app.R              : Main application file
 #' 3: R/example.R        : Helper file with R code
 #' 4: R/example-module.R : Example module
-#' 5: tests/shinytest/   : Tests using the shinytest package
-#' 6: tests/testthat/    : Tests using the testthat package
+#' 5: tests/testthat/    : Tests using the testthat and shinytest2 package
 #' ```
 #'
 #' If option 1 is selected, the full example application including the
@@ -24,13 +23,12 @@
 #' |   |- example-module.R
 #' |   `- example.R
 #' `- tests
-#'     |- shinytest.R
-#'     |- shinytest
-#'     |   `- mytest.R
 #'     |- testthat.R
 #'     `- testthat
+#'         |- setup-shinytest2.R
 #'         |- test-examplemodule.R
 #'         |- test-server.R
+#'         |- test-shinytest2.R
 #'         `- test-sort.R
 #' ```
 #'
@@ -45,20 +43,21 @@
 #' * `tests/` contains various tests for the application. You may
 #'   choose to use or remove any of them. They can be executed by the
 #'   [runTests()] function.
-#' * `tests/shinytest.R` is a test runner for test files in the
-#'   `tests/shinytest/` directory.
-#' * `tests/shinytest/mytest.R` is a test that uses the
-#'   [shinytest](https://rstudio.github.io/shinytest/) package to do
-#'   snapshot-based testing.
 #' * `tests/testthat.R` is a test runner for test files in the
-#'   `tests/testthat/` directory using the [testthat](https://testthat.r-lib.org/) package.
+#'   `tests/testthat/` directory using the
+#'   [shinytest2](https://rstudio.github.io/shinytest2/reference/test_app.html)
+#'   package.
+#' * `tests/testthat/setup-shinytest2.R` is setup file to source your `./R` folder into the testing environment.
 #' * `tests/testthat/test-examplemodule.R` is a test for an application's module server function.
 #' * `tests/testthat/test-server.R` is a test for the application's server code
+#' * `tests/testthat/test-shinytest2.R` is a test that uses the
+#'   [shinytest2](https://rstudio.github.io/shinytest2/) package to do
+#'   snapshot-based testing.
 #' * `tests/testthat/test-sort.R` is a test for a supporting function in the `R/` directory.
 #'
 #' @param path Path to create new shiny application template.
 #' @param examples Either one of "default", "ask", "all", or any combination of
-#'   "app", "rdir", "module", "shinytest", and "testthat". In an
+#'   "app", "rdir", "module", and "tests". In an
 #'   interactive session, "default" falls back to "ask"; in a non-interactive
 #'   session, "default" falls back to "all". With "ask", this function will
 #'   prompt the user to select which template items will be added to the new app
@@ -79,15 +78,19 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
   # =======================================================
 
   choices <- c(
-    app       = "app.R              : Main application file",
-    rdir      = "R/example.R        : Helper file with R code",
-    module    = "R/example-module.R : Example module",
-    shinytest = "tests/shinytest/   : Tests using the shinytest package",
-    testthat  = "tests/testthat/    : Tests using the testthat package"
+    app    = "app.R              : Main application file",
+    rdir   = "R/example.R        : Helper file with R code",
+    module = "R/example-module.R : Example module",
+    tests  = "tests/testthat/    : Tests using {testthat} and {shinytest2}"
   )
 
+  # Support legacy value
+  examples[examples == "shinytest"] <- "tests"
+  examples[examples == "testthat"] <- "tests"
+  examples <- unique(examples)
+
   if (identical(examples, "default")) {
-    if (interactive()) {
+    if (rlang::is_interactive()) {
       examples <- "ask"
     } else {
       examples <- "all"
@@ -124,18 +127,8 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
     return(invisible())
   }
 
-  if ("shinytest" %in% examples) {
-    if (!is_available("shinytest", "1.4.0"))
-    {
-      message(
-        "The tests/shinytest directory needs shinytest 1.4.0 or later to work properly."
-      )
-      if (is_available("shinytest")) {
-        message("You currently have shinytest ",
-                utils::packageVersion("shinytest"), " installed.")
-      }
-
-    }
+  if ("tests" %in% examples) {
+    rlang::check_installed("shinytest2", "for {testthat} tests to work as expected", version = "0.2.0")
   }
 
   # =======================================================
@@ -152,7 +145,7 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
 
   # Helper to resolve paths relative to our template
   template_path <- function(...) {
-    system.file("app_template", ..., package = "shiny")
+    system_file("app_template", ..., package = "shiny")
   }
 
   # Resolve path relative to destination
@@ -208,16 +201,13 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
   }
 
   # Copy the files for a tests/ subdirectory
-  copy_test_dir <- function(name) {
+  copy_test_dir <- function() {
     files <- dir(template_path("tests"), recursive = TRUE)
-    # Note: This is not the same as using dir(pattern = "^shinytest"), since
-    # that will not match files inside of shinytest/.
-    files <- files[grepl(paste0("^", name), files)]
 
     # Filter out files that are not module files in the R directory.
     if (! "rdir" %in% examples) {
       # find all files in the testthat folder that are not module or server files
-      is_r_folder_file <- (!grepl("module|server", basename(files))) & (dirname(files) == "testthat")
+      is_r_folder_file <- !grepl("module|server|shinytest2|testthat", basename(files))
       files <- files[!is_r_folder_file]
     }
 
@@ -282,12 +272,10 @@ shinyAppTemplate <- function(path = NULL, examples = "default", dryrun = FALSE)
     copy_file(file.path("R", module_files))
   }
 
-  # tests/ dir
-  if ("shinytest" %in% examples) {
-    copy_test_dir("shinytest")
-  }
-  if ("testthat" %in% examples) {
-    copy_test_dir("testthat")
+  # tests/testthat dir
+  if ("tests" %in% examples) {
+    copy_test_dir()
   }
+
   invisible()
 }

R/bind-cache.R

@@ -159,8 +159,8 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'   ```
 #'
 #'   To use different settings for a session-scoped cache, you can set
-#'   `self$cache` at the top of your server function. By default, it will create
-#'   a 200 MB memory cache for each session, but you can replace it with
+#'   `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:
@@ -177,7 +177,7 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'   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"))
+#'   shinyOptions(cache = cachem::cache_disk(file.path(dirname(tempdir()), "myapp-cache")))
 #'   ```
 #'
 #'   This will create a subdirectory in your system temp directory named
@@ -231,8 +231,8 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'   promises, but rather objects provided by the
 #'   \href{https://rstudio.github.io/promises/}{\pkg{promises}}  package, which
 #'   are similar to promises in JavaScript. (See [promises::promise()] for more
-#'   information.) You can also use [future::future()] objects to run code in a
-#'   separate process or even on a remote machine.
+#'   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.
@@ -255,7 +255,7 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'   the cache.
 #'
 #'   You may need to provide a `cacheHint` to [createRenderFunction()] (or
-#'   [htmlwidgets::shinyRenderWidget()], if you've authored an htmlwidget) in
+#'   `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:
@@ -292,11 +292,11 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'   In some cases, however, the automatic cache hint inference is not
 #'   sufficient, and it is necessary to provide a cache hint. This is true
 #'   for `renderPrint()`. Unlike `renderText()`, it wraps the user-provided
-#'   expression in another function, before passing it to [markRenderFunction()]
+#'   expression in another function, before passing it to [createRenderFunction()]
 #'   (instead of [createRenderFunction()]). Because the user code is wrapped in
-#'   another function, `markRenderFunction()` is not able to automatically
+#'   another function, `createRenderFunction()` is not able to automatically
 #'   extract the user-provided code and use it in the cache key. Instead,
-#'   `renderPrint` calls `markRenderFunction()`, it explicitly passes along a
+#'   `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
@@ -310,19 +310,19 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'
 #'   ```
 #'   renderMyWidget <- function(expr) {
-#'     expr <- substitute(expr)
+#'     q <- rlang::enquo0(expr)
 #'
-#'     htmlwidgets::shinyRenderWidget(expr,
+#'     htmlwidgets::shinyRenderWidget(
+#'       q,
 #'       myWidgetOutput,
 #'       quoted = TRUE,
-#'       env = parent.frame(),
-#'       cacheHint = list(label = "myWidget", userExpr = expr)
+#'       cacheHint = list(label = "myWidget", userQuo = q)
 #'     )
 #'   }
 #'   ```
 #'
 #'   If your `render` function sets any internal state, you may find it useful
-#'   in your call to [createRenderFunction()] or [markRenderFunction()] to use
+#'   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
@@ -339,8 +339,8 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'   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`.
+#'   For developers of such code, they should call [createRenderFunction()] (or
+#'   [markRenderFunction()]) with `cacheHint = FALSE`.
 #'
 #'
 #' @section Caching with `renderPlot()`:
@@ -453,7 +453,7 @@ utils::globalVariables(".GenericCallEnv", add = TRUE)
 #'       bindEvent(input$go)
 #'       # The cached, eventified reactive takes a reactive dependency on
 #'       # input$go, but doesn't use it for the cache key. It uses input$x and
-#'       # input$y for the cache key, but doesn't take a reactive depdency on
+#'       # 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())
@@ -478,7 +478,12 @@ bindCache.default <- function(x, ...) {
 bindCache.reactiveExpr <- function(x, ..., cache = "app") {
   check_dots_unnamed()
 
-  label <- exprToLabel(substitute(key), "cachedReactive")
+  call_srcref <- get_call_srcref(-1)
+  label <- rassignSrcrefToLabel(
+    call_srcref,
+    defaultLabel = exprToLabel(substitute(x), "cachedReactive")
+  )
+
   domain <- reactive_get_domain(x)
 
   # Convert the ... to a function that returns their evaluated values.
@@ -490,24 +495,37 @@ bindCache.reactiveExpr <- function(x, ..., cache = "app") {
   cacheHint <- rlang::hash(extractCacheHint(x))
   valueFunc <- wrapFunctionLabel(valueFunc, "cachedReactiveValueFunc", ..stacktraceon = TRUE)
 
+  x_classes <- class(x)
+  x_otel_attrs <- attr(x, "observable", exact = TRUE)$.otelAttrs
+
   # 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)
+  if (exists(".GenericCallEnv") && exists(".", envir = .GenericCallEnv, inherits = FALSE)) {
+    rm(list = ".", envir = .GenericCallEnv, inherits = FALSE)
   }
 
-
-  res <- reactive(label = label, domain = domain, {
-    cache <- resolve_cache_object(cache, domain)
-    hybrid_chain(
-      keyFunc(),
-      generateCacheFun(valueFunc, cache, cacheHint, cacheReadHook = identity, cacheWriteHook = identity)
-    )
+  with_no_otel_collect({
+    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))
+
+  local({
+    impl <- attr(res, "observable", exact = TRUE)
+    impl$.otelAttrs <- append_otel_srcref_attrs(x_otel_attrs, call_srcref, fn_name = "bindCache")
+  })
+
+  if (has_otel_collect("reactivity")) {
+    res <- enable_otel_reactive_expr(res)
+  }
   res
 }
 
@@ -534,6 +552,7 @@ bindCache.shiny.render.function <- function(x, ..., cache = "app") {
     )
   }
 
+  # Passes over the otelAttrs from valueFunc to renderFunc
   renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
   class(renderFunc) <- c("shiny.render.function.cache", class(valueFunc))
   renderFunc
@@ -585,7 +604,7 @@ bindCache.shiny.renderPlot <- function(x, ...,
 
     observe({
       doResizeCheck()
-    })
+    }, label = "plot-resize")
     # 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

R/bind-event.R

@@ -196,31 +196,58 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE
   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))
+  call_srcref <- get_call_srcref(-1)
+  if (is.null(label)) {
+    label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = as_default_label(sprintf(
+        'bindEvent(%s, %s)',
+        attr(x, "observable", exact = TRUE)$.label,
+        quos_to_label(qs)
+      ))
+    )
+  }
+
+  x_classes <- class(x)
+  x_otel_attrs <- attr(x, "observable", exact = TRUE)$.otelAttrs
 
   # 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)
+  with_no_otel_collect({
+    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())
         }
-
-        req(!ignoreNULL || !isNullEvent(value))
-
-        isolate(valueFunc())
-      }
-    )
+      )
+    })
   })
 
-  class(res) <- c("reactive.event", class(res))
+  class(res) <- c("reactive.event", x_classes)
+
+  local({
+    impl <- attr(res, "observable", exact = TRUE)
+    impl$.otelAttrs <- append_otel_srcref_attrs(x_otel_attrs, call_srcref, fn_name = "bindEvent")
+  })
+
+
+  if (has_otel_collect("reactivity")) {
+    res <- enable_otel_reactive_expr(res)
+  }
+
   res
 }
 
@@ -249,6 +276,7 @@ bindEvent.shiny.render.function <- function(x, ..., ignoreNULL = TRUE, ignoreIni
     )
   }
 
+  # Passes over the otelAttrs from valueFunc to renderFunc
   renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
   class(renderFunc) <- c("shiny.render.function.event", class(valueFunc))
   renderFunc
@@ -269,7 +297,17 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
 
   # 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))
+  if (is.null(label)) {
+    call_srcref <- get_call_srcref(-1)
+    x$.label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = as_default_label(
+        sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs))
+      )
+    )
+  } else {
+    x$.label <- label
+  }
 
   initialized <- FALSE
 
@@ -302,6 +340,13 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
   )
 
   class(x) <- c("Observer.event", class(x))
+  call_srcref <- get_call_srcref(-1)
+  x$.otelAttrs <- append_otel_srcref_attrs(x$.otelAttrs, call_srcref, fn_name = "bindEvent")
+
+  if (has_otel_collect("reactivity")) {
+    x <- enable_otel_observe(x)
+  }
+
   invisible(x)
 }
 

R/bookmark-state.R

@@ -1,6 +1,3 @@
-#' @include stack.R
-NULL
-
 ShinySaveState <- R6Class("ShinySaveState",
   public = list(
     input = NULL,
@@ -102,13 +99,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),
@@ -324,34 +321,38 @@ RestoreContext <- R6Class("RestoreContext",
       if (substr(queryString, 1, 1) == '?')
         queryString <- substr(queryString, 2, nchar(queryString))
 
+      # The "=" after "_inputs_" is optional. Shiny doesn't generate URLs with
+      # "=", but httr always adds "=".
+      inputs_reg <- "(^|&)_inputs_=?(&|$)"
+      values_reg <- "(^|&)_values_=?(&|$)"
 
       # Error if multiple '_inputs_' or '_values_'. This is needed because
       # strsplit won't add an entry if the search pattern is at the end of a
       # string.
-      if (length(gregexpr("(^|&)_inputs_(&|$)", queryString)[[1]]) > 1)
+      if (length(gregexpr(inputs_reg, queryString)[[1]]) > 1)
         stop("Invalid state string: more than one '_inputs_' found")
-      if (length(gregexpr("(^|&)_values_(&|$)", queryString)[[1]]) > 1)
+      if (length(gregexpr(values_reg, queryString)[[1]]) > 1)
         stop("Invalid state string: more than one '_values_' found")
 
       # Look for _inputs_ and store following content in inputStr
-      splitStr <- strsplit(queryString, "(^|&)_inputs_(&|$)")[[1]]
+      splitStr <- strsplit(queryString, inputs_reg)[[1]]
       if (length(splitStr) == 2) {
         inputStr <- splitStr[2]
         # Remove any _values_ (and content after _values_) that may come after
         # _inputs_
-        inputStr <- strsplit(inputStr, "(^|&)_values_(&|$)")[[1]][1]
+        inputStr <- strsplit(inputStr, values_reg)[[1]][1]
 
       } else {
         inputStr <- ""
       }
 
       # Look for _values_ and store following content in valueStr
-      splitStr <- strsplit(queryString, "(^|&)_values_(&|$)")[[1]]
+      splitStr <- strsplit(queryString, values_reg)[[1]]
       if (length(splitStr) == 2) {
         valueStr <- splitStr[2]
         # Remove any _inputs_ (and content after _inputs_) that may come after
         # _values_
-        valueStr <- strsplit(valueStr, "(^|&)_inputs_(&|$)")[[1]][1]
+        valueStr <- strsplit(valueStr, inputs_reg)[[1]][1]
 
       } else {
         valueStr <- ""
@@ -362,16 +363,20 @@ RestoreContext <- R6Class("RestoreContext",
       values <- parseQueryString(valueStr, nested = TRUE)
 
       valuesFromJSON <- function(vals) {
-        mapply(names(vals), vals, SIMPLIFY = FALSE,
+        varsUnparsed <- c()
+        valsParsed <- mapply(names(vals), vals, SIMPLIFY = FALSE,
           FUN = function(name, value) {
             tryCatch(
               safeFromJSON(value),
               error = function(e) {
-                stop("Failed to parse URL parameter \"", name, "\"")
+                varsUnparsed <<- c(varsUnparsed, name)
+                warning("Failed to parse URL parameter \"", name, "\"")
               }
             )
           }
         )
+        valsParsed[varsUnparsed] <- NULL
+        valsParsed
       }
 
       inputs <- valuesFromJSON(inputs)
@@ -447,8 +452,10 @@ RestoreInputSet <- R6Class("RestoreInputSet",
   )
 )
 
-
-restoreCtxStack <- Stack$new()
+restoreCtxStack <- NULL
+on_load({
+    restoreCtxStack <- fastmap::faststack()
+})
 
 withRestoreContext <- function(ctx, expr) {
   restoreCtxStack$push(ctx)
@@ -544,7 +551,7 @@ restoreInput <- function(id, default) {
 #' `window.history.pushState(null, null, queryString)`.
 #'
 #' @param queryString The new query string to show in the location bar.
-#' @param mode When the query string is updated, should the the current history
+#' @param mode When the query string is updated, should the current history
 #'   entry be replaced (default), or should a new history entry be pushed onto
 #'   the history stack? The former should only be used in a live bookmarking
 #'   context. The latter is useful if you want to navigate between states using

R/bootstrap-deprecated.R

@@ -6,7 +6,7 @@
 #' @param sidebarPanel The [sidebarPanel] containing input controls
 #' @param mainPanel The [mainPanel] containing outputs
 #' @keywords internal
-#' @return A UI defintion that can be passed to the [shinyUI] function
+#' @return A UI definition that can be passed to the [shinyUI] function
 #' @export
 pageWithSidebar <- function(headerPanel,
                             sidebarPanel,

R/bootstrap-layout.R

@@ -11,14 +11,9 @@
 #' @param ... Elements to include within the page
 #' @param title The browser window title (defaults to the host URL of the page).
 #'   Can also be set as a side effect of the [titlePanel()] function.
-#' @param responsive This option is deprecated; it is no longer optional with
-#'   Bootstrap 3.
-#' @param theme Alternative Bootstrap stylesheet (normally a css file within the
-#'   www directory). For example, to use the theme located at
-#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
 #' @inheritParams bootstrapPage
 #'
-#' @return A UI defintion that can be passed to the [shinyUI] function.
+#' @return A UI definition that can be passed to the [shinyUI] function.
 #'
 #' @details To create a fluid page use the `fluidPage` function and include
 #'   instances of `fluidRow` and [column()] within it. As an
@@ -88,10 +83,9 @@
 #' }
 #' @rdname fluidPage
 #' @export
-fluidPage <- function(..., title = NULL, responsive = deprecated(), theme = NULL, lang = NULL) {
+fluidPage <- function(..., title = NULL, theme = NULL, lang = NULL) {
   bootstrapPage(div(class = "container-fluid", ...),
                 title = title,
-                responsive = responsive,
                 theme = theme,
                 lang = lang)
 }
@@ -115,14 +109,9 @@ fluidRow <- function(...) {
 #'
 #' @param ... Elements to include within the container
 #' @param title The browser window title (defaults to the host URL of the page)
-#' @param responsive This option is deprecated; it is no longer optional with
-#'   Bootstrap 3.
-#' @param theme Alternative Bootstrap stylesheet (normally a css file within the
-#'   www directory). For example, to use the theme located at
-#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
 #' @inheritParams bootstrapPage
 #'
-#' @return A UI defintion that can be passed to the [shinyUI] function.
+#' @return A UI definition that can be passed to the [shinyUI] function.
 #'
 #' @details To create a fixed page use the `fixedPage` function and include
 #'   instances of `fixedRow` and [column()] within it. Note that
@@ -159,10 +148,9 @@ fluidRow <- function(...) {
 #'
 #' @rdname fixedPage
 #' @export
-fixedPage <- function(..., title = NULL, responsive = deprecated(), theme = NULL, lang = NULL) {
+fixedPage <- function(..., title = NULL, theme = NULL, lang = NULL) {
   bootstrapPage(div(class = "container", ...),
                 title = title,
-                responsive = responsive,
                 theme = theme,
                 lang = lang)
 }
@@ -402,7 +390,7 @@ mainPanel <- function(..., width = 8) {
 #' }
 #' @export
 verticalLayout <- function(..., fluid = TRUE) {
-  lapply(list(...), function(row) {
+  lapply(list2(...), function(row) {
     col <- column(12, row)
     if (fluid)
       fluidRow(col)
@@ -439,7 +427,7 @@ verticalLayout <- function(..., fluid = TRUE) {
 #' @export
 flowLayout <- function(..., cellArgs = list()) {
 
-  children <- list(...)
+  children <- list2(...)
   childIdx <- !nzchar(names(children) %||% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
@@ -522,13 +510,13 @@ inputPanel <- function(...) {
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
-  children <- list(...)
+  children <- list2(...)
   childIdx <- !nzchar(names(children) %||% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
   count <- length(children)
 
-  if (length(cellWidths) == 0 || is.na(cellWidths)) {
+  if (length(cellWidths) == 0 || isTRUE(is.na(cellWidths))) {
     cellWidths <- sprintf("%.3f%%", 100 / count)
   }
   cellWidths <- rep(cellWidths, length.out = count)
@@ -620,7 +608,7 @@ fillCol <- function(..., flex = 1, width = "100%", height = "100%") {
 }
 
 flexfill <- function(..., direction, flex, width = width, height = height) {
-  children <- list(...)
+  children <- list2(...)
   attrs <- list()
 
   if (!is.null(names(children))) {

R/bootstrap.R

@@ -14,8 +14,6 @@ NULL
 #'
 #' @param ... The contents of the document body.
 #' @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 One of the following:
 #'   * `NULL` (the default), which implies a "stock" build of Bootstrap 3.
 #'   * A [bslib::bs_theme()] object. This can be used to replace a stock
@@ -26,30 +24,24 @@ NULL
 #'   This will be used as the lang in the \code{<html>} tag, as in \code{<html lang="en">}.
 #'   The default (NULL) results in an empty string.
 #'
-#' @return A UI defintion that can be passed to the [shinyUI] function.
+#' @return A UI definition that can be passed to the [shinyUI] function.
 #'
 #' @note The `basicPage` function is deprecated, you should use the
 #'   [fluidPage()] function instead.
 #'
 #' @seealso [fluidPage()], [fixedPage()]
 #' @export
-bootstrapPage <- function(..., title = NULL, responsive = deprecated(), theme = NULL, lang = NULL) {
-
-  if (lifecycle::is_present(responsive)) {
-    shinyDeprecated(
-      "0.10.2.2", "bootstrapPage(responsive=)",
-      details = "The 'responsive' argument is no longer used with the latest version of Bootstrap."
-    )
-  }
+bootstrapPage <- function(..., title = NULL, theme = NULL, lang = NULL) {
 
   args <- list(
+    jqueryDependency(),
     if (!is.null(title)) tags$head(tags$title(title)),
     if (is.character(theme)) {
       if (length(theme) > 1) stop("`theme` must point to a single CSS file, not multiple files.")
       tags$head(tags$link(rel="stylesheet", type="text/css", href=theme))
     },
     # remainder of tags passed to the function
-    list(...)
+    list2(...)
   )
 
   # If theme is a bslib::bs_theme() object, bootstrapLib() needs to come first
@@ -91,6 +83,10 @@ getLang <- function(ui) {
 #' @export
 bootstrapLib <- function(theme = NULL) {
   tagFunction(function() {
+    if (isRunning()) {
+      setCurrentTheme(theme)
+    }
+
     # If we're not compiling Bootstrap Sass (from bslib), return the
     # static Bootstrap build.
     if (!is_bs_theme(theme)) {
@@ -112,7 +108,6 @@ bootstrapLib <- function(theme = NULL) {
     # Note also that since this is shinyOptions() (and not options()), the
     # option is automatically reset when the app (or session) exits
     if (isRunning()) {
-      setCurrentTheme(theme)
       registerThemeDependency(bs_theme_deps)
 
     } else {
@@ -143,8 +138,7 @@ bs_theme_deps <- function(theme) {
 }
 
 is_bs_theme <- function(x) {
-  is_available("bslib", "0.2.0.9000") &&
-    bslib::is_bs_theme(x)
+  bslib::is_bs_theme(x)
 }
 
 #' Obtain Shiny's Bootstrap Sass theme
@@ -163,15 +157,25 @@ getCurrentTheme <- function() {
   getShinyOption("bootstrapTheme", default = NULL)
 }
 
+getCurrentThemeVersion <- function() {
+  theme <- getCurrentTheme()
+  if (bslib::is_bs_theme(theme)) {
+    bslib::theme_version(theme)
+  } else {
+    strsplit(bootstrapVersion, ".", fixed = TRUE)[[1]][[1]]
+  }
+}
+
 setCurrentTheme <- function(theme) {
   shinyOptions(bootstrapTheme = theme)
 }
 
 #' Register a theme dependency
 #'
-#' This function registers a function that returns an [htmlDependency()] or list
-#' of such objects. If `session$setCurrentTheme()` is called, the function will
-#' be re-executed, and the resulting html dependency will be sent to the client.
+#' This function registers a function that returns an
+#' [htmltools::htmlDependency()] or list of such objects. If
+#' `session$setCurrentTheme()` is called, the function will be re-executed, and
+#' the resulting html dependency will be sent to the client.
 #'
 #' Note that `func` should **not** be an anonymous function, or a function which
 #' is defined within the calling function. This is so that,
@@ -211,11 +215,10 @@ registerThemeDependency <- function(func) {
 
 bootstrapDependency <- function(theme) {
   htmlDependency(
-    "bootstrap", "3.4.1",
-    c(
-      href = "shared/bootstrap",
-      file = system.file("www/shared/bootstrap", package = "shiny")
-    ),
+    "bootstrap",
+    bootstrapVersion,
+    src = "www/shared/bootstrap",
+    package = "shiny",
     script = c(
       "js/bootstrap.min.js",
       # Safely adding accessibility plugin for screen readers and keyboard users; no break for sighted aspects (see https://github.com/paypal/bootstrap-accessibility-plugin)
@@ -230,6 +233,8 @@ bootstrapDependency <- function(theme) {
   )
 }
 
+bootstrapVersion <- "3.4.1"
+
 
 #' @rdname bootstrapPage
 #' @export
@@ -283,7 +288,6 @@ basicPage <- function(...) {
 #' @param title The title to use for the browser window/tab (it will not be
 #'   shown in the document).
 #' @param bootstrap If `TRUE`, load the Bootstrap CSS library.
-#' @param theme URL to alternative Bootstrap stylesheet.
 #' @inheritParams bootstrapPage
 #'
 #' @family layout functions
@@ -371,22 +375,17 @@ collapseSizes <- function(padding) {
 #' @param inverse `TRUE` to use a dark background and light text for the
 #'   navigation bar
 #' @param collapsible `TRUE` to automatically collapse the navigation
-#'   elements into a menu when the width of the browser is less than 940 pixels
-#'   (useful for viewing on smaller touchscreen device)
-#' @param collapsable Deprecated; use `collapsible` instead.
+#'   elements into an expandable menu on mobile devices or narrow window widths.
 #' @param fluid `TRUE` to use a fluid layout. `FALSE` to use a fixed
 #'   layout.
-#' @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"`.
-#' @param windowTitle The title that should be displayed by the browser window.
-#'   Useful if `title` is not a string.
+#' @param windowTitle the browser window title (as a character string). The
+#'   default value, `NA`, means to use any character strings that appear in
+#'   `title` (if none are found, the host URL of the page is displayed by
+#'   default).
 #' @inheritParams bootstrapPage
 #' @param icon Optional icon to appear on a `navbarMenu` tab.
 #'
-#' @return A UI defintion that can be passed to the [shinyUI] function.
+#' @return A UI definition that can be passed to the [shinyUI] function.
 #'
 #' @details The `navbarMenu` function can be used to create an embedded
 #'   menu within the navbar that in turns includes additional tabPanels (see
@@ -424,86 +423,20 @@ navbarPage <- function(title,
                        footer = NULL,
                        inverse = FALSE,
                        collapsible = FALSE,
-                       collapsable = deprecated(),
                        fluid = TRUE,
-                       responsive = deprecated(),
                        theme = NULL,
-                       windowTitle = title,
+                       windowTitle = NA,
                        lang = NULL) {
-
-  if (lifecycle::is_present(collapsable)) {
-    shinyDeprecated("0.10.2.2", "navbarPage(collapsable =)", "navbarPage(collapsible =)")
-    collapsible <- collapsable
-  }
-
-  # alias title so we can avoid conflicts w/ title in withTags
-  pageTitle <- title
-
-  # navbar class based on options
-  navbarClass <- "navbar navbar-default"
-  position <- match.arg(position)
-  if (!is.null(position))
-    navbarClass <- paste(navbarClass, " navbar-", position, sep = "")
-  if (inverse)
-    navbarClass <- paste(navbarClass, "navbar-inverse")
-
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
-  # build the tabset
-  tabs <- list(...)
-  tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id, selected)
-
-  # function to return plain or fluid class name
-  className <- function(name) {
-    if (fluid)
-      paste(name, "-fluid", sep="")
-    else
-      name
-  }
-
-  # built the container div dynamically to support optional collapsibility
-  if (collapsible) {
-    navId <- paste("navbar-collapse-", p_randomInt(1000, 10000), sep="")
-    containerDiv <- div(class=className("container"),
-      div(class="navbar-header",
-        tags$button(type="button", class="navbar-toggle collapsed",
-          `data-toggle`="collapse", `data-target`=paste0("#", navId),
-          span(class="sr-only", "Toggle navigation"),
-          span(class="icon-bar"),
-          span(class="icon-bar"),
-          span(class="icon-bar")
-        ),
-        span(class="navbar-brand", pageTitle)
-      ),
-      div(class="navbar-collapse collapse", id=navId, tabset$navList)
-    )
-  } else {
-    containerDiv <- div(class=className("container"),
-      div(class="navbar-header",
-        span(class="navbar-brand", pageTitle)
-      ),
-      tabset$navList
-    )
-  }
-
-  # build the main tab content div
-  contentDiv <- div(class=className("container"))
-  if (!is.null(header))
-    contentDiv <- tagAppendChild(contentDiv, div(class="row", header))
-  contentDiv <- tagAppendChild(contentDiv, tabset$content)
-  if (!is.null(footer))
-    contentDiv <- tagAppendChild(contentDiv, div(class="row", footer))
-
-  # build the page
-  bootstrapPage(
-    title = windowTitle,
-    responsive = responsive,
+  remove_first_class(bslib::page_navbar(
+    ..., title = title, id = id, selected = selected,
+    position = match.arg(position),
+    header = header, footer = footer,
+    inverse = inverse, collapsible = collapsible,
+    fluid = fluid,
     theme = theme,
-    lang = lang,
-    tags$nav(class=navbarClass, role="navigation", containerDiv),
-    contentDiv
-  )
+    window_title = windowTitle,
+    lang = lang
+  ))
 }
 
 #' @param menuName A name that identifies this `navbarMenu`. This
@@ -513,11 +446,7 @@ navbarPage <- function(title,
 #' @rdname navbarPage
 #' @export
 navbarMenu <- function(title, ..., menuName = title, icon = NULL) {
-  structure(list(title = title,
-                 menuName = menuName,
-                 tabs = list(...),
-                 iconClass = iconClass(icon)),
-            class = "shiny.navbarmenu")
+  bslib::nav_menu(title, ..., value = menuName, icon = icon)
 }
 
 #' Create a well panel
@@ -604,7 +533,12 @@ wellPanel <- function(...) {
 #' }
 #' @export
 conditionalPanel <- function(condition, ..., ns = NS(NULL)) {
-  div(`data-display-if`=condition, `data-ns-prefix`=ns(""), ...)
+  div(
+    class = "shiny-panel-conditional",
+    `data-display-if` = condition,
+    `data-ns-prefix` = ns(""),
+    ...
+  )
 }
 
 #' Create a help text element
@@ -652,27 +586,14 @@ helpText <- function(...) {
 #' @export
 #' @describeIn tabPanel Create a tab panel that can be included within a [tabsetPanel()] or a [navbarPage()].
 tabPanel <- function(title, ..., value = title, icon = NULL) {
-  div(
-    class = "tab-pane",
-    title = title,
-    `data-value` = value,
-    `data-icon-class` = iconClass(icon),
-    ...
-  )
+  bslib::nav(title, ..., value = value, icon = icon)
 }
+
 #' @export
 #' @describeIn tabPanel Create a tab panel that drops the title argument.
 #'   This function should be used within `tabsetPanel(type = "hidden")`. See [tabsetPanel()] for example usage.
 tabPanelBody <- function(value, ..., icon = NULL) {
-  if (
-    !is.character(value) ||
-    length(value) != 1 ||
-    any(is.na(value)) ||
-    nchar(value) == 0
-  ) {
-    stop("`value` must be a single, non-empty string value")
-  }
-  tabPanel(title = NULL, ..., value = value, icon = icon)
+  bslib::nav_content(value, ..., icon = icon)
 }
 
 #' Create a tabset panel
@@ -695,8 +616,7 @@ tabPanelBody <- function(value, ..., icon = NULL) {
 #'   conjunction with [tabPanelBody()] and [updateTabsetPanel()] to control the
 #'   active tab via other input controls. (See example below)}
 #' }
-#' @param position This argument is deprecated; it has been discontinued in
-#'   Bootstrap 3.
+#' @inheritParams navbarPage
 #' @return A tabset that can be passed to [mainPanel()]
 #'
 #' @seealso [tabPanel()], [updateTabsetPanel()],
@@ -746,29 +666,21 @@ tabsetPanel <- function(...,
                         id = NULL,
                         selected = NULL,
                         type = c("tabs", "pills", "hidden"),
-                        position = deprecated()) {
-  if (lifecycle::is_present(position)) {
-    shinyDeprecated(
-      "0.10.2.2", "bootstrapPage(position =)",
-      details = "The 'position' argument is no longer used with the latest version of Bootstrap."
-    )
-  }
+                        header = NULL,
+                        footer = NULL) {
 
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
+  func <- switch(
+    match.arg(type),
+    tabs = bslib::navs_tab,
+    pills = bslib::navs_pill,
+    hidden = bslib::navs_hidden
+  )
 
-  # build the tabset
-  tabs <- list(...)
-  type <- match.arg(type)
-
-  tabset <- buildTabset(tabs, paste0("nav nav-", type), NULL, id, selected)
-
-  # create the content
-  first <- tabset$navList
-  second <- tabset$content
-
-  # create the tab div
-  tags$div(class = "tabbable", first, second)
+  # bslib adds a class to make the content browsable() by default,
+  # but that's probably too big of a change for shiny
+  remove_first_class(
+    func(..., id = id, selected = selected, header = header, footer = footer)
+  )
 }
 
 #' Create a navigation list panel
@@ -788,8 +700,10 @@ tabsetPanel <- function(...,
 #'   navigation list.
 #' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
 #'   layout.
-#' @param widths Column withs of the navigation list and tabset content areas
+#' @param widths Column widths of the navigation list and tabset content areas
 #'   respectively.
+#' @inheritParams tabsetPanel
+#' @inheritParams navbarPage
 #'
 #' @details You can include headers within the `navlistPanel` by including
 #'   plain text elements in the list. Versions of Shiny before 0.11 supported
@@ -816,194 +730,23 @@ tabsetPanel <- function(...,
 navlistPanel <- function(...,
                          id = NULL,
                          selected = NULL,
+                         header = NULL,
+                         footer = NULL,
                          well = TRUE,
                          fluid = TRUE,
                          widths = c(4, 8)) {
-
-  # text filter for headers
-  textFilter <- function(text) {
-      tags$li(class="navbar-brand", text)
-  }
-
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
-  # build the tabset
-  tabs <- list(...)
-  tabset <- buildTabset(tabs,
-                        "nav nav-pills nav-stacked",
-                        textFilter,
-                        id,
-                        selected)
-
-  # create the columns
-  columns <- list(
-    column(widths[[1]], class=ifelse(well, "well", ""), tabset$navList),
-    column(widths[[2]], tabset$content)
-  )
-
-  # return the row
-  if (fluid)
-    fluidRow(columns)
-  else
-    fixedRow(columns)
+  remove_first_class(bslib::navs_pill_list(
+    ..., id = id, selected = selected,
+    header = header, footer = footer,
+    well = well, fluid = fluid, widths = widths
+  ))
 }
 
-# Helpers to build tabsetPanels (& Co.) and their elements
-markTabAsSelected <- function(x) {
-  attr(x, "selected") <- TRUE
+remove_first_class <- function(x) {
+  class(x) <- class(x)[-1]
   x
 }
 
-isTabSelected <- function(x) {
-  isTRUE(attr(x, "selected", exact = TRUE))
-}
-
-containsSelectedTab <- function(tabs) {
-  any(vapply(tabs, isTabSelected, logical(1)))
-}
-
-findAndMarkSelectedTab <- function(tabs, selected, foundSelected) {
-  tabs <- lapply(tabs, function(div) {
-    if (foundSelected || is.character(div)) {
-      # Strings are not selectable items
-
-    } else if (inherits(div, "shiny.navbarmenu")) {
-      # Recur for navbarMenus
-      res <- findAndMarkSelectedTab(div$tabs, selected, foundSelected)
-      div$tabs <- res$tabs
-      foundSelected <<- res$foundSelected
-
-    } else {
-      # Base case: regular tab item. If the `selected` argument is
-      # provided, check for a match in the existing tabs; else,
-      # mark first available item as selected
-      if (is.null(selected)) {
-        foundSelected <<- TRUE
-        div <- markTabAsSelected(div)
-      } else {
-        tabValue <- div$attribs$`data-value` %||% div$attribs$title
-        if (identical(selected, tabValue)) {
-          foundSelected <<- TRUE
-          div <- markTabAsSelected(div)
-        }
-      }
-    }
-    return(div)
-  })
-  return(list(tabs = tabs, foundSelected = foundSelected))
-}
-
-# Returns the icon object (or NULL if none), provided either a
-# tabPanel, OR the icon class
-getIcon <- function(tab = NULL, iconClass = NULL) {
-  if (!is.null(tab)) iconClass <- tab$attribs$`data-icon-class`
-  if (!is.null(iconClass)) {
-    if (grepl("fa-", iconClass, fixed = TRUE)) {
-      # for font-awesome we specify fixed-width
-      iconClass <- paste(iconClass, "fa-fw")
-    }
-    icon(name = NULL, class = iconClass)
-  } else NULL
-}
-
-# Text filter for navbarMenu's (plain text) separators
-navbarMenuTextFilter <- function(text) {
-  if (grepl("^\\-+$", text)) tags$li(class = "divider")
-  else tags$li(class = "dropdown-header", text)
-}
-
-# This function is called internally by navbarPage, tabsetPanel
-# and navlistPanel
-buildTabset <- function(tabs, ulClass, textFilter = NULL, id = NULL,
-                        selected = NULL, foundSelected = FALSE) {
-
-  res <- findAndMarkSelectedTab(tabs, selected, foundSelected)
-  tabs <- res$tabs
-  foundSelected <- res$foundSelected
-
-  # add input class if we have an id
-  if (!is.null(id)) ulClass <- paste(ulClass, "shiny-tab-input")
-
-  if (anyNamed(tabs)) {
-    nms <- names(tabs)
-    nms <- nms[nzchar(nms)]
-    stop("Tabs should all be unnamed arguments, but some are named: ",
-      paste(nms, collapse = ", "))
-  }
-
-  tabsetId <- p_randomInt(1000, 10000)
-  tabs <- lapply(seq_len(length(tabs)), buildTabItem,
-            tabsetId = tabsetId, foundSelected = foundSelected,
-            tabs = tabs, textFilter = textFilter)
-
-  tabNavList <- tags$ul(class = ulClass, id = id,
-                  `data-tabsetid` = tabsetId, lapply(tabs, "[[", 1))
-
-  tabContent <- tags$div(class = "tab-content",
-                  `data-tabsetid` = tabsetId, lapply(tabs, "[[", 2))
-
-  list(navList = tabNavList, content = tabContent)
-}
-
-# Builds tabPanel/navbarMenu items (this function used to be
-# declared inside the buildTabset() function and it's been
-# refactored for clarity and reusability). Called internally
-# by buildTabset.
-buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
-                         divTag = NULL, textFilter = NULL) {
-
-  divTag <- if (!is.null(divTag)) divTag else tabs[[index]]
-
-  if (is.character(divTag) && !is.null(textFilter)) {
-    # text item: pass it to the textFilter if it exists
-    liTag <- textFilter(divTag)
-    divTag <- NULL
-
-  } else if (inherits(divTag, "shiny.navbarmenu")) {
-    # navbarMenu item: build the child tabset
-    tabset <- buildTabset(divTag$tabs, "dropdown-menu",
-      navbarMenuTextFilter, foundSelected = foundSelected)
-
-    # if this navbarMenu contains a selected item, mark it active
-    containsSelected <- containsSelectedTab(divTag$tabs)
-    liTag <- tags$li(
-      class = paste0("dropdown", if (containsSelected) " active"),
-      tags$a(href = "#",
-        class = "dropdown-toggle", `data-toggle` = "dropdown",
-        `data-value` = divTag$menuName,
-        getIcon(iconClass = divTag$iconClass),
-        divTag$title, tags$b(class = "caret")
-      ),
-      tabset$navList   # inner tabPanels items
-    )
-    # list of tab content divs from the child tabset
-    divTag <- tabset$content$children
-
-  } else {
-    # tabPanel item: create the tab's liTag and divTag
-    tabId <- paste("tab", tabsetId, index, sep = "-")
-    liTag <- tags$li(
-               tags$a(
-                 href = paste("#", tabId, sep = ""),
-                 `data-toggle` = "tab",
-                 `data-value` = divTag$attribs$`data-value`,
-                 getIcon(iconClass = divTag$attribs$`data-icon-class`),
-                 divTag$attribs$title
-               )
-    )
-    # if this tabPanel is selected item, mark it active
-    if (isTabSelected(divTag)) {
-      liTag$attribs$class <- "active"
-      divTag$attribs$class <- "tab-pane active"
-    }
-    divTag$attribs$id <- tabId
-    divTag$attribs$title <- NULL
-  }
-  return(list(liTag = liTag, divTag = divTag))
-}
-
-
 #' Create a text output element
 #'
 #' Render a reactive output variable as text within an application page.
@@ -1056,7 +799,7 @@ verbatimTextOutput <- function(outputId, placeholder = FALSE) {
 #' @export
 imageOutput <- function(outputId, width = "100%", height="400px",
                         click = NULL, dblclick = NULL, hover = NULL, brush = NULL,
-                        inline = FALSE) {
+                        inline = FALSE, fill = FALSE) {
 
   style <- if (!inline) {
     # Using `css()` here instead of paste/sprintf so that NULL values will
@@ -1112,7 +855,8 @@ imageOutput <- function(outputId, width = "100%", height="400px",
   }
 
   container <- if (inline) span else div
-  do.call(container, args)
+  res <- do.call(container, args)
+  bindFillRole(res, item = fill)
 }
 
 #' Create an plot or image output element
@@ -1180,6 +924,11 @@ imageOutput <- function(outputId, width = "100%", height="400px",
 #'   `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 Whether or not the returned tag should be treated as a fill item,
+#'   meaning that its `height` is allowed to grow/shrink to fit a fill container
+#'   with an opinionated height (see [htmltools::bindFillRole()]) with an
+#'   opinionated height. Examples of fill containers include `bslib::card()` and
+#'   `bslib::card_body_fill()`.
 #' @inheritParams textOutput
 #' @note The arguments `clickId` and `hoverId` only work for R base graphics
 #'   (see the \pkg{\link[graphics:graphics-package]{graphics}} package). They do
@@ -1350,11 +1099,11 @@ imageOutput <- function(outputId, width = "100%", height="400px",
 #' @export
 plotOutput <- function(outputId, width = "100%", height="400px",
                        click = NULL, dblclick = NULL, hover = NULL, brush = NULL,
-                       inline = FALSE) {
+                       inline = FALSE, fill = !inline) {
 
   # Result is the same as imageOutput, except for HTML class
   res <- imageOutput(outputId, width, height, click, dblclick,
-                     hover, brush, inline)
+                     hover, brush, inline, fill)
 
   res$attribs$class <- "shiny-plot-output"
   res
@@ -1364,17 +1113,23 @@ plotOutput <- function(outputId, width = "100%", height="400px",
 #' @rdname renderTable
 #' @export
 tableOutput <- function(outputId) {
-  div(id = outputId, class="shiny-html-output")
+  div(id = outputId, class="shiny-html-output shiny-table-output")
 }
 
 dataTableDependency <- list(
   htmlDependency(
-    "datatables", "1.10.5", c(href = "shared/datatables"),
+    "datatables",
+    "1.10.22",
+    src = "www/shared/datatables",
+    package = "shiny",
     script = "js/jquery.dataTables.min.js"
   ),
   htmlDependency(
-    "datatables-bootstrap", "1.10.5", c(href = "shared/datatables"),
-    stylesheet = c("css/dataTables.bootstrap.css", "css/dataTables.extra.css"),
+    "datatables-bootstrap",
+    "1.10.22",
+    src = "www/shared/datatables",
+    package = "shiny",
+    stylesheet = "css/dataTables.bootstrap.css",
     script = "js/dataTables.bootstrap.js"
   )
 )
@@ -1382,24 +1137,67 @@ dataTableDependency <- list(
 #' @rdname renderDataTable
 #' @export
 dataTableOutput <- function(outputId) {
-  attachDependencies(
-    div(id = outputId, class="shiny-datatable-output"),
-    dataTableDependency
-  )
+  legacy <- useLegacyDataTable(from = "shiny::dataTableOutput()", to = "DT::DTOutput()")
+
+  if (legacy) {
+    attachDependencies(
+      div(id = outputId, class = "shiny-datatable-output"),
+      dataTableDependency
+    )
+  } else {
+    DT::DTOutput(outputId)
+  }
 }
 
+useLegacyDataTable <- function(from, to) {
+  legacy <- getOption("shiny.legacy.datatable")
+
+  # If option has been set, user knows what they're doing
+  if (!is.null(legacy)) {
+    return(legacy)
+  }
+
+  # If not set, use DT if a suitable version is available (and inform either way)
+  hasDT <- is_installed("DT", "0.32.1")
+  details <- NULL
+  if (hasDT) {
+    details <- paste0(c(
+      "Since you have a suitable version of DT (>= v0.32.1), ",
+      from,
+      " will automatically use ",
+      to,
+      " under-the-hood.\n",
+      "If this happens to break your app, set `options(shiny.legacy.datatable = TRUE)` ",
+      "to get the legacy datatable implementation (or `FALSE` to squelch this message).\n"
+    ), collapse = "")
+  }
+
+  details <- paste0(details, "See <https://rstudio.github.io/DT/shiny.html> for more information.")
+
+  shinyDeprecated("1.8.1", from, to, details)
+
+  !hasDT
+}
+
+
 #' Create an HTML output element
 #'
 #' Render a reactive output variable as HTML within an application page. The
-#' text will be included within an HTML `div` tag, and is presumed to
-#' contain HTML content which should not be escaped.
+#' text will be included within an HTML `div` tag, and is presumed to contain
+#' HTML content which should not be escaped.
 #'
-#' `uiOutput` is intended to be used with `renderUI` on the server
-#' side. It is currently just an alias for `htmlOutput`.
+#' `uiOutput` is intended to be used with `renderUI` on the server side. It is
+#' currently just an alias for `htmlOutput`.
 #'
 #' @param outputId output variable to read the value from
 #' @param ... Other arguments to pass to the container tag function. This is
 #'   useful for providing additional classes for the tag.
+#' @param fill If `TRUE`, the result of `container` is treated as _both_ a fill
+#'   item and container (see [htmltools::bindFillRole()]), which means both the
+#'   `container` as well as its immediate children (i.e., the result of
+#'   `renderUI()`) are allowed to grow/shrink to fit a fill container with an
+#'   opinionated height. Set `fill = "item"` or `fill = "container"` to treat
+#'   `container` as just a fill item or a fill container.
 #' @inheritParams textOutput
 #' @return An HTML output element that can be included in a panel
 #' @examples
@@ -1411,12 +1209,16 @@ dataTableOutput <- function(outputId) {
 #' )
 #' @export
 htmlOutput <- function(outputId, inline = FALSE,
-  container = if (inline) span else div, ...)
+  container = if (inline) span else div, fill = FALSE, ...)
 {
-  if (anyUnnamed(list(...))) {
+  if (any_unnamed(list(...))) {
     warning("Unnamed elements in ... will be replaced with dynamic UI.")
   }
-  container(id = outputId, class="shiny-html-output", ...)
+  res <- container(id = outputId, class = "shiny-html-output", ...)
+  bindFillRole(
+    res, item = isTRUE(fill) || isTRUE("item" == fill),
+    container = isTRUE(fill) || isTRUE("container" == fill)
+  )
 }
 
 #' @rdname htmlOutput
@@ -1440,19 +1242,25 @@ uiOutput <- htmlOutput
 #' @examples
 #' \dontrun{
 #' ui <- fluidPage(
+#'   p("Choose a dataset to download."),
+#'   selectInput("dataset", "Dataset", choices = c("mtcars", "airquality")),
 #'   downloadButton("downloadData", "Download")
 #' )
 #'
 #' server <- function(input, output) {
-#'   # Our dataset
-#'   data <- mtcars
+#'   # The requested dataset
+#'   data <- reactive({
+#'     get(input$dataset)
+#'   })
 #'
 #'   output$downloadData <- downloadHandler(
 #'     filename = function() {
-#'       paste("data-", Sys.Date(), ".csv", sep="")
+#'       # Use the selected dataset as the suggested file name
+#'       paste0(input$dataset, ".csv")
 #'     },
 #'     content = function(file) {
-#'       write.csv(data, file)
+#'       # Write the dataset to the `file` that will be downloaded
+#'       write.csv(data(), file)
 #'     }
 #'   )
 #' }
@@ -1468,23 +1276,29 @@ downloadButton <- function(outputId,
                            class=NULL,
                            ...,
                            icon = shiny::icon("download")) {
-  aTag <- tags$a(id=outputId,
-                 class=paste('btn btn-default shiny-download-link', class),
-                 href='',
-                 target='_blank',
-                 download=NA,
-                 validateIcon(icon),
-                 label, ...)
+  tags$a(id=outputId,
+         class='btn btn-default shiny-download-link disabled',
+         class=class,
+         href='',
+         target='_blank',
+         download=NA,
+         "aria-disabled"="true",
+         tabindex="-1",
+         validateIcon(icon),
+         label, ...)
 }
 
 #' @rdname downloadButton
 #' @export
 downloadLink <- function(outputId, label="Download", class=NULL, ...) {
   tags$a(id=outputId,
-         class=paste(c('shiny-download-link', class), collapse=" "),
+         class='shiny-download-link disabled',
+         class=class,
          href='',
          target='_blank',
          download=NA,
+         "aria-disabled"="true",
+         tabindex="-1",
          label, ...)
 }
 
@@ -1492,32 +1306,31 @@ downloadLink <- function(outputId, label="Download", class=NULL, ...) {
 #' Create an icon
 #'
 #' Create an icon for use within a page. Icons can appear on their own, inside
-#' of a button, or as an icon for a [tabPanel()] within a
-#' [navbarPage()].
+#' of a button, and/or used with [tabPanel()] and [navbarMenu()].
 #'
-#' @param name Name of icon. Icons are drawn from the
-#'   [Font Awesome Free](https://fontawesome.com/) (currently icons from
-#'   the v5.13.0 set are supported with the v4 naming convention) and
-#'   [Glyphicons](https://getbootstrap.com/components/#glyphicons)
-#'   libraries. Note that the "fa-" and "glyphicon-" prefixes should not be used
-#'   in icon names (i.e. the "fa-calendar" icon should be referred to as
-#'   "calendar")
-#' @param class Additional classes to customize the style of the icon (see the
+#' @param name The name of the icon. A name from either [Font
+#'   Awesome](https://fontawesome.com/) (when `lib="font-awesome"`) or
+#'   [Bootstrap
+#'   Glyphicons](https://getbootstrap.com/docs/3.3/components/#glyphicons) (when
+#'   `lib="glyphicon"`) may be provided. Note that the `"fa-"` and
+#'   `"glyphicon-"` prefixes should not appear in name (i.e., the
+#'   `"fa-calendar"` icon should be referred to as `"calendar"`). A `name` of
+#'   `NULL` may also be provided to get a raw `<i>` tag with no library attached
+#'   to it.
+#' @param class Additional classes to customize the style of an icon (see the
 #'   [usage examples](https://fontawesome.com/how-to-use) for details on
 #'   supported styles).
-#' @param lib Icon library to use ("font-awesome" or "glyphicon")
-#' @param ... Arguments passed to the `<i>` tag of [htmltools::tags]
+#' @param lib The icon library to use. Either `"font-awesome"` or `"glyphicon"`.
+#' @param ... Arguments passed to the `<i>` tag of [htmltools::tags].
 #'
-#' @return An icon element
-#'
-#' @seealso For lists of available icons, see
-#'   [https://fontawesome.com/icons](https://fontawesome.com/icons) and
-#'   [https://getbootstrap.com/components/#glyphicons](https://getbootstrap.com/components/#glyphicons).
+#' @return An `<i>` (icon) HTML tag.
 #'
+#' @seealso For lists of available icons, see <https://fontawesome.com/icons>
+#'   and <https://getbootstrap.com/docs/3.3/components/#glyphicons>
 #'
 #' @examples
 #' # add an icon to a submit button
-#' submitButton("Update View", icon = icon("refresh"))
+#' submitButton("Update View", icon = icon("redo"))
 #'
 #' navbarPage("App Title",
 #'   tabPanel("Plot", icon = icon("bar-chart-o")),
@@ -1526,48 +1339,26 @@ downloadLink <- function(outputId, label="Download", class=NULL, ...) {
 #' )
 #' @export
 icon <- function(name, class = NULL, lib = "font-awesome", ...) {
-  prefixes <- list(
-    "font-awesome" = "fa",
-    "glyphicon" = "glyphicon"
+
+  # A NULL name allows for a generic <i> not tied to any library
+  if (is.null(name)) {
+    lib <- "none"
+  }
+
+  switch(
+    lib %||% "",
+    "none" = iconTag(name, class = class, ...),
+    "font-awesome" = fontawesome::fa_i(name = name, class = class, ...),
+    "glyphicon" = iconTag(
+      name, class = "glyphicon", class = paste0("glyphicon-", name),
+      class = class, ...
+    ),
+    stop("Unknown icon library: ", lib, ". See `?icon` for supported libraries.")
   )
-  prefix <- prefixes[[lib]]
-
-  # determine stylesheet
-  if (is.null(prefix)) {
-    stop("Unknown font library '", lib, "' specified. Must be one of ",
-         paste0('"', names(prefixes), '"', collapse = ", "))
-  }
-
-  # build the icon class (allow name to be null so that other functions
-  # e.g. buildTabset can pass an explicit class value)
-  iconClass <- ""
-  if (!is.null(name)) {
-    prefix_class <- prefix
-    if (prefix_class == "fa" && name %in% font_awesome_brands) {
-      prefix_class <- "fab"
-    }
-    iconClass <- paste0(prefix_class, " ", prefix, "-", name)
-  }
-  if (!is.null(class))
-    iconClass <- paste(iconClass, class)
-
-  iconTag <- tags$i(class = iconClass, role = "presentation", `aria-label` = paste(name, "icon"), ...)
-
-  # font-awesome needs an additional dependency (glyphicon is in bootstrap)
-  if (lib == "font-awesome") {
-    htmlDependencies(iconTag) <- htmlDependency(
-      "font-awesome", "5.13.0", "www/shared/fontawesome", package = "shiny",
-      stylesheet = c(
-        "css/all.min.css",
-        "css/v4-shims.min.css"
-      )
-    )
-  }
-
-  htmltools::browsable(iconTag)
 }
 
-# Helper funtion to extract the class from an icon
-iconClass <- function(icon) {
-  if (!is.null(icon)) icon$attribs$class
+iconTag <- function(name, ...) {
+  htmltools::browsable(
+    tags$i(..., role = "presentation", `aria-label` = paste(name, "icon"))
+  )
 }

R/busy-indicators-spinners.R

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

@@ -0,0 +1,294 @@
+#' 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/conditions.R

@@ -75,6 +75,18 @@ 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)
@@ -122,7 +134,9 @@ getCallCategories <- function(calls) {
 #' @rdname stacktrace
 #' @export
 captureStackTraces <- function(expr) {
-  promises::with_promise_domain(createStackTracePromiseDomain(),
+  # Use `promises::` as it shows up in the stack trace
+  promises::with_promise_domain(
+    createStackTracePromiseDomain(),
     expr
   )
 }
@@ -130,11 +144,49 @@ 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(
+  d <- new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
       # Subscription time
@@ -142,13 +194,14 @@ 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 <- c(currentDeepStack, list(currentStack))
+          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -165,13 +218,14 @@ 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 <- c(currentDeepStack, list(currentStack))
+          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -199,6 +253,7 @@ doCaptureStack <- function(e) {
     calls <- sys.calls()
     parents <- sys.parents()
     attr(calls, "parents") <- parents
+    calls <- saveCallStackDigest(calls)
     attr(e, "stack.trace") <- calls
   }
   if (deepStacksEnabled()) {
@@ -225,10 +280,12 @@ withLogErrors <- function(expr,
       result <- captureStackTraces(expr)
 
       # Handle expr being an async operation
-      if (promises::is.promise(result)) {
+      if (is.promise(result)) {
         result <- promises::catch(result, function(cond) {
           # Don't print shiny.silent.error (i.e. validation errors)
-          if (inherits(cond, "shiny.silent.error")) return()
+          if (cnd_inherits(cond, "shiny.silent.error")) {
+            return()
+          }
           if (isTRUE(getOption("show.error.messages"))) {
             printError(cond, full = full, offset = offset)
           }
@@ -239,7 +296,7 @@ withLogErrors <- function(expr,
     },
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
-      if (inherits(cond, "shiny.silent.error")) return()
+      if (cnd_inherits(cond, "shiny.silent.error")) return()
       if (isTRUE(getOption("show.error.messages"))) {
         printError(cond, full = full, offset = offset)
       }
@@ -279,162 +336,113 @@ printStackTrace <- function(cond,
   full = get_devmode_option("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
-  should_drop <- !full
-  should_strip <- !full
-  should_prune <- !full
-
-  stackTraceCalls <- c(
+  stackTraces <- c(
     attr(cond, "deep.stack.trace", exact = TRUE),
     list(attr(cond, "stack.trace", exact = TRUE))
   )
 
-  stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
-  stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
-  stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
-
-  # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
-  if (should_drop) {
-    # toKeep is a list of logical vectors, of which elements (stack frames) to keep
-    toKeep <- lapply(stackTraceCallNames, dropTrivialFrames)
-    # We apply the list of logical vector indices to each data structure
-    stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+  # 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))
   }
 
-  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 = `&`,
+  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
   )
 
-  dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
-    st <- data.frame(
-      num = rev(which(index)),
-      call = rev(nms[index]),
-      loc = rev(getLocs(calls[index])),
-      category = rev(getCallCategories(calls[index])),
-      stringsAsFactors = FALSE
-    )
-
-    if (i != 1) {
-      message("From earlier call:")
-    }
-
-    if (nrow(st) == 0) {
-      message("  [No stack trace available]")
-    } else {
-      width <- floor(log10(max(st$num))) + 1
-      formatted <- paste0(
-        "  ",
-        formatC(st$num, width = width),
-        ": ",
-        mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
-          if (category == "pkg")
-            crayon::silver(name)
-          else if (category == "user")
-            crayon::blue$bold(name)
-          else
-            crayon::white(name)
-        }),
-        "\n"
-      )
-      cat(file = stderr(), formatted, sep = "")
-    }
-
-    st
-  }, SIMPLIFY = FALSE)
-
   invisible()
 }
 
-#' @details `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 = get_devmode_option("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
+printOneStackTrace <- function(stackTrace, stripResult, full, offset) {
+  calls <- offsetSrcrefs(stackTrace, offset = offset)
+  callNames <- getCallNames(stackTrace)
+  parents <- attr(stackTrace, "parents", exact = TRUE)
 
-  shinyDeprecated(
-    "1.0.5", "extractStackTrace()",
-    details = "Please contact the Shiny team if you were using this functionality."
-  )
+  should_drop <- !full
+  should_strip <- !full
+  should_prune <- !full
 
-  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_drop) {
+    toKeep <- dropTrivialFrames(callNames)
+    calls <- calls[toKeep]
+    callNames <- callNames[toKeep]
+    parents <- parents[toKeep]
+    stripResult <- stripResult[toKeep]
   }
-  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"))
+  toShow <- rep(TRUE, length(callNames))
+  if (should_prune) {
+    toShow <- toShow & pruneStackTrace(parents)
+  }
+  if (should_strip) {
+    toShow <- toShow & stripResult
   }
-  calls <- calls[toShow]
 
-  calls <- rev(calls) # Show in traceback() order
-  index <- rev(which(toShow))
-  width <- floor(log10(max(index))) + 1
+  # 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)
 
-  data.frame(
-    num = index,
-    call = getCallNames(calls),
-    loc = getLocs(calls),
-    category = getCallCategories(calls),
+  st <- data.frame(
+    num = rev(which(toShow)),
+    call = rev(callNames[toShow]),
+    loc = rev(getLocs(calls[toShow])),
+    category = rev(getCallCategories(calls[toShow])),
     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) {
@@ -495,8 +503,17 @@ pruneStackTrace <- function(parents) {
   # Loop over the parent indices. Anything that is not parented by current_node
   # (a.k.a. last-known-good node), or is a dupe, can be discarded. Anything that
   # is kept becomes the new current_node.
+  #
+  # jcheng 2022-03-18: Two more reasons a node can be kept:
+  #   1. parent is 0
+  #   2. parent is i
+  # Not sure why either of these situations happen, but they're common when
+  # interacting with rlang/dplyr errors. See issue rstudio/shiny#3250 for repro
+  # cases.
   include <- vapply(seq_along(parents), function(i) {
-    if (!is_dupe[[i]] && parents[[i]] == current_node) {
+    if ((!is_dupe[[i]] && parents[[i]] == current_node) ||
+        parents[[i]] == 0 ||
+        parents[[i]] == i) {
       current_node <<- i
       TRUE
     } else {
@@ -523,6 +540,34 @@ dropTrivialFrames <- function(callnames) {
   )
 }
 
+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"
+  )
+
+  # Remove everything from inception to calling the test
+  # It shouldn't matter how you get there, just that you're finally testing
+  toRemove <- max(which(hideable))
+
+  c(
+    rep_len(FALSE, toRemove),
+    rep_len(TRUE, length(callnames) - toRemove)
+  )
+}
+
 offsetSrcrefs <- function(calls, offset = TRUE) {
   if (offset) {
     srcrefs <- getSrcRefs(calls)
@@ -531,49 +576,12 @@ offsetSrcrefs <- function(calls, offset = TRUE) {
     # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
     # the definition of foo().
     srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
-
     calls <- setSrcRefs(calls, srcrefs)
   }
 
   calls
 }
 
-#' @details `formatStackTrace` is similar to `extractStackTrace`, but
-#'   it returns a preformatted character vector instead of a data frame. It was
-#'   deprecated after shiny 1.0.5 because it doesn't support deep stack traces.
-#' @param indent A string to prefix every line of the stack trace.
-#' @rdname stacktrace
-#' @export
-formatStackTrace <- function(calls, indent = "    ",
-  full = get_devmode_option("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  shinyDeprecated(
-    "1.0.5", "formatStackTrace()",
-    details = "Please contact the Shiny team if you were using this functionality."
-  )
-
-  st <- extractStackTrace(calls, full = full, offset = offset)
-  if (nrow(st) == 0) {
-    return(character(0))
-  }
-
-  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

@@ -9,13 +9,19 @@
 #' @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
+  version,
+  what,
+  with = NULL,
+  details = NULL,
+  type = c("deprecated", "superseded")
 ) {
   if (is_false(getOption("shiny.deprecation.messages"))) {
     return(invisible())
   }
 
-  msg <- paste0("`", what, "` is deprecated as of shiny ", version, ".")
+  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.")
   }
@@ -32,13 +38,20 @@ deprecatedEnvQuotedMessage <- function() {
   if (!in_devmode()) return(invisible())
   if (is_false(getOption("shiny.deprecation.messages"))) return(invisible())
 
-  # manually
+  # 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.6.0.",
+    "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."
+    "See <https://github.com/rstudio/shiny/issues/3108> for more information.\n",
+    "Function call:\n",
+    grandparent_txt
   )
-  rlang::inform(message = msg, .frequency = "always", .frequency_id = msg, .file = stderr())
+  # Call less often as users do not have much control over this warning
+  rlang::inform(message = msg, .frequency = "regularly", .frequency_id = msg, .file = stderr())
 }
 
 
@@ -60,7 +73,7 @@ diskCache <- function(
   logfile = NULL
 ) {
   shinyDeprecated("1.6.0", "diskCache()", "cachem::cache_disk()")
-  if (lifecycle::is_present(exec_missing)) {
+  if (is_present(exec_missing)) {
     shinyDeprecated("1.6.0", "diskCache(exec_missing =)")
   }
 
@@ -93,7 +106,7 @@ memoryCache <- function(
   logfile = NULL)
 {
   shinyDeprecated("1.6.0", "diskCache()", "cachem::cache_mem()")
-  if (lifecycle::is_present(exec_missing)) {
+  if (is_present(exec_missing)) {
     shinyDeprecated("1.6.0", "diskCache(exec_missing =)")
   }
 

R/devmode.R

@@ -1,6 +1,6 @@
 #' Shiny Developer Mode
 #'
-#' @description \lifecycle{experimental}
+#' @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
@@ -128,6 +128,12 @@ in_devmode <- function() {
     !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
@@ -190,8 +196,10 @@ devmode_inform <- function(
 
 
 
-#' @include map.R
-registered_devmode_options <- Map$new()
+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
@@ -233,6 +241,7 @@ registered_devmode_options <- Map$new()
 #'   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()`].
@@ -243,6 +252,7 @@ registered_devmode_options <- Map$new()
 #'   `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
@@ -338,21 +348,22 @@ get_devmode_option <- function(
 }
 
 
+on_load({
+  register_devmode_option(
+    "shiny.autoreload",
+    "Turning on shiny autoreload. To disable, call `options(shiny.autoreload = FALSE)`",
+    TRUE
+  )
 
-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.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
-)
+  register_devmode_option(
+    "shiny.fullstacktrace",
+    "Turning on full stack trace. To disable, call `options(shiny.fullstacktrace = FALSE)`",
+    TRUE
+  )
+})

R/extended-task.R

@@ -0,0 +1,338 @@
+#' 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.
+#'
+#' @section OpenTelemetry Integration:
+#'
+#' When an `ExtendedTask` is created, if OpenTelemetry tracing is enabled for
+#' `"reactivity"` (see [withOtelCollect()]), the `ExtendedTask` will record
+#' spans for each invocation of the task. The tracing level at `invoke()` time
+#' does not affect whether spans are recorded; only the tracing level when
+#' calling `ExtendedTask$new()` matters.
+#'
+#' The OTel span will be named based on the label created from the variable the
+#' `ExtendedTask` is assigned to. If no label can be determined, the span will
+#' be named `<anonymous>`. Similar to other Shiny OpenTelemetry spans, the span
+#' will also include source reference attributes and session ID attributes.
+#'
+#' ```r
+#' withOtelCollect("all", {
+#'   my_task <- ExtendedTask$new(function(...) { ... })
+#' })
+#'
+#' # Span recorded for this invocation: ExtendedTask my_task
+#' my_task$invoke(...)
+#' ```
+#'
+#' @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
+
+      # Do not show these private reactive values in otel spans
+      with_no_otel_collect({
+        private$rv_status <- reactiveVal("initial", label = "ExtendedTask$private$status")
+        private$rv_value <- reactiveVal(NULL, label = "ExtendedTask$private$value")
+        private$rv_error <- reactiveVal(NULL, label = "ExtendedTask$private$error")
+      })
+
+      private$invocation_queue <- fastmap::fastqueue()
+
+      domain <- getDefaultReactiveDomain()
+
+      # Set a label for the reactive values for easier debugging
+      # Go up an extra sys.call() to get the user's call to ExtendedTask$new()
+      # The first sys.call() is to `initialize(...)`
+      call_srcref <- get_call_srcref(-1)
+      label <- rassignSrcrefToLabel(
+        call_srcref,
+        defaultLabel = "<anonymous>"
+      )
+      private$otel_span_label <- otel_span_label_extended_task(label, domain = domain)
+      private$otel_log_label_add_to_queue <- otel_log_label_extended_task_add_to_queue(label, domain = domain)
+
+      private$otel_attrs <- c(
+        otel_srcref_attributes(call_srcref, "ExtendedTask"),
+        otel_session_id_attrs(domain)
+      ) %||% list()
+
+      # Capture this value at init-time, not run-time
+      # This way, the span is only created if otel was enabled at time of creation... just like other spans
+      private$is_recording_otel <- has_otel_collect("reactivity")
+    },
+    #' @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
+      ) {
+        otel_log(
+          private$otel_log_add_to_queue_label,
+          severity = "debug",
+          attributes = c(
+            private$otel_attrs,
+            list(
+              queue_size = private$invocation_queue$size() + 1L
+            )
+          )
+        )
+        private$invocation_queue$add(list(args = args, call = call))
+      } else {
+
+        if (private$is_recording_otel) {
+          private$otel_span <- start_otel_span(
+            private$otel_span_label,
+            attributes = private$otel_attrs
+          )
+          otel::local_active_span(private$otel_span)
+        }
+
+        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,
+
+    otel_span_label = NULL,
+    otel_log_label_add_to_queue = NULL,
+    otel_attrs = list(),
+    is_recording_otel = FALSE,
+    otel_span = NULL,
+
+    do_invoke = function(args, call = NULL) {
+      private$rv_status("running")
+      private$rv_value(NULL)
+      private$rv_error(NULL)
+
+      p <- promise_resolve(
+        maskReactiveContext(do.call(private$func, args))
+      )
+
+      p <- promises::then(
+        p,
+        onFulfilled = function(value, .visible) {
+          if (is_otel_span(private$otel_span)) {
+
+            private$otel_span$end(status_code = "ok")
+            private$otel_span <- NULL
+          }
+          private$on_success(list(value = value, visible = .visible))
+        },
+        onRejected = function(error) {
+          if (is_otel_span(private$otel_span)) {
+            private$otel_span$end(status_code = "error")
+            private$otel_span <- NULL
+          }
+          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

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

R/globals.R

@@ -1,70 +1,31 @@
 # A scope where we can put mutable global state
 .globals <- new.env(parent = emptyenv())
 
-register_s3_method <- function(pkg, generic, class, fun = NULL) {
-  stopifnot(is.character(pkg), length(pkg) == 1)
-  stopifnot(is.character(generic), length(generic) == 1)
-  stopifnot(is.character(class), length(class) == 1)
-
-  if (is.null(fun)) {
-    fun <- get(paste0(generic, ".", class), envir = parent.frame())
-  } else {
-    stopifnot(is.function(fun))
-  }
-
-  if (pkg %in% loadedNamespaces()) {
-    registerS3method(generic, class, fun, envir = asNamespace(pkg))
-  }
-
-  # Always register hook in case pkg is loaded at some
-  # point the future (or, potentially, but less commonly,
-  # unloaded & reloaded)
-  setHook(
-    packageEvent(pkg, "onLoad"),
-    function(...) {
-      registerS3method(generic, class, fun, envir = asNamespace(pkg))
-    }
-  )
-}
-
-register_upgrade_message <- function(pkg, version) {
-
-  msg <- sprintf(
-    "This version of Shiny is designed to work with '%s' >= %s.
-    Please upgrade via install.packages('%s').",
-    pkg, version, pkg
-  )
-
-  if (pkg %in% loadedNamespaces() && !is_available(pkg, version)) {
-    packageStartupMessage(msg)
-  }
-
-  # Always register hook in case pkg is loaded at some
-  # point the future (or, potentially, but less commonly,
-  # unloaded & reloaded)
-  setHook(
-    packageEvent(pkg, "onLoad"),
-    function(...) {
-      if (!is_available(pkg, version)) packageStartupMessage(msg)
-    }
-  )
-}
-
 .onLoad <- function(libname, pkgname) {
   # R's lazy-loading package scheme causes the private seed to be cached in the
   # package itself, making our PRNG completely deterministic. This line resets
   # the private seed during load.
   withPrivateSeed(set.seed(NULL))
 
+  for (expr in on_load_exprs) {
+    eval(expr, envir = environment(.onLoad))
+  }
+
   # Make sure these methods are available to knitr if shiny is loaded but not
   # attached.
-  register_s3_method("knitr", "knit_print", "reactive")
-  register_s3_method("knitr", "knit_print", "shiny.appobj")
-  register_s3_method("knitr", "knit_print", "shiny.render.function")
-
-  # Shiny 1.4.0 bumps jQuery 1.x to 3.x, which caused a problem
-  # with static-rendering of htmlwidgets, and htmlwidgets 1.5
-  # includes a fix for this problem
-  # https://github.com/rstudio/shiny/issues/2630
-  register_upgrade_message("htmlwidgets", 1.5)
+  s3_register("knitr::knit_print", "reactive")
+  s3_register("knitr::knit_print", "shiny.appobj")
+  s3_register("knitr::knit_print", "shiny.render.function")
 }
+
+
+on_load_exprs <- list()
+# Register an expression to be evaluated when the package is loaded (in the
+# .onLoad function).
+on_load <- function(expr) {
+  on_load_exprs[[length(on_load_exprs) + 1]] <<- substitute(expr)
+}
+
+on_load({
+  IS_SHINY_LOCAL_PKG <- exists(".__DEVTOOLS__")
+})

R/graph.R

@@ -1,32 +1,3 @@
-# Check that the version of an suggested package satisfies the requirements
-#
-# @param package The name of the suggested package
-# @param version The version of the package
-check_suggested <- function(package, version = NULL) {
-
-  if (is_available(package, version)) {
-    return()
-  }
-
-  msg <- paste0(
-    sQuote(package),
-    if (is.na(version %||% 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
 
 
@@ -48,7 +19,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 `options(shiny.reactlog=TRUE)`; then launch your
+#' run the command `reactlog::reactlog_enable()`; 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.
@@ -71,16 +42,20 @@ reactIdStr <- function(num) {
 #' call `reactlogShow()` explicitly.
 #'
 #' For security and performance reasons, do not enable
-#' `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.
+#' `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.
 #'
 #' @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()
@@ -94,20 +69,35 @@ reactlogShow <- function(time = TRUE) {
   check_reactlog()
   reactlog::reactlog_show(reactlog(), time = time)
 }
-#' @describeIn reactlog This function is deprecated. You should use [reactlogShow()]
-#' @export
-# legacy purposes
-showReactLog <- function(time = TRUE) {
-  shinyDeprecated("1.2.0", "showReactLog()", "reactlogShow()")
 
-  reactlogShow(time = time)
-}
-#' @describeIn reactlog Resets the entire reactlog stack.  Useful for debugging and removing all prior reactive history.
+#' @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()
@@ -117,28 +107,15 @@ renderReactlog <- function(sessionToken = NULL, time = TRUE) {
     time = time
   )
 }
+
 check_reactlog <- function() {
-  check_suggested("reactlog", reactlog_version())
-}
-# read reactlog version from description file
-# prevents version mismatch in code and description file
-reactlog_version <- function() {
-  desc <- read.dcf(system.file("DESCRIPTION", package = "shiny", mustWork = TRUE))
-  suggests <- desc[1,"Suggests"][[1]]
-  suggests_pkgs <- strsplit(suggests, "\n")[[1]]
-
-  reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
-  if (length(reactlog_info) == 0) {
-    stop("reactlog can not be found in shiny DESCRIPTION file")
+  if (!is_installed("reactlog", reactlog_min_version)) {
+    rlang::check_installed("reactlog", reactlog_min_version)
   }
-
-  reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
-  reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
-  reactlog_info <- sub("^[>= ]*", "", reactlog_info)
-
-  package_version(reactlog_info)
 }
 
+# Should match the (suggested) version in DESCRIPTION file
+reactlog_min_version <- "1.0.0"
 
 RLog <- R6Class(
   "RLog",
@@ -146,7 +123,6 @@ 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
@@ -161,20 +137,19 @@ 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) {
@@ -189,7 +164,6 @@ 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
@@ -199,10 +173,9 @@ 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
@@ -212,7 +185,7 @@ RLog <- R6Class(
     reset = function() {
       .globals$reactIdCounter <- 0L
 
-      self$logStack <- Stack$new()
+      self$logStack <- fastmap::faststack()
       self$msg <- MessageLogger$new(option = private$msgOption)
 
       # setup dummy and missing react information
@@ -222,7 +195,6 @@ RLog <- R6Class(
     isLogging = function() {
       isTRUE(getOption(private$option, FALSE))
     },
-
     define = function(reactId, value, label, type, domain) {
       valueStr <- self$valueStr(value)
       if (msg$hasReact(reactId)) {
@@ -253,9 +225,10 @@ 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(
@@ -268,7 +241,6 @@ 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))
@@ -282,7 +254,6 @@ 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)
@@ -293,10 +264,9 @@ 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")) {
@@ -339,7 +309,6 @@ RLog <- R6Class(
         ))
       }
     },
-
     valueChange = function(reactId, value, domain) {
       valueStr <- self$valueStr(value)
       msg$log("valueChange:", msg$reactStr(reactId), msg$valueStr(valueStr))
@@ -361,8 +330,6 @@ 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")) {
@@ -405,7 +372,6 @@ RLog <- R6Class(
         ))
       }
     },
-
     invalidateLater = function(reactId, runningCtx, millis, domain) {
       msg$log("invalidateLater: ", millis, "ms", msg$reactStr(reactId), msg$ctxStr(runningCtx))
       private$appendEntry(domain, list(
@@ -415,14 +381,12 @@ 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(
@@ -435,7 +399,6 @@ RLog <- R6Class(
         action = "asyncStop"
       ))
     },
-
     freezeReactiveVal = function(reactId, domain) {
       msg$log("freeze:", msg$reactStr(reactId))
       private$appendEntry(domain, list(
@@ -446,7 +409,6 @@ 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(
@@ -457,54 +419,60 @@ 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) {
@@ -519,17 +487,21 @@ MessageLogger = R6Class(
       return(txt)
     },
     singleLine = function(txt) {
-      gsub("[^\\]\\n", "\\\\n", txt)
+      gsub("([^\\])\\n", "\\1\\\\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)), "'"
       )
@@ -538,11 +510,15 @@ 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),
@@ -550,7 +526,9 @@ MessageLogger = R6Class(
       )
     },
     log = function(...) {
-      if (self$isNotLogging()) return(NULL)
+      if (self$isNotLogging()) {
+        return(NULL)
+      }
       msg <- paste0(
         paste0(rep("= ", depth), collapse = ""), "- ", paste0(..., collapse = ""),
         collapse = ""
@@ -560,5 +538,6 @@ MessageLogger = R6Class(
   )
 )
 
-#' @include stack.R
-rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")
+on_load({
+  rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")
+})

R/history.R

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

R/html-deps.R

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

R/image-interact-opts.R

@@ -20,7 +20,6 @@
 #'   `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")

R/image-interact.R

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

R/imageutils.R

@@ -1,22 +1,23 @@
 startPNG <- function(filename, width, height, res, ...) {
-  # shiny.useragg is an experimental option that isn't officially supported or
-  # documented. It's here in the off chance that someone really wants
-  # to use ragg (say, instead of showtext, for custom font rendering).
-  # In the next shiny release, this option will likely be superseded in
-  # favor of a fully customizable graphics device option
-  if ((getOption('shiny.useragg') %||% FALSE) && is_available("ragg")) {
-    pngfun <- ragg::agg_png
+  pngfun <- if ((getOption('shiny.useragg') %||% TRUE) && is_installed("ragg")) {
+    ragg::agg_png
   } else if (capabilities("aqua")) {
     # i.e., png(type = 'quartz')
-    pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %||% TRUE) && is_available("Cairo")) {
-    pngfun <- Cairo::CairoPNG
+    grDevices::png
+  } else if ((getOption('shiny.usecairo') %||% TRUE) && is_installed("Cairo")) {
+    Cairo::CairoPNG
   } else {
     # i.e., png(type = 'cairo')
-    pngfun <- grDevices::png
+    grDevices::png
   }
 
-  args <- rlang::list2(filename=filename, width=width, height=height, res=res, ...)
+  args <- list2(filename = filename, width = width, height = height, res = res, ...)
+
+  # It's possible for width/height to be NULL/numeric(0) (e.g., when using
+  # suspendWhenHidden=F w/ tabsetPanel(), see rstudio/shiny#1409), so when
+  # this happens let the device determine what the default size should be.
+  if (length(args$width) == 0) args$width <- NULL
+  if (length(args$height) == 0) args$height <- NULL
 
   # Set a smarter default for the device's bg argument (based on thematic's global state).
   # Note that, technically, this is really only needed for CairoPNG, since the other
@@ -57,33 +58,35 @@ startPNG <- function(filename, width, height, res, ...) {
   grDevices::dev.cur()
 }
 
-#' Run a plotting function and save the output as a PNG
+#' Capture a plot as a PNG file.
 #'
-#' This function returns the name of the PNG file that it generates. In
-#' essence, it calls `png()`, then `func()`, then `dev.off()`.
-#' So `func` must be a function that will generate a plot when used this
-#' way.
+#' The PNG graphics device used is determined in the following order:
+#'   * If the ragg package is installed (and the `shiny.useragg` is not
+#'    set to `FALSE`), then use [ragg::agg_png()].
+#'   * If a quartz device is available (i.e., `capabilities("aqua")` is
+#'    `TRUE`), then use `png(type = "quartz")`.
+#'   * If the Cairo package is installed (and the `shiny.usecairo` option
+#'    is not set to `FALSE`), then use [Cairo::CairoPNG()].
+#'   * Otherwise, use [grDevices::png()]. In this case, Linux and Windows
+#'    may not antialias some point shapes, resulting in poor quality output.
 #'
-#' For output, it will try to use the following devices, in this order:
-#' quartz (via [grDevices::png()]), then [Cairo::CairoPNG()],
-#' and finally [grDevices::png()]. This is in order of quality of
-#' output. Notably, plain `png` output on Linux and Windows may not
-#' antialias some point shapes, resulting in poor quality output.
-#'
-#' In some cases, `Cairo()` provides output that looks worse than
-#' `png()`. To disable Cairo output for an app, use
-#' `options(shiny.usecairo=FALSE)`.
+#' @details
+#'   A `NULL` value provided to `width` or `height` is ignored (i.e., the
+#'   default `width` or `height` of the graphics device is used).
 #'
 #' @param func A function that generates a plot.
 #' @param filename The name of the output file. Defaults to a temp file with
 #'   extension `.png`.
 #' @param width Width in pixels.
 #' @param height Height in pixels.
-#' @param res Resolution in pixels per inch. This value is passed to
-#'   [grDevices::png()]. Note that this affects the resolution of PNG rendering in
+#' @param res Resolution in pixels per inch. This value is passed to the
+#'   graphics device. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
-#' @param ... Arguments to be passed through to [grDevices::png()].
-#'   These can be used to set the width, height, background color, etc.
+#' @param ... Arguments to be passed through to the graphics device. These can
+#'   be used to set the width, height, background color, etc.
+#'
+#' @return A path to the newly generated PNG file.
+#'
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
@@ -97,7 +100,7 @@ plotPNG <- function(func, filename=tempfile(fileext='.png'),
 createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
   force(which)
 
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
       function(...) {

R/input-action.R

@@ -7,6 +7,8 @@
 #' @param label The contents of the button or link--usually a text label, but
 #'   you could also use any other HTML, like an image.
 #' @param icon An optional [icon()] to appear on the button.
+#' @param disabled If `TRUE`, the button will not be clickable. Use
+#'   [updateActionButton()] to dynamically enable/disable the button.
 #' @param ... Named attributes to be applied to the button or link.
 #'
 #' @family input elements
@@ -49,16 +51,29 @@
 #'   * Event handlers (e.g., [observeEvent()], [eventReactive()]) won't execute on initial load.
 #'   * Input validation (e.g., [req()], [need()]) will fail on initial load.
 #' @export
-actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
+actionButton <- function(inputId, label, icon = NULL, width = NULL,
+  disabled = FALSE, ...) {
 
   value <- restoreInput(id = inputId, default = NULL)
 
-  tags$button(id=inputId,
+  icon <- validateIcon(icon)
+
+  if (!is.null(icon)) {
+    icon <- span(icon, class = "action-icon")
+  }
+
+  if (!is.null(label)) {
+    label <- span(label, class = "action-label")
+  }
+
+  tags$button(
+    id = inputId,
     style = css(width = validateCssUnit(width)),
-    type="button",
-    class="btn btn-default action-button",
+    type = "button",
+    class = "btn btn-default action-button",
     `data-val` = value,
-    list(validateIcon(icon), label),
+    disabled = if (isTRUE(disabled)) NA else NULL,
+    icon, label,
     ...
   )
 }
@@ -68,30 +83,40 @@ actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
 actionLink <- function(inputId, label, icon = NULL, ...) {
   value <- restoreInput(id = inputId, default = NULL)
 
-  tags$a(id=inputId,
-    href="#",
-    class="action-button",
+  icon <- validateIcon(icon)
+
+  if (!is.null(icon)) {
+    icon <- span(icon, class = "action-icon")
+  }
+
+  if (!is.null(label)) {
+    label <- span(label, class = "action-label")
+  }
+
+  tags$a(
+    id = inputId,
+    href = "#",
+    class = "action-button action-link",
     `data-val` = value,
-    list(validateIcon(icon), label),
+    icon, label,
     ...
   )
 }
 
 
-# Check that the icon parameter is valid:
-# 1) Check  if the user wants to actually add an icon:
-#    -- if icon=NULL, it means leave the icon unchanged
-#    -- if icon=character(0), it means don't add an icon or, more usefully,
-#       remove the previous icon
-# 2) If so, check that the icon has the right format (this does not check whether
-# it is a *real* icon - currently that would require a massive cross reference
-# with the "font-awesome" and the "glyphicon" libraries)
+# Throw an informative warning if icon isn't html-ish
 validateIcon <- function(icon) {
-  if (is.null(icon) || identical(icon, character(0))) {
+  if (length(icon) == 0) {
     return(icon)
-  } else if (inherits(icon, "shiny.tag") && icon$name == "i") {
-    return(icon)
-  } else {
-    stop("Invalid icon. Use Shiny's 'icon()' function to generate a valid icon")
   }
+  if (!isTagLike(icon)) {
+    rlang::warn(
+      c(
+        "It appears that a non-HTML value was provided to `icon`.",
+        i = "Try using a `shiny::icon()` (or an equivalent) to get an icon."
+      ),
+      class = "shiny-validate-icon"
+    )
+  }
+  icon
 }

R/input-checkbox.R

@@ -31,7 +31,7 @@ checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
 
   value <- restoreInput(id = inputId, default = value)
 
-  inputTag <- tags$input(id = inputId, type="checkbox")
+  inputTag <- tags$input(id = inputId, type="checkbox", class = "shiny-input-checkbox")
   if (!is.null(value) && value)
     inputTag$attribs$checked <- "checked"
 

R/input-date.R

@@ -133,14 +133,13 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
 }
 
 
-datePickerVersion <- "1.9.0"
-
 datePickerDependency <- function(theme) {
   list(
     htmlDependency(
       name = "bootstrap-datepicker-js",
-      version = datePickerVersion,
-      src = c(href = "shared/datepicker"),
+      version = version_bs_date_picker,
+      src = "www/shared/datepicker",
+      package = "shiny",
       script = if (getOption("shiny.minified", TRUE)) "js/bootstrap-datepicker.min.js"
                else                                   "js/bootstrap-datepicker.js",
       # Need to enable noConflict mode. See #1346.
@@ -154,23 +153,28 @@ datePickerDependency <- function(theme) {
   )
 }
 
+datePickerSass <- function() {
+  sass::sass_file(
+    system_file(package = "shiny", "www/shared/datepicker/scss/build3.scss")
+  )
+}
+
 datePickerCSS <- function(theme) {
   if (!is_bs_theme(theme)) {
     return(htmlDependency(
       name = "bootstrap-datepicker-css",
-      version = datePickerVersion,
-      src = c(href = "shared/datepicker"),
+      version = version_bs_date_picker,
+      src = "www/shared/datepicker",
+      package = "shiny",
       stylesheet = "css/bootstrap-datepicker3.min.css"
     ))
   }
 
-  scss_file <- system.file(package = "shiny", "www/shared/datepicker/scss/build3.scss")
-
   bslib::bs_dependency(
-    input = sass::sass_file(scss_file),
+    input = datePickerSass(),
     theme = theme,
     name = "bootstrap-datepicker",
-    version = datePickerVersion,
-    cache_key_extra = shinyPackageVersion()
+    version = version_bs_date_picker,
+    cache_key_extra = get_package_version("shiny")
   )
 }

R/input-file.R

@@ -2,8 +2,13 @@
 #'
 #' Create a file upload control that can be used to upload one or more files.
 #'
-#' Whenever a file upload completes, the corresponding input variable is set
-#' to a dataframe. See the `Server value` section.
+#' Whenever a file upload completes, the corresponding input variable is set to
+#' a dataframe. See the `Server value` section.
+#'
+#' Each time files are uploaded, they are written to a new random subdirectory
+#' inside of R's process-level temporary directory. The Shiny user session keeps
+#' track of all uploads in the session, and when the session ends, Shiny deletes
+#' all of the subdirectories where files where uploaded to.
 #'
 #' @family input elements
 #'
@@ -11,19 +16,30 @@
 #' @param multiple Whether the user should be allowed to select and upload
 #'   multiple files at once. **Does not work on older browsers, including
 #'   Internet Explorer 9 and earlier.**
-#' @param accept A character vector of "unique file type specifiers" which
-#'   gives the browser a hint as to the type of file the server expects.
-#'   Many browsers use this prevent the user from selecting an invalid file.
+#' @param accept A character vector of "unique file type specifiers" which gives
+#'   the browser a hint as to the type of file the server expects. Many browsers
+#'   use this prevent the user from selecting an invalid file.
 #'
 #'   A unique file type specifier can be:
 #'   * A case insensitive extension like `.csv` or `.rds`.
 #'   * A valid MIME type, like `text/plain` or `application/pdf`
 #'   * One of `audio/*`, `video/*`, or `image/*` meaning any audio, video,
-#'     or image type, respectively.
+#'   or image type, respectively.
 #' @param buttonLabel The label used on the button. Can be text or an HTML tag
 #'   object.
 #' @param placeholder The text to show before a file has been uploaded.
+#' @param capture What source to use for capturing image, audio or video data.
+#'   This attribute facilitates user access to a device's media capture
+#'   mechanism, such as a camera, or microphone, from within a file upload
+#'   control.
 #'
+#'   A value of `user` indicates that the user-facing camera and/or microphone
+#'   should be used. A value of `environment` specifies that the outward-facing
+#'   camera and/or microphone should be used.
+#'
+#'   By default on most phones, this will accept still photos or video. For
+#'   still photos only, also use `accept="image/*"`. For video only, use
+#'   `accept="video/*"`.
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
@@ -56,7 +72,9 @@
 #' }
 #'
 #' @section Server value:
-#' A `data.frame` that contains one row for each selected file, and following columns:
+#'
+#'   A `data.frame` that contains one row for each selected file, and following
+#'   columns:
 #' \describe{
 #'   \item{`name`}{The filename provided by the web browser. This is
 #'   **not** the path to read to get at the actual data that was uploaded
@@ -73,7 +91,8 @@
 #'
 #' @export
 fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
-  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
+  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected",
+  capture = NULL) {
 
   restoredValue <- restoreInput(id = inputId, default = NULL)
 
@@ -89,6 +108,7 @@ 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/
@@ -101,6 +121,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)),

R/input-numeric.R

@@ -29,22 +29,36 @@
 #' A numeric vector of length 1.
 #'
 #' @export
-numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
-  width = NULL) {
+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)
 
   value <- restoreInput(id = inputId, default = value)
 
   # build input tag
-  inputTag <- tags$input(id = inputId, type = "number", class="form-control",
-                         value = formatNoSci(value))
-  if (!is.na(min))
-    inputTag$attribs$min = min
-  if (!is.na(max))
-    inputTag$attribs$max = max
-  if (!is.na(step))
-    inputTag$attribs$step = step
+  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
 
-  div(class = "form-group shiny-input-container",
+  div(
+    class = "form-group shiny-input-container",
     style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
     inputTag

R/input-password.R

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

R/input-select.R

@@ -4,7 +4,7 @@
 #' from a list of values.
 #'
 #' By default, `selectInput()` and `selectizeInput()` use the JavaScript library
-#' \pkg{selectize.js} (<https://github.com/selectize/selectize.js>) instead of
+#' \pkg{selectize.js} (<https://selectize.dev/>) instead of
 #' the basic select input element. To use the standard HTML select input
 #' element, use `selectInput()` with `selectize=FALSE`.
 #'
@@ -106,6 +106,7 @@ 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)
@@ -172,7 +173,7 @@ needOptgroup <- function(choices) {
 
 #' @rdname selectInput
 #' @param ... Arguments passed to `selectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#' @param options A list of options. See the documentation of \pkg{selectize.js}(<https://selectize.dev/docs/usage>)
 #'   for possible options (character option values inside [base::I()] will
 #'   be treated as literal JavaScript code; see [renderDataTable()]
 #'   for details).
@@ -213,14 +214,7 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
   deps <- list(selectizeDependency())
 
   if ('drag_drop' %in% options$plugins) {
-    deps <- c(
-      deps,
-      list(htmlDependency(
-        'jqueryui', '1.12.1',
-        c(href = 'shared/jqueryui'),
-        script = 'jquery-ui.min.js'
-      ))
-    )
+    deps[[length(deps) + 1]] <- jqueryuiDependency()
   }
 
   # Insert script on same level as <select> tag
@@ -243,20 +237,12 @@ selectizeDependency <- function() {
 }
 
 selectizeDependencyFunc <- function(theme) {
-  selectizeVersion <- "0.12.4"
   if (!is_bs_theme(theme)) {
-    return(selectizeStaticDependency(selectizeVersion))
+    return(selectizeStaticDependency(version_selectize))
   }
 
-  selectizeDir <- system.file(package = "shiny", "www/shared/selectize/")
-  stylesheet <- file.path(
-    selectizeDir, "scss",
-    if ("3" %in% bslib::theme_version(theme)) {
-      "selectize.bootstrap3.scss"
-    } else {
-      "selectize.bootstrap4.scss"
-    }
-  )
+  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
@@ -264,28 +250,46 @@ selectizeDependencyFunc <- function(theme) {
   # name, the JS/CSS would be loaded/included twice, which leads to
   # strange issues, especially since we now include a 3rd party
   # accessibility plugin https://github.com/rstudio/shiny/pull/3153
-  script <- file.path(
-    selectizeDir, c("js/selectize.min.js", "accessibility/js/selectize-plugin-a11y.min.js")
-  )
+  selectizeDir <- system_file(package = "shiny", "www/shared/selectize/")
+  script <- file.path(selectizeDir, selectizeScripts())
+
   bslib::bs_dependency(
-    input = sass::sass_file(stylesheet),
+    input = selectizeSass(bs_version),
     theme = theme,
     name = "selectize",
-    version = selectizeVersion,
-    cache_key_extra = shinyPackageVersion(),
+    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 = c(href = "shared/selectize"),
+    "selectize",
+    version,
+    src = "www/shared/selectize",
+    package = "shiny",
     stylesheet = "css/selectize.bootstrap3.css",
-    script = c(
-      "js/selectize.min.js",
-      "accessibility/js/selectize-plugin-a11y.min.js"
-    )
+    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"
   )
 }
 
@@ -297,7 +301,7 @@ selectizeStaticDependency <- function(version) {
 #'
 #' By default, `varSelectInput()` and `selectizeInput()` use the
 #' JavaScript library \pkg{selectize.js}
-#' (<https://github.com/selectize/selectize.js>) to instead of the basic
+#' (<https://selectize.dev/>) to instead of the basic
 #' select input element. To use the standard HTML select input element, use
 #' `selectInput()` with `selectize=FALSE`.
 #'
@@ -393,7 +397,7 @@ varSelectInput <- function(
 
 #' @rdname varSelectInput
 #' @param ... Arguments passed to `varSelectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#' @param options A list of options. See the documentation of \pkg{selectize.js}(<https://selectize.dev/docs/usage>)
 #'   for possible options (character option values inside [base::I()] will
 #'   be treated as literal JavaScript code; see [renderDataTable()]
 #'   for details).

R/input-slider.R

@@ -19,8 +19,6 @@
 #'   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
@@ -78,23 +76,9 @@
 #'
 #' @export
 sliderInput <- function(inputId, label, min, max, value, step = NULL,
-                        round = FALSE, format = NULL, locale = NULL,
-                        ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
-                        pre = NULL, post = NULL, timeFormat = NULL,
-                        timezone = NULL, dragRange = TRUE) {
-  if (!missing(format)) {
-    shinyDeprecated(
-      "0.10.2.2", "sliderInput(format =)",
-      details = "Use `sep`, `pre`, and `post` instead."
-    )
-  }
-  if (!missing(locale)) {
-    shinyDeprecated(
-      "0.10.2.2", "sliderInput(locale =)",
-      details = "Use `sep`, `pre`, and `post` instead."
-    )
-  }
-
+                        round = FALSE, ticks = TRUE, animate = FALSE,
+                        width = NULL, sep = ",", pre = NULL, post = NULL,
+                        timeFormat = NULL, timezone = NULL, dragRange = TRUE) {
   validate_slider_value(min, max, value, "sliderInput")
 
   dataType <- getSliderType(min, max, value)
@@ -217,59 +201,53 @@ 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", ionRangeSliderVersion,
-      src = c(href = "shared/ionrangeslider"),
+      "ionrangeslider-javascript",
+      version_ion_range_slider,
+      src = "www/shared/ionrangeslider",
+      package = "shiny",
       script = "js/ion.rangeSlider.min.js"
     ),
     htmlDependency(
-      "strftime", "0.9.2",
-      src = c(href = "shared/strftime"),
+      "strftime",
+      version_strftime,
+      src = "www/shared/strftime",
+      package = "shiny",
       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")
+    )
+  )
+}
+
 ionRangeSliderDependencyCSS <- function(theme) {
   if (!is_bs_theme(theme)) {
     return(htmlDependency(
       "ionrangeslider-css",
-      ionRangeSliderVersion,
-      src = c(href = "shared/ionrangeslider"),
+      version_ion_range_slider,
+      src = "www/shared/ionrangeslider",
+      package = "shiny",
       stylesheet = "css/ion.rangeSlider.css"
     ))
   }
 
-  # Remap some variable names for ionRangeSlider's scss
-  sass_input <- list(
-    list(
-      # The bootswatch materia theme sets $input-bg: transparent;
-      # which is an issue for the slider's handle(s) (#3130)
-      bg = "if(alpha($input-bg)==0, $body-bg, $input-bg)",
-      fg = sprintf(
-        "if(alpha($input-color)==0, $%s, $input-color)",
-        if ("3" %in% bslib::theme_version(theme)) "text-color" else "body-color"
-      ),
-      accent = "$component-active-bg",
-      `font-family` = "$font-family-base"
-    ),
-    sass::sass_file(
-      system.file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss")
-    )
-  )
-
   bslib::bs_dependency(
-    input = sass_input,
+    input = ionRangeSliderDependencySass(),
     theme = theme,
     name = "ionRangeSlider",
-    version = ionRangeSliderVersion,
-    cache_key_extra = shinyPackageVersion()
+    version = version_ion_range_slider,
+    cache_key_extra = get_package_version("shiny")
   )
 }
 

R/input-submit.R

@@ -57,7 +57,7 @@ submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
   div(
     tags$button(
       type="submit",
-      class="btn btn-primary",
+      class="btn btn-primary shiny-submit-button",
       style = css(width = validateCssUnit(width)),
       list(icon, text)
     )

R/input-text.R

@@ -10,6 +10,14 @@
 #' @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
@@ -34,15 +42,31 @@
 #' unless `value` is provided.
 #'
 #' @export
-textInput <- function(inputId, label, value = "", width = NULL,
-  placeholder = NULL) {
+textInput <- function(
+  inputId,
+  label,
+  value = "",
+  width = NULL,
+  placeholder = NULL,
+  ...,
+  updateOn = c("change", "blur")
+) {
+  rlang::check_dots_empty()
+  updateOn <- rlang::arg_match(updateOn)
 
   value <- restoreInput(id = inputId, default = value)
 
-  div(class = "form-group shiny-input-container",
+  div(
+    class = "form-group shiny-input-container",
     style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
-    tags$input(id = inputId, type="text", class="form-control", value=value,
-      placeholder = placeholder)
+    tags$input(
+      id = inputId,
+      type = "text",
+      class = "shiny-input-text form-control",
+      value = value,
+      placeholder = placeholder,
+      `data-update-on` = updateOn
+    )
   )
 }

R/input-textarea.R

@@ -16,6 +16,8 @@
 #' @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
@@ -41,8 +43,22 @@
 #' unless `value` is provided.
 #'
 #' @export
-textAreaInput <- function(inputId, label, value = "", width = NULL, height = NULL,
-  cols = NULL, rows = NULL, placeholder = NULL, resize = NULL) {
+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)
 
   value <- restoreInput(id = inputId, default = value)
 
@@ -50,23 +66,30 @@ textAreaInput <- function(inputId, label, value = "", width = NULL, height = NUL
     resize <- match.arg(resize, c("both", "none", "vertical", "horizontal"))
   }
 
-  style <- css(
-    # The width is specified on the parent div.
-    width = if (!is.null(width)) "width: 100%;",
-    height = validateCssUnit(height),
-    resize = resize
-  )
+  classes <- "form-control"
+  if (autoresize) {
+    classes <- c(classes, "textarea-autoresize")
+    if (is.null(rows)) {
+      rows <- 1
+    }
+  }
 
-  div(class = "form-group shiny-input-container",
+  div(
+    class = "shiny-input-textarea form-group shiny-input-container",
+    style = css(width = validateCssUnit(width)),
     shinyInputLabel(inputId, label),
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     tags$textarea(
       id = inputId,
-      class = "form-control",
+      class = classes,
       placeholder = placeholder,
-      style = style,
+      style = css(
+        width = if (!is.null(width)) "100%",
+        height = validateCssUnit(height),
+        resize = resize
+      ),
       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 (anyNamed(choiceNames) || anyNamed(choiceValues)) {
+    if (any_named(choiceNames) || any_named(choiceValues)) {
       stop("`choiceNames` and `choiceValues` must not be named.")
     }
   } else {

R/insert-tab.R

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

R/insert-ui.R

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

R/jqueryui.R

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

R/knitr.R

@@ -4,6 +4,7 @@
 #' themselves in knitr/rmarkdown documents.
 #'
 #' @name knitr_methods
+#' @keywords internal
 #' @param x Object to knit_print
 #' @param ... Additional knit_print arguments
 NULL
@@ -62,7 +63,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))
+  output <- knitr::knit_print(tagList(x), ..., inline = inline)
   attr(output, "knit_cacheable") <- FALSE
   attr(output, "knit_meta") <- append(attr(output, "knit_meta"),
                                       shiny_rmd_warning())
@@ -76,5 +77,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,4 +1,3 @@
-#' @importFrom fastmap fastmap
 Map <- R6Class(
   'Map',
   portable = FALSE,
@@ -49,9 +48,12 @@ Map <- R6Class(
   )
 )
 
-as.list.Map <- function(map) {
-  map$values()
+#' @export
+as.list.Map <- function(x, ...) {
+  x$values()
 }
-length.Map <- function(map) {
-  map$size()
+
+#' @export
+length.Map <- function(x) {
+  x$size()
 }

R/middleware.R

@@ -348,7 +348,7 @@ HandlerManager <- R6Class("HandlerManager",
                   httpResponse(status = 500L,
                     content_type = "text/html; charset=UTF-8",
                     content = as.character(htmltools::htmlTemplate(
-                      system.file("template", "error.html", package = "shiny"),
+                      system_file("template", "error.html", package = "shiny"),
                       message = conditionMessage(err)
                     ))
                   )

R/mock-session.R

@@ -1,5 +1,5 @@
 # Promise helpers taken from:
-#   https://github.com/rstudio/promises/blob/master/tests/testthat/common.R
+#   https://github.com/rstudio/promises/blob/main/tests/testthat/common.R
 # Block until all pending later tasks have executed
 wait_for_it <- function() {
   while (!later::loop_empty()) {
@@ -259,7 +259,7 @@ MockShinySession <- R6Class(
       private$file_generators <- fastmap()
 
       private$timer <- MockableTimerCallbacks$new()
-      self$progressStack <- Stack$new()
+      self$progressStack <- fastmap::faststack()
 
       self$userData <- new.env(parent=emptyenv())
 
@@ -436,29 +436,36 @@ MockShinySession <- R6Class(
       if (!is.function(func))
         stop(paste("Unexpected", class(func), "output for", name))
 
-      obs <- observe({
-        # We could just stash the promise, but we get an "unhandled promise error". This bypasses
-        prom <- NULL
-        tryCatch({
-          v <- private$withCurrentOutput(name, func(self, name))
-          if (!promises::is.promise(v)){
-            # Make our sync value into a promise
-            prom <- promises::promise(function(resolve, reject){ resolve(v) })
-          } else {
-            prom <- v
-          }
-        }, error=function(e){
-          # Error running value()
-          prom <<- promises::promise(function(resolve, reject){ reject(e) })
-        })
-
-        private$outs[[name]]$promise <- hybrid_chain(
-          prom,
-          function(v){
-            list(val = v, err = NULL)
-          }, catch=function(e){
-            list(val = NULL, err = e)
+      with_no_otel_collect({
+        obs <- observe({
+          # We could just stash the promise, but we get an "unhandled promise error". This bypasses
+          prom <- NULL
+          tryCatch({
+            v <- private$withCurrentOutput(name, func(self, name))
+            if (!is.promise(v)){
+              # Make our sync value into a promise
+              prom <- promise_resolve(v)
+            } else {
+              prom <- v
+            }
+          }, error=function(e){
+            # Error running value()
+            prom <<- promise_reject(e)
           })
+
+          private$outs[[name]]$promise <- hybrid_chain(
+            prom,
+            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)
+            })
+        })
       })
       private$outs[[name]] <- list(obs = obs, func = func, promise = NULL)
     },
@@ -560,10 +567,26 @@ MockShinySession <- R6Class(
     rootScope = function() {
       self
     },
+    #' @description Add an unhandled error callback.
+    #' @param callback The callback to add, which should accept an error object
+    #'   as its first argument.
+    #' @return A deregistration function.
+    onUnhandledError = function(callback) {
+      private$unhandledErrorCallbacks$register(callback)
+    },
     #' @description Called by observers when a reactive expression errors.
     #' @param e An error object.
-    unhandledError = function(e) {
-      self$close()
+    #' @param close If `TRUE`, the session will be closed after the error is
+    #'  handled, defaults to `FALSE`.
+    unhandledError = function(e, close = TRUE) {
+      if (close) {
+        class(e) <- c("shiny.error.fatal", class(e))
+      }
+
+      private$unhandledErrorCallbacks$invoke(e, onError = printError)
+      .globals$onUnhandledErrorCallbacks$invoke(e, onError = printError)
+
+      if (close) self$close()
     },
     #' @description Freeze a value until the flush cycle completes.
     #' @param x A `ReactiveValues` object.
@@ -620,6 +643,9 @@ MockShinySession <- R6Class(
     flushedCBs = NULL,
     # @field endedCBs `Callbacks` called when session ends.
     endedCBs = NULL,
+    # @field unhandledErrorCallbacks `Callbacks` called when an unhandled error
+    #   occurs.
+    unhandledErrorCallbacks = Callbacks$new(),
     # @field timer `MockableTimerCallbacks` called at particular times.
     timer = NULL,
     # @field was_closed Set to `TRUE` once the session is closed.
@@ -692,7 +718,7 @@ MockShinySession <- R6Class(
         stop("Nested calls to withCurrentOutput() are not allowed.")
       }
 
-      promises::with_promise_domain(
+      with_promise_domain(
         createVarPromiseDomain(private, "currentOutputName", name),
         expr
       )

R/modal.R

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

R/otel-attr-srcref.R

@@ -0,0 +1,65 @@
+
+
+# Very similar to srcrefFromShinyCall(),
+# however, this works when the function does not have a srcref attr set
+otel_srcref_attributes <- function(srcref, fn_name = NULL) {
+  if (is.function(srcref)) {
+    srcref <- getSrcRefs(srcref)[[1]][[1]]
+  }
+
+  if (is.null(srcref)) {
+    return(NULL)
+  }
+
+  stopifnot(inherits(srcref, "srcref"))
+
+  # Semantic conventions for code: https://opentelemetry.io/docs/specs/semconv/registry/attributes/code/
+  #
+  # Inspiration from https://github.com/r-lib/testthat/pull/2087/files#diff-92de3306849d93d6f7e76c5aaa1b0c037e2d716f72848f8a1c70536e0c8a1564R123-R124
+  filename <- attr(srcref, "srcfile")$filename
+  dropNulls(list(
+    "code.function.name" = fn_name,
+    # Location attrs
+    "code.file.path" = filename,
+    "code.line.number" = srcref[1],
+    "code.column.number" = srcref[2],
+    # Remove these deprecated location names once Logfire supports the preferred names
+    # https://github.com/pydantic/logfire/issues/1559
+    "code.filepath" = filename,
+    "code.lineno" = srcref[1],
+    "code.column" = srcref[2]
+  ))
+}
+
+#' Get the srcref for the call at the specified stack level
+#'
+#' If you need to go farther back in the `sys.call()` stack, supply a larger
+#' negative number to `which_offset`. The default of 0 gets the immediate
+#' caller. `-1` would get the caller's caller, and so on.
+#' @param which_offset The stack level to get the call from. Defaults to -1 (the
+#'   immediate caller).
+#' @return An srcref object, or NULL if none is found.
+#' @noRd
+get_call_srcref <- function(which_offset = 0) {
+  # Go back one call to account for this function itself
+  call <- sys.call(which_offset - 1)
+
+  srcref <- attr(call, "srcref", exact = TRUE)
+  srcref
+}
+
+
+append_otel_srcref_attrs <- function(attrs, call_srcref, fn_name) {
+  if (is.null(call_srcref)) {
+    return(attrs)
+  }
+
+  srcref_attrs <- otel_srcref_attributes(call_srcref, fn_name)
+  if (is.null(srcref_attrs)) {
+    return(attrs)
+  }
+
+  attrs[names(srcref_attrs)] <- srcref_attrs
+
+  attrs
+}

R/otel-collect.R

@@ -0,0 +1,55 @@
+otel_collect_choices <- c(
+  "none",
+  "session",
+  "reactive_update",
+  "reactivity",
+  "all"
+)
+
+# Check if the collect level is sufficient
+otel_collect_is_enabled <- function(
+  impl_level,
+  # Listen to option and fall back to the env var
+  opt_collect_level = getOption("shiny.otel.collect", Sys.getenv("SHINY_OTEL_COLLECT", "all"))
+) {
+  opt_collect_level <- as_otel_collect(opt_collect_level)
+
+  which(opt_collect_level == otel_collect_choices) >=
+    which(impl_level == otel_collect_choices)
+}
+
+# Check if tracing is enabled and if the collect level is sufficient
+has_otel_collect <- function(collect) {
+  # Only check pkg author input iff loaded with pkgload
+  if (IS_SHINY_LOCAL_PKG) {
+    stopifnot(length(collect) == 1, any(collect == otel_collect_choices))
+  }
+
+  otel_is_tracing_enabled() && otel_collect_is_enabled(collect)
+}
+
+# Run expr with otel collection disabled
+with_no_otel_collect <- function(expr) {
+  withOtelCollect("none", expr)
+}
+
+
+## -- Helpers -----------------------------------------------------
+
+# shiny.otel.collect can be:
+# "none"; To do nothing / fully opt-out
+# "session" for session/start events
+# "reactive_update" (includes "session" features) and reactive_update spans
+# "reactivity" (includes "reactive_update" features) and spans for all reactive things
+# "all" - Anything that Shiny can do. (Currently equivalent to the "reactivity" level)
+
+as_otel_collect <- function(collect = "all") {
+  if (!is.character(collect)) {
+    stop("`collect` must be a character vector.")
+  }
+
+  # Match to collect enum
+  collect <- match.arg(collect, otel_collect_choices, several.ok = FALSE)
+
+  return(collect)
+}

R/otel-enable.R

@@ -0,0 +1,194 @@
+# # Approach
+# Use flags on the reactive object to indicate whether to record OpenTelemetry spans.
+#
+# Cadence:
+# * `$.isRecordingOtel` - Whether to record OpenTelemetry spans for this reactive object
+# * `$.otelLabel` - The label to use for the OpenTelemetry span
+# * `$.otelAttrs` - Additional attributes to add to the OpenTelemetry span
+
+
+#' Add OpenTelemetry for reactivity to an object
+#'
+#' @description
+#'
+#' `enable_otel_*()` methods add OpenTelemetry flags for [reactive()] expressions
+#' and `render*` functions (like [renderText()], [renderTable()], ...).
+#'
+#' Wrapper to creating an active reactive OpenTelemetry span that closes when
+#' the reactive expression is done computing. Typically this is when the
+#' reactive expression finishes (synchronous) or when the returned promise is
+#' done computing (asynchronous).
+
+#' @section Async with OpenTelemetry:
+#'
+#'   With a 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.
+#'
+#'   When reactive expressions are being calculated in parallel (by having
+#'   another reactive promise compute in the main process), the currently active
+#'   OpenTelemetry span will be dynamically swapped out according to the
+#'   currently active reactive expression. This means that as long as a promise
+#'   was `then()`ed or `catch()`ed with an active OpenTelemetry span, the span
+#'   will be correctly propagated to the next step (and subsequently other
+#'   steps) in the promise chain.
+#'
+#'   While the common case is for a reactive expression to be created
+#'   synchronously, troubles arise when the reactive expression is created
+#'   asynchronously. The span **must** be created before the reactive expression
+#'   is executed, it **must** be active for the duration of the expression, and
+#'   it **must** not be closed until the reactive expression is done executing.
+#'   This is not easily achieved with a single function call, so we provide a
+#'   way to create a reactive expression that is bound to an OpenTelemetry
+#'   span.
+#'
+#' @section Span management and performance:
+#'
+#' Dev note - Barret 2025-10:
+#' Typically, an OpenTelemetry span (`otel_span`) will inherit from the parent
+#' span. This works well and we can think of the hierarchy as a tree. With
+#' `options("shiny.otel.collect" = <value>)`, we are able to control with a sliding
+#' dial how much of the tree we are interested in: "none", "session",
+#' "reactive_update", "reactivity", and finally "all".
+#'
+#' Leveraging this hierarchy, we can avoid creating spans that are not needed.
+#' The act of making a noop span takes on the order of 10microsec. Handling of
+#' the opspan is also in the 10s of microsecond range. We should avoid this when
+#' we **know** that we're not interested in the span.  Therefore, manually
+#' handling spans should be considered for Shiny.
+#'
+#' * Q:
+#'   * But what about app author who want the current span? Is there any
+#'     guarantee that the current span is expected `reactive()` span?
+#' * A:
+#'   * No. The current span is whatever the current span is. If the app author
+#'     wants a specific span, they should create it themselves.
+#' * Proof:
+#'   ```r
+#'   noop <- otel::get_active_span()
+#'   noop$get_context()$get_span_id()
+#'   #> [1] "0000000000000000"
+#'   ignore <- otelsdk::with_otel_record({
+#'     a <- otel::start_local_active_span("a")
+#'     a$get_context()$get_span_id() |> str()
+#'     otel::with_active_span(noop, {
+#'       otel::get_active_span()$get_context()$get_span_id() |> str()
+#'     })
+#'   })
+#'   #> chr "2645e95715841e75"
+#'   #> chr "2645e95715841e75"
+#'   # ## It is reasonable to expect the second id to be `0000000000000000`, but it's not.
+#'   ```
+#'   Therefore, the app author has no guarantee that the current span is the
+#'   span they're expecting. If the app author wants a specific span, they should
+#'   create it themselves and let natural inheritance take over.
+#'
+#' Given this, I will imagine that app authors will set
+#' `options("shiny.otel.collect" = "reactive_update")` as their default behavior.
+#' Enough to know things are happening, but not overwhelming from **everything**
+#' that is reactive.
+#'
+#' To _light up_ a specific area, users can call `withr::with_options(list("shiny.otel.collect" = "all"), { ... })`.
+#'
+#' @param x The object to add caching to.
+#' @param ... Future parameter expansion.
+#' @noRd
+NULL
+
+
+enable_otel_reactive_val <- function(x) {
+
+  impl <- attr(x, ".impl", exact = TRUE)
+  # Set flag for otel logging when setting the value
+  impl$.isRecordingOtel <- TRUE
+
+  class(x) <- c("reactiveVal.otel", class(x))
+
+  x
+}
+
+enable_otel_reactive_values <- function(x) {
+
+  impl <- .subset2(x, "impl")
+  # Set flag for otel logging when setting values
+  impl$.isRecordingOtel <- TRUE
+
+  class(x) <- c("reactivevalues.otel", class(x))
+
+  x
+}
+
+enable_otel_reactive_expr <- function(x) {
+
+  domain <- reactive_get_domain(x)
+
+  impl <- attr(x, "observable", exact = TRUE)
+  impl$.isRecordingOtel <- TRUE
+  # Covers both reactive and reactive.event
+  impl$.otelLabel <- otel_span_label_reactive(x, domain = impl$.domain)
+
+  class(x) <- c("reactiveExpr.otel", class(x))
+
+  x
+}
+
+enable_otel_observe <- function(x) {
+  x$.isRecordingOtel <- TRUE
+  x$.otelLabel <- otel_span_label_observer(x, domain = x$.domain)
+
+  class(x) <- c("Observer.otel", class(x))
+  invisible(x)
+}
+
+
+
+enable_otel_shiny_render_function <- function(x) {
+
+  valueFunc <- force(x)
+  otel_span_label <- NULL
+  otel_span_attrs <- NULL
+
+  renderFunc <- function(...) {
+    # Dynamically determine the span label given the current reactive domain
+    if (is.null(otel_span_label)) {
+      domain <- getDefaultReactiveDomain()
+      otel_span_label <<-
+        otel_span_label_render_function(x, domain = domain)
+      otel_span_attrs <<- c(
+        attr(x, "otelAttrs"),
+        otel_session_id_attrs(domain)
+      )
+    }
+
+    with_otel_span(
+      otel_span_label,
+      {
+        hybrid_then(
+          valueFunc(...),
+          on_failure = set_otel_exception_status_and_throw,
+          # Must save the error object
+          tee = FALSE
+        )
+      },
+      attributes = otel_span_attrs
+    )
+  }
+
+  renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
+  class(renderFunc) <- c("shiny.render.function.otel", class(valueFunc))
+  renderFunc
+}
+
+
+# ## If we ever expose a S3 function, I'd like to add this method.
+# bindOtel.function <- function(x, ...) {
+#   cli::cli_abort(paste0(
+#     "Don't know how to add OpenTelemetry recording to a plain function. ",
+#     "If this is a {.code render*()} function for Shiny, it may need to be updated. ",
+#     "Please see {.help shiny::bindOtel} for more information."
+#   ))
+# }

R/otel-error.R

@@ -0,0 +1,56 @@
+
+has_seen_otel_exception <- function(cnd) {
+  !is.null(cnd$.shiny_otel_exception)
+}
+
+mark_otel_exception_as_seen <- function(cnd) {
+  cnd$.shiny_otel_exception <- TRUE
+  cnd
+}
+
+set_otel_exception_status_and_throw <- function(cnd) {
+  cnd <- set_otel_exception_status(cnd)
+
+  # Rethrow the (possibly updated) error
+  signalCondition(cnd)
+}
+
+set_otel_exception_status <- function(cnd) {
+  if (inherits(cnd, "shiny.custom.error")) {
+    # No-op
+  } else if (inherits(cnd, "shiny.output.cancel")) {
+    # No-op
+  } else if (inherits(cnd, "shiny.output.progress")) {
+    # No-op
+  } else if (cnd_inherits(cnd, "shiny.silent.error")) {
+    # No-op
+  } else {
+    # Only when an unknown error occurs do we set the span status to error
+    span <- otel::get_active_span()
+
+    # Only record the exception once at the original point of failure,
+    # not every reactive expression that it passes through
+    if (!has_seen_otel_exception(cnd)) {
+      span$record_exception(
+        # Record a sanitized error if sanitization is enabled
+        get_otel_error_obj(cnd)
+      )
+      cnd <- mark_otel_exception_as_seen(cnd)
+    }
+
+    # Record the error status on the span for any context touching this error
+    span$set_status("error")
+  }
+
+  cnd
+}
+
+
+get_otel_error_obj <- function(e) {
+  # Do not expose errors to otel if sanitization is enabled
+  if (getOption("shiny.otel.sanitize.errors", TRUE)) {
+    sanitized_error()
+  } else {
+    e
+  }
+}

R/otel-label.R

@@ -0,0 +1,198 @@
+# observe mymod:<anonymous>
+# observe <anonymous>
+# observe mylabel
+
+# -- Reactives --------------------------------------------------------------
+
+#' OpenTelemetry Label Generation Functions
+#'
+#' Functions for generating formatted labels for OpenTelemetry tracing spans
+#' in Shiny applications. These functions handle module namespacing and
+#' cache/event modifiers for different Shiny reactive constructs.
+#'
+#' @param x The object to generate a label for (reactive, observer, etc.)
+#' @param label Character string label for reactive values
+#' @param key Character string key for reactiveValues operations
+#' @param ... Additional arguments (unused)
+#' @param domain Shiny domain object containing namespace information
+#'
+#' @return Character string formatted for OpenTelemetry span labels
+#' @name otel_label
+#' @noRd
+NULL
+
+otel_span_label_reactive <- function(x, ..., domain) {
+  fn_name <- otel_label_with_modifiers(
+    x,
+    "reactive",
+    cache_class = "reactive.cache",
+    event_class = "reactive.event"
+  )
+
+  label <- attr(x, "observable", exact = TRUE)[[".label"]]
+  otel_span_label <- otel_label_upgrade(label, domain = domain)
+
+  sprintf("%s %s", fn_name, otel_span_label)
+}
+
+otel_span_label_render_function <- function(x, ..., domain) {
+  fn_name <- otel_label_with_modifiers(
+    x,
+    "output",
+    cache_class = "shiny.render.function.cache",
+    event_class = "shiny.render.function.event"
+  )
+
+  label <- getCurrentOutputInfo(session = domain)$name %||% "<unknown>"
+  otel_span_label <- otel_label_upgrade(label, domain = domain)
+
+  sprintf("%s %s", fn_name, otel_span_label)
+}
+
+otel_span_label_observer <- function(x, ..., domain) {
+  fn_name <- otel_label_with_modifiers(
+    x,
+    "observe",
+    cache_class = NULL, # Do not match a cache class here
+    event_class = "Observer.event"
+  )
+
+  otel_span_label <- otel_label_upgrade(x$.label, domain = domain)
+
+  sprintf("%s %s", fn_name, otel_span_label)
+}
+
+# -- Set reactive value(s) ----------------------------------------------------
+
+otel_log_label_set_reactive_val <- function(label, ..., domain) {
+  sprintf(
+    "Set reactiveVal %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+otel_log_label_set_reactive_values <- function(label, key, ..., domain) {
+  sprintf(
+    "Set reactiveValues %s$%s",
+    otel_label_upgrade(label, domain = domain),
+    key
+  )
+}
+
+# -- ExtendedTask -------------------------------------------------------------
+
+otel_span_label_extended_task <- function(label, suffix = NULL, ..., domain) {
+  sprintf(
+    "ExtendedTask %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+otel_log_label_extended_task_add_to_queue <- function(label, ..., domain) {
+  sprintf(
+    "ExtendedTask %s add to queue",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+# -- Debounce / Throttle -------------------------------------------------------
+
+otel_label_debounce <- function(label, ..., domain) {
+  sprintf(
+    "debounce %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+otel_label_throttle <- function(label, ..., domain) {
+  sprintf(
+    "throttle %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+# ---- Reactive Poll / File Reader -----------------------------------------------
+otel_label_reactive_poll <- function(label, ..., domain) {
+  sprintf(
+    "reactivePoll %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+otel_label_reactive_file_reader <- function(label, ..., domain) {
+  sprintf(
+    "reactiveFileReader %s",
+    otel_label_upgrade(label, domain = domain)
+  )
+}
+
+# -- Helpers --------------------------------------------------------------
+
+#' Modify function name based on object class modifiers
+#'
+#' @param x Object to check class of
+#' @param fn_name Base function name
+#' @param cache_class Optional class name that indicates cache operation
+#' @param event_class Optional class name that indicates event operation
+#'
+#' @return Modified function name with "cache" or "event" suffix if applicable
+#' @noRd
+otel_label_with_modifiers <- function(
+  x,
+  fn_name,
+  cache_class = NULL,
+  event_class = NULL
+) {
+  for (x_class in rev(class(x))) {
+    if (!is.null(cache_class) && x_class == cache_class) {
+      fn_name <- sprintf("%s cache", fn_name)
+    } else if (!is.null(event_class) && x_class == event_class) {
+      fn_name <- sprintf("%s event", fn_name)
+    }
+  }
+
+  fn_name
+}
+
+
+#' Upgrade and format OpenTelemetry labels with module namespacing
+#'
+#' Processes labels for OpenTelemetry tracing, replacing default verbose labels
+#' with cleaner alternatives and prepending module namespaces when available.
+#'
+#' @param label Character string label to upgrade
+#' @param ... Additional arguments (unused)
+#' @param domain Shiny domain object containing namespace information
+#'
+#' @return Modified label string with module prefix if applicable
+#' @noRd
+#'
+#' @details
+#' Module prefix examples:
+#' - "" -> ""
+#' - "my-nested-mod-" -> "my-nested-mod"
+otel_label_upgrade <- function(label, ..., domain) {
+  # By default, `observe()` sets the label to `observe(CODE)`
+  # This label is too big and inconsistent.
+  # Replace it with `<anonymous>`
+  # (Similar with `eventReactive()` and `observeEvent()`)
+  if (is_default_label(label) && grepl("(", label, fixed = TRUE)) {
+    label <- "<anonymous>"
+    # label <- sprintf("<anonymous> - %s", label)
+  }
+
+  if (is.null(domain)) {
+    return(label)
+  }
+
+  namespace <- domain$ns("")
+
+  if (!nzchar(namespace)) {
+    return(label)
+  }
+
+  # Remove trailing module separator
+  mod_ns <- sub(sprintf("%s$", ns.sep), "", namespace)
+
+  # Prepend the module name to the label
+  # Ex: `"mymod:x"`
+  sprintf("%s:%s", mod_ns, label)
+}

R/otel-reactive-update.R

@@ -0,0 +1,114 @@
+# * `session$userData[["_otel_span_reactive_update"]]` - The active reactive update span (or `NULL`)
+
+
+#' Start a `reactive_update` OpenTelemetry span and store it
+#'
+#' Used when a reactive expression is updated
+#' Will only start the span iff the otel tracing is enabled
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @return Invisibly returns.
+#' @seealso `otel_span_reactive_update_teardown()`
+#' @noRd
+otel_span_reactive_update_init <- function(..., domain) {
+
+  if (!has_otel_collect("reactive_update")) return()
+
+  # Ensure cleanup is registered only once per session
+  if (is.null(domain$userData[["_otel_has_reactive_cleanup"]])) {
+    domain$userData[["_otel_has_reactive_cleanup"]] <- TRUE
+
+    # Clean up any dangling reactive spans on an unplanned exit
+    domain$onSessionEnded(function() {
+      otel_span_reactive_update_teardown(domain = domain)
+    })
+  }
+
+  # Safety check
+  if (is_otel_span(domain$userData[["_otel_span_reactive_update"]])) {
+    stop("Reactive update span already exists")
+  }
+
+  domain$userData[["_otel_span_reactive_update"]] <-
+    start_otel_span(
+      "reactive_update",
+      ...,
+      attributes = otel_session_id_attrs(domain)
+    )
+
+  invisible()
+}
+
+#' End a `reactive_update` OpenTelemetry span and remove it from the session
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @return Invisibly returns.
+#' @seealso `otel_span_reactive_update_init()`
+#' @noRd
+otel_span_reactive_update_teardown <- function(..., domain) {
+  ospan <- domain$userData[["_otel_span_reactive_update"]]
+
+  if (is_otel_span(ospan)) {
+    otel::end_span(ospan)
+    domain$userData[["_otel_span_reactive_update"]] <- NULL
+  }
+
+  invisible()
+}
+
+
+#' Run expr within a `reactive_update` OpenTelemetry span
+#'
+#' Used to wrap the execution of a reactive expression. Will only
+#' require/activate the span iff the otel tracing is enabled
+#' @param expr The expression to executed within the span
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @noRd
+with_otel_span_reactive_update <- function(expr, ..., domain) {
+  ospan <- domain$userData[["_otel_span_reactive_update"]]
+
+  if (!is_otel_span(ospan)) {
+    return(force(expr))
+  }
+
+  # Given the reactive update span is started before and ended when exec count
+  # is 0, we only need to wrap the expr in the span context
+  otel::with_active_span(ospan, {force(expr)})
+}
+
+
+#' Run expr within `reactive_update` otel span if not already active
+#'
+#' If the reactive update otel span is not already active, run the expression
+#' within the reactive update otel span context. This ensures that nested calls
+#' to reactive expressions do not attempt to re-enter the same span.
+#'
+#' This method is used within Context `run()` and running an Output's observer
+#' implementation
+#' @param expr The expression to executed within the span
+#' @param ... Ignored
+#' @param domain The reactive domain to associate with the span
+#' @noRd
+maybe_with_otel_span_reactive_update <- function(expr, ..., domain) {
+  if (is.null(domain$userData[["_otel_reactive_update_is_active"]])) {
+    domain$userData[["_otel_reactive_update_is_active"]] <- TRUE
+
+    # When the expression is done promising, clear the active flag
+    hybrid_then(
+      {
+        with_otel_span_reactive_update(domain = domain, expr)
+      },
+      on_success = function(value) {
+        domain$userData[["_otel_reactive_update_is_active"]] <- NULL
+      },
+      on_failure = function(e) {
+        domain$userData[["_otel_reactive_update_is_active"]] <- NULL
+      },
+      # Return the value before the callbacks
+      tee = TRUE
+    )
+  } else {
+    expr
+  }
+}

R/otel-session.R

@@ -0,0 +1,96 @@
+# Semantic conventions for session: https://opentelemetry.io/docs/specs/semconv/general/session/
+
+#' Create and use session span and events
+#'
+#' If otel is disabled, the session span and events will not be created,
+#' however the expression will still be evaluated.
+#'
+#' Span: `session_start`, `session_end`
+#' @param expr Expression to evaluate within the session span
+#' @param ... Ignored
+#' @param domain The reactive domain
+#' @noRd
+otel_span_session_start <- function(expr, ..., domain) {
+
+  if (!has_otel_collect("session")) {
+    return(force(expr))
+  }
+
+  # Wrap the server initialization
+  with_otel_span(
+    "session_start",
+    expr,
+    attributes = otel::as_attributes(c(
+      otel_session_id_attrs(domain),
+      otel_session_attrs(domain)
+    ))
+  )
+}
+
+
+otel_span_session_end <- function(expr, ..., domain) {
+  if (!has_otel_collect("session")) {
+    return(force(expr))
+  }
+
+  id_attrs <- otel_session_id_attrs(domain)
+  with_otel_span(
+    "session_end",
+    expr,
+    attributes = id_attrs
+  )
+}
+
+# -- Helpers -------------------------------
+
+
+# Occurs when the websocket connection is established
+otel_session_attrs <- function(domain) {
+  # TODO: Future: Posit Connect integration
+  # > we are still trying to identify all of the information we want to track/expose
+  #
+  # * `POSIT_PRODUCT` (Fallback to RSTUDIO_PRODUCT) for host environment
+  # * `CONNECT_SERVER` envvar to get the `session.address`.
+  # * `CONNECT_CONTENT_GUID` for the consistent app distinguisher
+  # * Maybe `CONNECT_CONTENT_JOB_KEY`?
+  # * Maybe `user.id` to be their user name: https://opentelemetry.io/docs/specs/semconv/registry/attributes/user/
+  attrs <- list(
+    server.path =
+      sub(
+        "/websocket/$", "/",
+        domain[["request"]][["PATH_INFO"]] %||% ""
+      ),
+    server.address = domain[["request"]][["HTTP_HOST"]] %||% "",
+    server.origin = domain[["request"]][["HTTP_ORIGIN"]] %||% "",
+    ## Currently, Shiny does not expose QUERY_STRING when connecting the websocket
+    # so we do not provide it here.
+    # QUERY_STRING = domain[["request"]][["QUERY_STRING"]] %||% "",
+    server.port = domain[["request"]][["SERVER_PORT"]] %||% NA_integer_
+  )
+  # Safely convert SERVER_PORT to integer
+  # If conversion fails, leave as-is (string or empty)
+  # This avoids warnings/errors if SERVER_PORT is not a valid integer
+  server_port <- suppressWarnings(as.integer(attrs$server.port))
+  if (!is.na(server_port)) {
+    attrs$server.port <- server_port
+  }
+
+  attrs
+}
+
+otel_session_id_attrs <- function(domain) {
+  token <- domain$token
+  if (is.null(token)) {
+    return(list())
+  }
+
+  list(
+    # Convention for client-side with session.start and session.end events
+    # https://opentelemetry.io/docs/specs/semconv/general/session/
+    #
+    # Since we are the server, we'll add them as an attribute to _every_ span
+    # within the session as we don't know exactly when they will be called.
+    # Given it's only a single attribute, the cost should be minimal, but it ties every reactive calculation together.
+    session.id = token
+  )
+}

R/otel-shiny.R

@@ -0,0 +1,127 @@
+# Used by otel to identify the tracer and logger for this package
+# https://github.com/r-lib/otel/blob/afc31bc1f4bd177870d44b051ada1d9e4e685346/R/tracer-name.R#L33-L49
+# DO NOT CHANGE THIS VALUE without understanding the implications for existing telemetry data!
+otel_tracer_name <- "co.posit.r-package.shiny"
+
+init_otel <- function() {
+  .globals$otel_tracer <- otel::get_tracer()
+  .globals$otel_is_tracing_enabled <- otel::is_tracing_enabled(.globals$otel_tracer)
+
+  .globals$otel_logger <- otel::get_logger()
+  # .globals$otel_is_logging_enabled <- otel::is_logging_enabled()
+}
+on_load({init_otel()})
+
+#' Run expr within a Shiny OpenTelemetry recording context
+#'
+#' Reset the OpenTelemetry tracer and logger for Shiny.
+#' Used for testing purposes only.
+#' @param expr Expression to evaluate within the recording context
+#' @return The result of evaluating `otelsdk::with_otel_record(expr)` with freshly enabled Shiny otel tracer and logger
+#' @noRd
+with_shiny_otel_record <- function(expr) {
+  # Only use within internal testthat tests
+  stopifnot(testthat__is_testing())
+  withr::defer({ init_otel() })
+
+  otelsdk::with_otel_record({
+    init_otel()
+
+    force(expr)
+  })
+}
+
+#' Check if OpenTelemetry tracing is enabled
+#'
+#' @param tracer The OpenTelemetry tracer to check (default: Shiny otel tracer)
+#' @return `TRUE` if tracing is enabled, `FALSE` otherwise
+#' @noRd
+otel_is_tracing_enabled <- function() {
+  .globals[["otel_is_tracing_enabled"]]
+}
+
+#' Shiny OpenTelemetry logger
+#'
+#' Used for logging OpenTelemetry events via `otel_log()`
+#' @return An OpenTelemetry logger
+#' @noRd
+shiny_otel_logger <- function() {
+  .globals[["otel_logger"]]
+}
+
+
+
+#' Shiny OpenTelemetry tracer
+#'
+#' Used for creating OpenTelemetry spans via `with_otel_span()` and
+#' `start_otel_span()`
+#'
+#' Inspired by httr2:::get_tracer().
+#' @return An OpenTelemetry tracer
+#' @noRd
+shiny_otel_tracer <- function() {
+  .globals[["otel_tracer"]]
+}
+
+
+
+
+#' Create and use a Shiny OpenTelemetry span
+#'
+#' If otel is disabled, the span will not be created,
+#' however the expression will still be evaluated.
+#' @param name Span name
+#' @param expr Expression to evaluate within the span
+#' @param ... Ignored
+#' @param attributes Optional span attributes
+#' @return The result of evaluating `expr`
+#' @noRd
+with_otel_span <- function(name, expr, ..., attributes = NULL) {
+  promises::with_otel_span(name, expr, ..., attributes = attributes, tracer = shiny_otel_tracer())
+}
+
+
+#' Start a Shiny OpenTelemetry span
+#'
+#' @param name Span name
+#' @param ... Additional arguments passed to `otel::start_span()`
+#' @return An OpenTelemetry span
+#' @noRd
+start_otel_span <- function(name, ...) {
+  otel::start_span(name, ..., tracer = shiny_otel_tracer())
+}
+
+
+# # TODO: Set attributes on the current active span
+# # 5. Set attributes on the current active span
+# set_otel_span_attrs(status = 200L)
+
+
+# -- Helpers --------------------------------------------------------------
+
+
+is_otel_span <- function(x) {
+  inherits(x, "otel_span")
+}
+
+testthat__is_testing <- function() {
+  # testthat::is_testing()
+  identical(Sys.getenv("TESTTHAT"), "true")
+}
+
+#' Log a message using the Shiny OpenTelemetry logger
+#'
+#' @param msg The log message
+#' @param ... Additional attributes to add to the log record
+#' @param severity The log severity level (default: "info")
+#' @param logger The OpenTelemetry logger to use (default: Shiny otel logger)
+#' @return Invisibly returns.
+#' @noRd
+otel_log <- function(
+  msg,
+  ...,
+  severity = "info",
+  logger = shiny_otel_logger()
+) {
+  otel::log(msg, ..., severity = severity, logger = logger)
+}

R/otel-with.R

@@ -0,0 +1,125 @@
+#' Temporarily set OpenTelemetry (OTel) collection level
+#'
+#' @description
+#' Control Shiny's OTel collection level for particular reactive expression(s).
+#'
+#' `withOtelCollect()` sets the OpenTelemetry collection level for
+#' the duration of evaluating `expr`. `localOtelCollect()` sets the collection
+#' level for the remainder of the current function scope.
+#'
+#' @details
+#' Note that `"session"` and `"reactive_update"` levels are not permitted as
+#' these are runtime-specific levels that should only be set permanently via
+#' `options(shiny.otel.collect = ...)` or the `SHINY_OTEL_COLLECT` environment
+#' variable, not temporarily during reactive expression creation.
+#'
+#' @section Best practice:
+#'
+#' Best practice is to set the collection level for code that *creates* reactive
+#' expressions, not code that *runs* them. For instance:
+#'
+#' ```r
+#' # Disable telemetry for a reactive expression
+#' withOtelCollect("none", {
+#'   my_reactive <- reactive({ ... })
+#' })
+#'
+#' # Disable telemetry for a render function
+#' withOtelCollect("none", {
+#'   output$my_plot <- renderPlot({ ... })
+#' })
+#'
+#' #' # Disable telemetry for an observer
+#' withOtelCollect("none", {
+#'   observe({ ... }))
+#' })
+#'
+#' # Disable telemetry for an entire module
+#' withOtelCollect("none", {
+#'   my_result <- my_module("my_id")
+#' })
+#' # Use `my_result` as normal here
+#' ```
+#'
+#' NOTE: It's not recommended to pipe existing reactive objects into
+#' `withOtelCollect()` since they won't inherit their intended OTel settings,
+#' leading to confusion.
+#'
+#' @param collect Character string specifying the OpenTelemetry collection level.
+#'   Must be one of the following:
+#'
+#'     * `"none"` - No telemetry data collected
+#'     * `"reactivity"` - Collect reactive execution spans (includes session and
+#'       reactive update events)
+#'     * `"all"` - All available telemetry (currently equivalent to `"reactivity"`)
+#' @param expr Expression to evaluate with the specified collection level
+#'   (for `withOtelCollect()`).
+#' @param envir Environment where the collection level should be set
+#'   (for `localOtelCollect()`). Defaults to the parent frame.
+#'
+#' @return
+#' * `withOtelCollect()` returns the value of `expr`.
+#' * `localOtelCollect()` is called for its side effect and returns the previous
+#'   `collect` value invisibly.
+#'
+#' @seealso See the `shiny.otel.collect` option within [`shinyOptions`]. Setting
+#' this value will globally control OpenTelemetry collection levels.
+#'
+#' @examples
+#' \dontrun{
+#' # Temporarily disable telemetry collection
+#' withOtelCollect("none", {
+#'   # Code here won't generate telemetry
+#'   reactive({ input$x + 1 })
+#' })
+#'
+#' # Collect reactivity telemetry but not other events
+#' withOtelCollect("reactivity", {
+#'   # Reactive execution will be traced
+#'   observe({ print(input$x) })
+#' })
+#'
+#' # Use local variant in a function
+#' my_function <- function() {
+#'   localOtelCollect("none")
+#'   # Rest of function executes without telemetry
+#'   reactive({ input$y * 2 })
+#' }
+#' }
+#'
+#' @rdname withOtelCollect
+#' @export
+withOtelCollect <- function(collect, expr) {
+  collect <- as_otel_collect_with(collect)
+
+  withr::with_options(
+    list(shiny.otel.collect = collect),
+    expr
+  )
+}
+
+#' @rdname withOtelCollect
+#' @export
+localOtelCollect <- function(collect, envir = parent.frame()) {
+  collect <- as_otel_collect_with(collect)
+
+  old <- withr::local_options(
+    list(shiny.otel.collect = collect),
+    .local_envir = envir
+  )
+
+  invisible(old)
+}
+
+# Helper function to validate collect levels for with/local functions
+# Only allows "none", "reactivity", and "all" - not "session" or "reactive_update"
+as_otel_collect_with <- function(collect) {
+  if (!is.character(collect)) {
+    stop("`collect` must be a character vector.")
+  }
+
+  allowed_levels <- c("none", "reactivity", "all")
+  collect <- match.arg(collect, allowed_levels, several.ok = FALSE)
+
+  return(collect)
+}

R/react.R

@@ -16,6 +16,60 @@ processId <- local({
   }
 })
 
+ctx_otel_info_obj <- function(
+  isRecordingOtel = FALSE,
+  otelLabel = "<unknown>",
+  otelAttrs = list()
+) {
+  structure(
+    list(
+      isRecordingOtel = isRecordingOtel,
+      otelLabel = otelLabel,
+      otelAttrs = otelAttrs
+    ),
+    class = "ctx_otel_info"
+  )
+}
+
+with_otel_span_context <- function(otel_info, expr, domain) {
+  if (!otel_is_tracing_enabled()) {
+    return(force(expr))
+  }
+
+  isRecordingOtel <- .subset2(otel_info, "isRecordingOtel")
+  otelLabel <- .subset2(otel_info, "otelLabel")
+  otelAttrs <- .subset2(otel_info, "otelAttrs")
+
+  # Always set the reactive update span as active
+  # This ensures that any spans created within the reactive context
+  # are at least children of the reactive update span
+  maybe_with_otel_span_reactive_update(domain = domain, {
+    if (isRecordingOtel) {
+      with_otel_span(
+        otelLabel,
+        {
+          # Works with both sync and async expressions
+          # Needed for both observer and reactive contexts
+          hybrid_then(
+            expr,
+            on_failure = set_otel_exception_status_and_throw,
+            # Must upgrade the error object
+            tee = FALSE
+          )
+        },
+        # expr,
+        attributes = otelAttrs
+      )
+    } else {
+      force(expr)
+    }
+  })
+
+}
+
+
+
+
 #' @include graph.R
 Context <- R6Class(
   'Context',
@@ -33,11 +87,14 @@ Context <- R6Class(
     .pid = NULL,
     .weak = NULL,
 
+    .otel_info = NULL,
+
     initialize = function(
       domain, label='', type='other', prevId='',
       reactId = rLog$noReactId,
       id = .getReactiveEnvironment()$nextId(), # For dummy context
-      weak = FALSE
+      weak = FALSE,
+      otel_info = ctx_otel_info_obj()
     ) {
       id <<- id
       .label <<- label
@@ -47,16 +104,27 @@ Context <- R6Class(
       .reactType <<- type
       .weak <<- weak
       rLog$createContext(id, label, type, prevId, domain)
+      if (!is.null(otel_info)) {
+        if (IS_SHINY_LOCAL_PKG) {
+          stopifnot(inherits(otel_info, "ctx_otel_info"))
+        }
+        .otel_info <<- otel_info
+      }
     },
     run = function(func) {
       "Run the provided function under this context."
 
+      # Use `promises::` as it shows up in the stack trace
       promises::with_promise_domain(reactivePromiseDomain(), {
         withReactiveDomain(.domain, {
-          env <- .getReactiveEnvironment()
-          rLog$enter(.reactId, id, .reactType, .domain)
-          on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
-          env$runWith(self, func)
+          with_otel_span_context(.otel_info, domain = .domain, {
+            captureStackTraces({
+              env <- .getReactiveEnvironment()
+              rLog$enter(.reactId, id, .reactType, .domain)
+              on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
+              env$runWith(self, func)
+            })
+          })
         })
       })
     },
@@ -219,27 +287,31 @@ getDummyContext <- function() {
 
 wrapForContext <- function(func, ctx) {
   force(func)
-  force(ctx)
+  force(ctx) # may be NULL (in the case of maskReactiveContext())
 
   function(...) {
-    ctx$run(function() {
-      captureStackTraces(
-        func(...)
-      )
+    .getReactiveEnvironment()$runWith(ctx, function() {
+      func(...)
     })
   }
 }
 
 reactivePromiseDomain <- function() {
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
-      ctx <- getCurrentContext()
+
+      # ctx will be NULL if we're in a maskReactiveContext()
+      ctx <- if (hasCurrentContext()) getCurrentContext() else NULL
+
       wrapForContext(onFulfilled, ctx)
     },
     wrapOnRejected = function(onRejected) {
       force(onRejected)
-      ctx <- getCurrentContext()
+
+      # ctx will be NULL if we're in a maskReactiveContext()
+      ctx <- if (hasCurrentContext()) getCurrentContext() else NULL
+
       wrapForContext(onRejected, ctx)
     }
   )

R/reactive-domains.R

@@ -45,6 +45,8 @@ createMockDomain <- function() {
   callbacks <- Callbacks$new()
   ended <- FALSE
   domain <- new.env(parent = emptyenv())
+  domain$ns <- function(id) id
+  domain$token <- "mock-domain"
   domain$onEnded <- function(callback) {
     return(callbacks$register(callback))
   }
@@ -95,7 +97,11 @@ getDefaultReactiveDomain <- function() {
 #' @rdname domains
 #' @export
 withReactiveDomain <- function(domain, expr) {
-  promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
+  # Use `promises::` as it shows up in the stack trace
+  promises::with_promise_domain(
+    createVarPromiseDomain(.globals, "domain", domain),
+    expr
+  )
 }
 
 #

R/reexports.R

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

R/render-cached-plot.R

@@ -181,7 +181,7 @@
 #' # 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 = cachem::cache_disk(file.path(dirname(tempdir()), "myapp-cache")))
 #'
 #' # At the top of app.R, this set the application-scoped cache to be a disk
 #' # cache that can be shared among multiple concurrent R processes, and

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 [grDevices::png()]. Note that this affects the resolution of PNG
+#'   passed to [plotPNG()]. Note that this affects the resolution of PNG
 #'   rendering in R; it won't change the actual ppi of the browser.
-#' @param 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()].
+#' @param alt Alternate text for the HTML `<img>` tag if it cannot be displayed
+#'   or viewed (i.e., the user uses a screen reader). In addition to a character
+#'   string, the value may be a reactive expression (or a function referencing
+#'   reactive values) that returns a character string. If the value is `NA` (the
+#'   default), then `ggplot2::get_alt_text()` is used to extract alt text from
+#'   ggplot objects; for other plots, `NA` results in alt text of "Plot object".
+#'   `NULL` or `""` is not recommended because those should be limited to
+#'   decorative images.
+#' @param ... Arguments to be passed through to [plotPNG()].
 #'   These can be used to set the width, height, background color, etc.
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
+#' @inheritParams renderUI
 #' @param execOnResize If `FALSE` (the default), then when a plot is
 #'   resized, Shiny will *replay* the plot drawing commands with
 #'   [grDevices::replayPlot()] instead of re-executing `expr`.
@@ -58,15 +58,18 @@
 #'   interactive R Markdown document.
 #' @export
 renderPlot <- function(expr, width = 'auto', height = 'auto', res = 72, ...,
-                       alt = "Plot object",
+                       alt = NA,
                        env = parent.frame(), quoted = FALSE,
                        execOnResize = FALSE, outputArgs = list()
 ) {
 
-  expr <- get_quosure(expr, env, quoted)
-  # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
-  # is called
-  func <- quoToFunction(expr, "renderPlot", ..stacktraceon = TRUE)
+  func <- installExprFunction(
+    expr, "func", env, quoted,
+    label = "renderPlot",
+    # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
+    # is called
+    ..stacktraceon = TRUE
+  )
 
   args <- list(...)
 
@@ -184,15 +187,15 @@ renderPlot <- function(expr, width = 'auto', height = 'auto', res = 72, ...,
     outputFunc,
     renderFunc,
     outputArgs,
-    cacheHint = list(userExpr = get_expr(expr), res = res)
+    cacheHint = list(userExpr = installedFuncExpr(func), res = res)
   )
   class(markedFunc) <- c("shiny.renderPlot", class(markedFunc))
   markedFunc
 }
 
 resizeSavedPlot <- function(name, session, result, width, height, alt, pixelratio, res, ...) {
-  if (result$img$width == width && result$img$height == height &&
-      result$pixelratio == pixelratio && result$res == res) {
+  if (isTRUE(result$img$width == width && result$img$height == height &&
+      result$pixelratio == pixelratio && result$res == res)) {
     return(result)
   }
 
@@ -212,7 +215,7 @@ resizeSavedPlot <- function(name, session, result, width, height, alt, pixelrati
     src = session$fileUrl(name, outfile, contentType = "image/png"),
     width = width,
     height = height,
-    alt = alt,
+    alt = result$alt,
     coordmap = coordmap,
     error = attr(coordmap, "error", exact = TRUE)
   )
@@ -250,7 +253,7 @@ drawPlot <- function(name, session, func, width, height, alt, pixelratio, res, .
 
   hybrid_chain(
     hybrid_chain(
-      promises::with_promise_domain(domain, {
+      with_promise_domain(domain, {
         hybrid_chain(
           func(),
           function(value) {
@@ -263,6 +266,8 @@ 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
@@ -288,6 +293,7 @@ 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
             )
           }
@@ -302,10 +308,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 = alt,
+        alt = result$alt,
         coordmap = result$coordmap,
         # Get coordmap error message if present
         error = attr(result$coordmap, "error", exact = TRUE)
@@ -339,6 +345,24 @@ custom_print.ggplot <- function(x) {
   ), class = "ggplot_build_gtable")
 }
 
+# Infer alt text description from renderPlot() value
+# (currently just ggplot2 is supported)
+getAltText <- function(x, default = "Plot object") {
+  # Since, inside renderPlot(), custom_print.ggplot()
+  # overrides print.ggplot, this class indicates a ggplot()
+  if (!inherits(x, "ggplot_build_gtable")) {
+    return(default)
+  }
+  # ggplot2::get_alt_text() was added in v3.3.4
+  # https://github.com/tidyverse/ggplot2/pull/4482
+  get_alt <- getNamespace("ggplot2")$get_alt_text
+  if (!is.function(get_alt)) {
+    return(default)
+  }
+  alt <- paste(get_alt(x$build), collapse = " ")
+  if (nzchar(alt)) alt else default
+}
+
 # The coordmap extraction functions below return something like the examples
 # below. For base graphics:
 # plot(mtcars$wt, mtcars$mpg)
@@ -590,7 +614,7 @@ getGgplotCoordmap <- function(p, width, height, res) {
 find_panel_info <- function(b) {
   # Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
   # an API for extracting the necessary information.
-  ggplot_ver <- utils::packageVersion("ggplot2")
+  ggplot_ver <- get_package_version("ggplot2")
 
   if (ggplot_ver > "2.2.1") {
     find_panel_info_api(b)

R/render-table.R

@@ -42,9 +42,7 @@
 #'   (i.e. they either evaluate to `NA` or `NaN`).
 #' @param ... Arguments to be passed through to [xtable::xtable()]
 #'   and [xtable::print.xtable()].
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)?
-#'   This is useful if you want to save an expression in a variable.
+#' @inheritParams renderUI
 #' @param outputArgs A list of arguments to be passed through to the
 #'   implicit call to [tableOutput()] when `renderTable` is
 #'   used in an interactive R Markdown document.
@@ -74,8 +72,7 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
                         env = parent.frame(), quoted = FALSE,
                         outputArgs=list())
 {
-  expr <- get_quosure(expr, env, quoted)
-  func <- quoToFunction(expr, "renderTable")
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderTable")
 
   if (!is.function(spacing)) spacing <- match.arg(spacing)
 

R/run-url.R

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

R/runapp.R

@@ -22,10 +22,13 @@
 #' @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.
+#'   use a random port between 3000:8000, excluding ports that are blocked
+#'   by Google Chrome for being considered unsafe: 3659, 4045, 5060,
+#'   5061, 6000, 6566, 6665:6669 and 6697. Up to twenty random
+#'   ports will be tried.
 #' @param launch.browser If true, the system's default web browser will be
 #'   launched automatically after the app is started. Defaults to true in
-#'   interactive sessions only. This value of this parameter can also be a
+#'   interactive sessions only. The value of this parameter can also be a
 #'   function to call with the application's URL.
 #' @param host The IPv4 address that the application should listen on. Defaults
 #'   to the `shiny.host` option, if set, or `"127.0.0.1"` if not. See
@@ -81,13 +84,22 @@
 #'   runApp(app)
 #' }
 #' @export
-runApp <- function(appDir=getwd(),
-                   port=getOption('shiny.port'),
-                   launch.browser = getOption('shiny.launch.browser', interactive()),
-                   host=getOption('shiny.host', '127.0.0.1'),
-                   workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase"),
-                   test.mode=getOption('shiny.testmode', FALSE)) {
+runApp <- function(
+  appDir=getwd(),
+  port=getOption('shiny.port'),
+  launch.browser = getOption('shiny.launch.browser', interactive()),
+  host=getOption('shiny.host', '127.0.0.1'),
+  workerId="", quiet=FALSE,
+  display.mode=c("auto", "normal", "showcase"),
+  test.mode=getOption('shiny.testmode', FALSE)
+) {
+
+  # * Wrap **all** execution of the app inside the otel promise domain
+  # * While this could be done at a lower level, it allows for _anything_ within
+  #   shiny's control to allow for the opportunity to have otel active spans be
+  #   reactivated upon promise domain restoration
+  promises::local_otel_promise_domain()
+
   on.exit({
     handlerManager$clear()
   }, add = TRUE)
@@ -301,7 +313,8 @@ 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
-          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
+          # https://chromium.googlesource.com/chromium/src.git/+/refs/heads/main/net/base/port_util.cc
+          if (!port %in% c(3659, 4045, 5060, 5061, 6000, 6566, 6665:6669, 6697)) {
             break
           }
         }
@@ -441,8 +454,20 @@ 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
-#'   `showcase`, but may be set to `normal` to see the example without
+#'   `"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
 #'   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
@@ -458,32 +483,46 @@ 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")) {
-  examplesDir <- system.file('examples', package='shiny')
+runExample <- function(
+  example = NA,
+  port = getOption("shiny.port"),
+  launch.browser = getOption("shiny.launch.browser", interactive()),
+  host = getOption("shiny.host", "127.0.0.1"),
+  display.mode = c("auto", "normal", "showcase"),
+  package = "shiny"
+) {
+  if (!identical(package, "shiny") && !is_installed(package)) {
+    rlang::check_installed(package)
+  }
+
+  use_legacy_shiny_examples <-
+    identical(package, "shiny") &&
+    isTRUE(getOption('shiny.legacy.examples', FALSE))
+
+  examplesDir <- system_file(
+    if (use_legacy_shiny_examples) "examples" else "examples-shiny",
+    package = package
+  )
+
   dir <- resolve(examplesDir, example)
+
   if (is.null(dir)) {
+    valid_examples <- sprintf(
+      'Valid examples in {%s}: "%s"',
+      package,
+      paste(list.files(examplesDir), collapse = '", "')
+    )
+
     if (is.na(example)) {
-      errFun <- message
-      errMsg <- ''
-    }
-    else {
-      errFun <- stop
-      errMsg <- paste('Example', example, 'does not exist. ')
+      message(valid_examples)
+      return(invisible())
     }
 
-    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)
+    stop("Example '", example, "' does not exist. ", valid_examples)
   }
+
+  runApp(dir, port = port, host = host, launch.browser = launch.browser,
+         display.mode = display.mode)
 }
 
 #' Run a gadget

R/serializers.R

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

R/server-input-handlers.R

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

R/server.R

@@ -1,7 +1,12 @@
 #' @include server-input-handlers.R
 
-appsByToken <- Map$new()
-appsNeedingFlush <- Map$new()
+appsByToken <- NULL
+appsNeedingFlush <- NULL
+on_load({
+  appsByToken <- Map$new()
+  appsNeedingFlush <- Map$new()
+})
+
 
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
@@ -29,7 +34,7 @@ registerClient <- function(client) {
 
 #' Define Server Functionality
 #'
-#' @description \lifecycle{superseded}
+#' @description `r lifecycle::badge("superseded")`
 #'
 #' @description Defines the server-side logic of the Shiny application. This generally
 #' involves creating functions that map user inputs to various kinds of output.
@@ -49,7 +54,7 @@ registerClient <- function(client) {
 #' optional `session` parameter, which is used when greater control is
 #' needed.
 #'
-#' See the [tutorial](https://rstudio.github.io/shiny/tutorial/) for more
+#' See the [tutorial](https://shiny.rstudio.com/tutorial/) for more
 #' on how to write a server function.
 #'
 #' @param func The server function for this application. See the details section
@@ -122,13 +127,16 @@ decodeMessage <- function(data) {
   return(mainMessage)
 }
 
-autoReloadCallbacks <- Callbacks$new()
+autoReloadCallbacks <- NULL
+on_load({
+  autoReloadCallbacks <- Callbacks$new()
+})
 
 createAppHandlers <- function(httpHandlers, serverFuncSource) {
   appvars <- new.env()
   appvars$server <- NULL
 
-  sys.www.root <- system.file('www', package='shiny')
+  sys.www.root <- system_file('www', package='shiny')
 
   # This value, if non-NULL, must be present on all HTTP and WebSocket
   # requests as the Shiny-Shared-Secret header or else access will be
@@ -266,15 +274,20 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
                 args <- argsForServerFunc(serverFunc, shinysession)
 
                 withReactiveDomain(shinysession, {
-                  do.call(
-                    # No corresponding ..stacktraceoff; the server func is pure
-                    # user code
-                    wrapFunctionLabel(appvars$server, "server",
-                      ..stacktraceon = TRUE
-                    ),
-                    args
-                  )
+                  otel_span_session_start(domain = shinysession, {
+
+                    do.call(
+                      # No corresponding ..stacktraceoff; the server func is pure
+                      # user code
+                      wrapFunctionLabel(appvars$server, "server",
+                        ..stacktraceon = TRUE
+                      ),
+                      args
+                    )
+
+                  })
                 })
+
               })
             },
             update = {
@@ -331,7 +344,7 @@ argsForServerFunc <- function(serverFunc, session) {
 getEffectiveBody <- function(func) {
   if (is.null(func))
     NULL
-  else if (isS4(func) && class(func) == "functionWithTrace")
+  else if (isS4(func) && inherits(func, "functionWithTrace"))
     body(func@original)
   else
     body(func)
@@ -385,7 +398,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,16 +65,20 @@ getShinyOption <- function(name, default = NULL) {
 #'   changes are detected, all connected Shiny sessions are reloaded. This
 #'   allows for fast feedback loops when tweaking Shiny UI.
 #'
-#'   Since monitoring for changes is expensive (we simply poll for last
-#'   modified times), this feature is intended only for development.
+#'   Monitoring for changes is no longer expensive, thanks to the \pkg{watcher}
+#'   package, but this feature is still 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"))`.
 #'
-#'   The default polling interval is 500 milliseconds. You can change this
-#'   by setting e.g. `options(shiny.autoreload.interval = 2000)` (every
-#'   two seconds).}
+#'   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.}
 #' \item{shiny.deprecation.messages (defaults to `TRUE`)}{This controls whether messages for
 #'   deprecated functions in Shiny will be printed. See
 #'   [shinyDeprecated()] for more information.}
@@ -88,12 +92,17 @@ getShinyOption <- function(name, default = NULL) {
 #' \item{shiny.host (defaults to `"127.0.0.1"`)}{The IP address that Shiny should listen on. See
 #'   [runApp()] for more information.}
 #' \item{shiny.jquery.version (defaults to `3`)}{The major version of jQuery to use.
-#' Currently only values of `3` or `1` are supported. If `1`, then jQuery 1.12.4 is used. If `3`,
-#' then jQuery 3.5.1 is used.}
-#' \item{shiny.json.digits (defaults to `16`)}{The number of digits to use when converting
-#'   numbers to JSON format to send to the client web browser.}
+#'   Currently only values of `3` or `1` are supported. If `1`, then jQuery 1.12.4 is used. If `3`,
+#'   then jQuery `r version_jquery` is used.}
+#' \item{shiny.json.digits (defaults to `I(16)`)}{Max number of digits to use when converting
+#'   numbers to JSON format to send to the client web browser. Use [I()] to specify significant digits.
+#'   Use `NA` for max precision.}
 #' \item{shiny.launch.browser (defaults to `interactive()`)}{A boolean which controls the default behavior
 #'   when an app is run. See [runApp()] for more information.}
+#' \item{shiny.mathjax.url (defaults to `"https://mathjax.rstudio.com/latest/MathJax.js"`)}{
+#'   The URL that should be used to load MathJax, via [withMathJax()].}
+#' \item{shiny.mathjax.config (defaults to `"config=TeX-AMS-MML_HTMLorMML"`)}{The querystring
+#'   used to load MathJax, via [withMathJax()].}
 #' \item{shiny.maxRequestSize (defaults to 5MB)}{This is a number which specifies the maximum
 #'   web request size, which serves as a size limit for file uploads.}
 #' \item{shiny.minified (defaults to `TRUE`)}{By default
@@ -108,7 +117,7 @@ getShinyOption <- function(name, default = NULL) {
 #'   production.}
 #' \item{shiny.sanitize.errors (defaults to `FALSE`)}{If `TRUE`, then normal errors (i.e.
 #'   errors not wrapped in `safeError`) won't show up in the app; a simple
-#'   generic error message is printed instead (the error and strack trace printed
+#'   generic error message is printed instead (the error and stack trace printed
 #'   to the console remain unchanged). If you want to sanitize errors in general, but you DO want a
 #'   particular error `e` to get displayed to the user, then set this option
 #'   to `TRUE` and use `stop(safeError(e))` for errors you want the
@@ -125,6 +134,9 @@ 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),
@@ -133,15 +145,46 @@ 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.usecairo (defaults to `TRUE`)}{This is used to disable graphical rendering by the
-#'   Cairo package, if it is installed. See [plotPNG()] for more
-#'   information.}
+#' \item{shiny.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.otel.collect (defaults to `Sys.getenv("SHINY_OTEL_COLLECT",
+#'   "all")`)}{Determines how Shiny will interact with OpenTelemetry.
+#'
+#'   Supported values:
+#'   * `"none"` - No Shiny OpenTelemetry tracing.
+#'   * `"session"` - Adds session start/end spans.
+#'   * `"reactive_update"` - Spans for any synchronous/asynchronous reactive
+#'     update. (Includes `"session"` features).
+#'   * `"reactivity"` - Spans for all reactive expressions and logs for setting
+#'     reactive vals and values. (Includes `"reactive_update"` features). This
+#'     option must be set when creating any reactive objects that should record
+#'     OpenTelemetry spans / logs. See [`withOtelCollect()`] and
+#'     [`localOtelCollect()`] for ways to set this option locally when creating
+#'     your reactive expressions.
+#'   * `"all"` - All Shiny OpenTelemetry tracing. Currently equivalent to
+#'     `"reactivity"`.
+#'
+#'   This option is useful for debugging and profiling while in production. This
+#'   option will only be useful if the `otelsdk` package is installed and
+#'   `otel::is_tracing_enabled()` returns `TRUE`. Please have any OpenTelemetry
+#'   environment variables set before loading any relevant R packages.
+#'
+#'   To set this option locally within a specific part of your Shiny
+#'   application, see [`withOtelCollect()`] and [`localOtelCollect()`].}
+#' \item{shiny.otel.sanitize.errors (defaults to `TRUE`)}{If `TRUE`, fatal and unhandled errors will be sanitized before being sent to the OpenTelemetry backend. The default value of `TRUE` is set to avoid potentially sending sensitive information to the OpenTelemetry backend. If you want the full error message and stack trace to be sent to the OpenTelemetry backend, set this option to `FALSE` or use `safeError(e)`.}
 #' }
 #'
 #'
@@ -178,7 +221,7 @@ getShinyOption <- function(name, default = NULL) {
 #' @aliases shiny-options
 #' @export
 shinyOptions <- function(...) {
-  newOpts <- list(...)
+  newOpts <- list2(...)
 
   if (length(newOpts) > 0) {
     # If we're within a session, modify at the session level.

R/shiny-package.R

@@ -1,28 +1,30 @@
 # See also R/reexports.R
 
 ## usethis namespace: start
-## usethis namespace: end
-#' @importFrom lifecycle deprecated
+#' @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
+#'     %...!% %...>%
+#'    as.promise is.promising is.promise
+#'    promise_resolve promise_reject
+#'    hybrid_then
+#'    with_promise_domain new_promise_domain
 #' @importFrom rlang
-#'    quo enquo as_function get_expr get_env new_function enquos
+#'    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
+#'    is_false list2
 #'    missing_arg is_missing maybe_missing
-#' @importFrom ellipsis
+#'    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
@@ -32,3 +34,11 @@ NULL
 # 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 stack.R
+#' @include utils.R
 NULL
 
 #' Web Application Framework for R
@@ -16,8 +16,7 @@ NULL
 #'
 #' @name shiny-package
 #' @aliases shiny
-#' @docType package
-NULL
+"_PACKAGE"
 
 createUniqueId <- function(bytes, prefix = "", suffix = "") {
   withPrivateSeed({
@@ -33,8 +32,12 @@ createUniqueId <- function(bytes, prefix = "", suffix = "") {
 }
 
 toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
-  auto_unbox = TRUE, digits = getOption("shiny.json.digits", 16),
-  use_signif = TRUE, force = TRUE, POSIXt = "ISO8601", UTC = TRUE,
+  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,
   rownames = FALSE, keep_vec_names = TRUE, strict_atomic = TRUE) {
 
   if (strict_atomic) {
@@ -185,9 +188,11 @@ workerId <- local({
 #'   session is actually connected.
 #' }
 #' \item{request}{
-#'   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).
+#'   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).
 #' }
 #' \item{userData}{
 #'   An environment for app authors and module/package authors to store whatever
@@ -209,7 +214,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 soley to convey information
+#'   have no meaning to Shiny itself; they are used solely 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){...})}
@@ -343,8 +348,8 @@ ShinySession <- R6Class(
     websocket = 'ANY',
     invalidatedOutputValues = 'Map',
     invalidatedOutputErrors = 'Map',
-    inputMessageQueue = list(), # A list of inputMessages to send when flushed
-    cycleStartActionQueue = list(), # A list of actions to perform to start a cycle
+    inputMessageQueue = 'fastqueue',     # A list of inputMessages to send when flushed
+    cycleStartActionQueue = 'fastqueue', # 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',
@@ -357,6 +362,7 @@ ShinySession <- R6Class(
     flushCallbacks = 'Callbacks',
     flushedCallbacks = 'Callbacks',
     inputReceivedCallbacks = 'Callbacks',
+    unhandledErrorCallbacks = 'Callbacks',
     bookmarkCallbacks = 'Callbacks',
     bookmarkedCallbacks = 'Callbacks',
     restoreCallbacks = 'Callbacks',
@@ -403,7 +409,7 @@ ShinySession <- R6Class(
     sendMessage = function(...) {
       # This function is a wrapper for $write
       msg <- list(...)
-      if (anyUnnamed(msg)) {
+      if (any_unnamed(msg)) {
         stop("All arguments to sendMessage must be named.")
       }
       private$write(toJSON(msg))
@@ -422,7 +428,7 @@ ShinySession <- R6Class(
         stop("Nested calls to withCurrentOutput() are not allowed.")
       }
 
-      promises::with_promise_domain(
+      with_promise_domain(
         createVarPromiseDomain(private, "currentOutputName", name),
         expr
       )
@@ -478,6 +484,35 @@ ShinySession <- R6Class(
           # "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"
+              }
+            }
 
           values <- list()
 
@@ -520,7 +555,7 @@ ShinySession <- R6Class(
               }
             )
 
-            values$input <- sortByName(values$input)
+            values$input <- sortByName(values$input, method = sortMethod)
           }
 
           if (!is.null(params$output)) {
@@ -548,7 +583,7 @@ ShinySession <- R6Class(
               }
             )
 
-            values$output <- sortByName(values$output)
+            values$output <- sortByName(values$output, method = sortMethod)
           }
 
           if (!is.null(params$export)) {
@@ -569,7 +604,7 @@ ShinySession <- R6Class(
               )
             }
 
-            values$export <- sortByName(values$export)
+            values$export <- sortByName(values$export, method = sortMethod)
           }
 
           # Make sure input, output, and export are all named lists (at this
@@ -622,9 +657,8 @@ ShinySession <- R6Class(
     startCycle = function() {
       # TODO: This should check for busyCount == 0L, and remove the checks from
       # the call sites
-      if (length(private$cycleStartActionQueue) > 0) {
-        head <- private$cycleStartActionQueue[[1L]]
-        private$cycleStartActionQueue <- private$cycleStartActionQueue[-1L]
+      if (private$cycleStartActionQueue$size() > 0) {
+        head <- private$cycleStartActionQueue$remove()
 
         # After we execute the current cycleStartAction (head), there may be
         # more items left on the queue. If the current busyCount > 0, then that
@@ -643,7 +677,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 && length(private$cycleStartActionQueue) > 0L) {
+          if (private$busyCount == 0L && private$cycleStartActionQueue$size() > 0L) {
             later::later(function() {
               if (private$busyCount == 0L) {
                 private$startCycle()
@@ -681,6 +715,8 @@ 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()
@@ -688,10 +724,11 @@ 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 <- Stack$new()
+      self$progressStack <- fastmap::faststack()
       self$files <- Map$new()
       self$downloads <- Map$new()
       self$userData <- new.env(parent = emptyenv())
@@ -824,7 +861,7 @@ ShinySession <- R6Class(
             dots <- eval(substitute(alist(...)))
           }
 
-          if (anyUnnamed(dots))
+          if (any_unnamed(dots))
             stop("exportTestValues: all arguments must be named.")
 
           names(dots) <- ns(names(dots))
@@ -912,7 +949,7 @@ ShinySession <- R6Class(
 
         # Copy `values` from scopeState to state, adding namespace
         if (length(scopeState$values) != 0) {
-          if (anyUnnamed(scopeState$values)) {
+          if (any_unnamed(scopeState$values)) {
             stop("All scope values in must be named.")
           }
 
@@ -1008,8 +1045,34 @@ ShinySession <- R6Class(
       new data from the client."
       return(private$inputReceivedCallbacks$register(callback))
     },
-    unhandledError = function(e) {
-      self$close()
+    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))
+      }
+
+      # For fatal errors, always log.
+      # For non-fatal errors, only log if we haven't seen this error before.
+      if (close || !has_seen_otel_exception(e)) {
+        otel_log(
+          if (close) "Fatal error" else "Unhandled error",
+          severity = if (close) "fatal" else "error",
+          attributes = otel::as_attributes(list(
+            session.id = self$token,
+            error = get_otel_error_obj(e)
+          ))
+        )
+      }
+
+      private$unhandledErrorCallbacks$invoke(e, onError = printError)
+      .globals$onUnhandledErrorCallbacks$invoke(e, onError = printError)
+
+      if (close) self$close()
     },
     close = function() {
       if (!self$closed) {
@@ -1023,7 +1086,9 @@ ShinySession <- R6Class(
       }
       # ..stacktraceon matches with the top-level ..stacktraceoff..
       withReactiveDomain(self, {
-        private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
+        otel_span_session_end(domain = self, {
+          private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
+        })
       })
     },
     isClosed = function() {
@@ -1092,7 +1157,8 @@ ShinySession <- R6Class(
         attr(label, "srcref") <- srcref
         attr(label, "srcfile") <- srcfile
 
-        obs <- observe(..stacktraceon = FALSE, {
+        # Do not bind this `observe()` call
+        obs <- with_no_otel_collect(observe(..stacktraceon = FALSE, {
 
           private$sendMessage(recalculating = list(
             name = name, status = 'recalculating'
@@ -1104,7 +1170,9 @@ ShinySession <- R6Class(
             hybrid_chain(
               {
                 private$withCurrentOutput(name, {
-                  shinyCallingHandlers(func())
+                  maybe_with_otel_span_reactive_update({
+                    shinyCallingHandlers(func())
+                  }, domain = self)
                 })
               },
               catch = function(cond) {
@@ -1113,7 +1181,14 @@ 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.silent.error")) {
+                } 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
+                  }
                   # 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
@@ -1122,10 +1197,9 @@ ShinySession <- R6Class(
                 } else {
                   if (isTRUE(getOption("show.error.messages"))) printError(cond)
                   if (getOption("shiny.sanitize.errors", FALSE)) {
-                    cond <- simpleError(paste("An error has occurred. Check your",
-                      "logs or contact the app author for",
-                      "clarification."))
+                    cond <- sanitized_error()
                   }
+                  self$unhandledError(cond, close = FALSE)
                   invisible(structure(list(), class = "try-error", condition = cond))
                 }
               }
@@ -1136,6 +1210,33 @@ 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'
               ))
@@ -1160,7 +1261,7 @@ ShinySession <- R6Class(
                 private$invalidatedOutputValues$set(name, value)
             }
           )
-        }, suspended=private$shouldSuspend(name), label=label)
+        }, suspended=private$shouldSuspend(name), label=label))
 
         # If any output attributes were added to the render function attach
         # them to observer.
@@ -1210,7 +1311,7 @@ ShinySession <- R6Class(
           length(private$progressKeys) != 0 ||
           length(private$invalidatedOutputValues) != 0 ||
           length(private$invalidatedOutputErrors) != 0 ||
-          length(private$inputMessageQueue) != 0
+          private$inputMessageQueue$size() != 0
         )
       }
 
@@ -1242,8 +1343,8 @@ ShinySession <- R6Class(
         private$invalidatedOutputValues <- Map$new()
         errors <- as.list(private$invalidatedOutputErrors)
         private$invalidatedOutputErrors <- Map$new()
-        inputMessages <- private$inputMessageQueue
-        private$inputMessageQueue <- list()
+        inputMessages <- private$inputMessageQueue$as_list()
+        private$inputMessageQueue$reset()
 
         if (isTRUE(private$testMode)) {
           private$storeOutputValues(mergeVectors(values, errors))
@@ -1261,30 +1362,36 @@ ShinySession <- R6Class(
     # does not guarantee) inputs and reactive values from changing underneath
     # async observers as they run.
     cycleStartAction = function(callback) {
-      private$cycleStartActionQueue <- c(private$cycleStartActionQueue, list(callback))
+      private$cycleStartActionQueue$add(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) {
+    showProgress = function(id, persistent=FALSE) {
       '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.'
+      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.'
 
       # 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)
-        return()
+      if (!id %in% private$progressKeys) {
+        private$progressKeys <- c(private$progressKeys, id)
+      }
 
-      private$progressKeys <- c(private$progressKeys, id)
-
-      self$sendProgress('binding', list(id = id))
+      self$sendProgress('binding', list(id = id, persistent = persistent))
     },
     sendProgress = function(type, message) {
       private$sendMessage(
@@ -1392,8 +1499,7 @@ ShinySession <- R6Class(
     sendInputMessage = function(inputId, message) {
       data <- list(id = inputId, message = message)
 
-      # Add to input message queue
-      private$inputMessageQueue[[length(private$inputMessageQueue) + 1]] <- data
+      private$inputMessageQueue$add(data)
       # Needed so that Shiny knows to actually flush the input message queue
       self$requestFlush()
     },
@@ -1701,7 +1807,7 @@ ShinySession <- R6Class(
         dots <- eval(substitute(alist(...)))
       }
 
-      if (anyUnnamed(dots))
+      if (any_unnamed(dots))
         stop("exportTestValues: all arguments must be named.")
 
       # Create a named list where each item is a list with an expression and
@@ -1714,7 +1820,7 @@ ShinySession <- R6Class(
     },
 
     getTestSnapshotUrl = function(input = TRUE, output = TRUE, export = TRUE,
-                                  format = "json") {
+                                  format = "json", sortC = FALSE) {
       reqString <- function(group, value) {
         if (isTRUE(value))
           paste0(group, "=1")
@@ -1728,6 +1834,7 @@ ShinySession <- R6Class(
         reqString("input", input),
         reqString("output", output),
         reqString("export", export),
+        reqString("sortC", sortC),
         paste0("format=", format),
         sep = "&"
       )
@@ -1932,8 +2039,8 @@ ShinySession <- R6Class(
           ext <- paste(".", ext, sep = "")
         tmpdata <- tempfile(fileext = ext)
         return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() {
-          promises::with_promise_domain(reactivePromiseDomain(), {
-            promises::with_promise_domain(createStackTracePromiseDomain(), {
+          with_promise_domain(reactivePromiseDomain(), {
+            captureStackTraces({
               self$incrementBusyCount()
               hybrid_chain(
                 # ..stacktraceon matches with the top-level ..stacktraceoff..
@@ -2104,6 +2211,8 @@ ShinySession <- R6Class(
       if (private$busyCount == 0L) {
         rLog$asyncStart(domain = self)
         private$sendMessage(busy = "busy")
+
+        otel_span_reactive_update_init(domain = self)
       }
       private$busyCount <- private$busyCount + 1L
     },
@@ -2125,20 +2234,10 @@ ShinySession <- R6Class(
             private$startCycle()
           }
         })
+
+        otel_span_reactive_update_teardown(domain = self)
       }
     }
-  ),
-  active = list(
-    session = function() {
-      shinyDeprecated(
-        "0.11.1", "shinysession$session",
-        details = paste0(
-          "Attempted to access deprecated shinysession$session object. ",
-          "Please just access the shinysession object directly."
-        )
-      )
-      self
-    }
   )
 )
 
@@ -2175,7 +2274,7 @@ ShinySession <- R6Class(
   if (getOption("shiny.allowoutputreads", FALSE)) {
     .subset2(x, 'impl')$getOutput(name)
   } else {
-    stop("Reading from shinyoutput object is not allowed.")
+    rlang::abort(paste0("Can't read output '", name, "'"))
   }
 }
 
@@ -2184,12 +2283,12 @@ ShinySession <- R6Class(
 
 #' @export
 `[.shinyoutput` <- function(values, name) {
-  stop("Single-bracket indexing of shinyoutput object is not allowed.")
+  rlang::abort("Can't index shinyoutput with `[`.")
 }
 
 #' @export
 `[<-.shinyoutput` <- function(values, name, value) {
-  stop("Single-bracket indexing of shinyoutput object is not allowed.")
+  rlang::abort("Can't index shinyoutput with `[[`.")
 }
 
 #' Set options for an output object.
@@ -2306,23 +2405,89 @@ 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. `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. `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.
 #'
 #' 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)
@@ -2343,6 +2508,27 @@ 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) {
@@ -2557,3 +2743,10 @@ validate_session_object <- function(session, label = as.character(sys.call(sys.p
     )
   }
 }
+
+
+sanitized_error <- function() {
+  simpleError(paste("An error has occurred. Check your",
+    "logs or contact the app author for",
+    "clarification."))
+}

R/shinyapp.R

@@ -162,11 +162,29 @@ 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.
@@ -193,10 +211,11 @@ 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.
@@ -232,10 +251,9 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
   onStart <- function() {
     oldwd <<- getwd()
     setwd(appDir)
-    # TODO: we should support hot reloading on global.R and R/*.R changes.
     if (getOption("shiny.autoload.r", TRUE)) {
-      loadSupport(appDir, renv=sharedEnv, globalrenv=globalenv())
-    }  else {
+      autoload_r_support_if_needed()
+    } else {
       if (file.exists(file.path.ci(appDir, "global.R")))
         sourceUTF8(file.path.ci(appDir, "global.R"))
     }
@@ -286,37 +304,81 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
-  if (!getOption("shiny.autoreload", FALSE)) {
+  if (!get_devmode_option("shiny.autoreload", FALSE)) {
     return(function(){})
   }
 
-  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)$"
+  )
 
-  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
+  
+  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()
       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"
+      )
+    }
 
-    invalidateLater(getOption("shiny.autoreload.interval", 500))
-  })
+    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
+  }
 
-  onStop(obs$destroy)
-
-  obs$destroy
+  invisible(watcher)
 }
 
 #' Load an app's supporting R files
@@ -339,7 +401,7 @@ initAutoReloadMonitor <- function(dir) {
 #' @param appDir The application directory. If `appDir` is `NULL` or
 #'   not supplied, the nearest enclosing directory that is a Shiny app, starting
 #'   with the current directory, is used.
-#' @param renv The environmeny in which the files in the `R/` directory should
+#' @param renv The environment in which the files in the `R/` directory should
 #'   be evaluated.
 #' @param globalrenv The environment in which `global.R` should be evaluated. If
 #'   `NULL`, `global.R` will not be evaluated at all.
@@ -351,17 +413,6 @@ loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalren
     appDir <- findEnclosingApp(".")
   }
 
-  descFile <- file.path.ci(appDir, "DESCRIPTION")
-  if (file.exists(file.path.ci(appDir, "NAMESPACE")) ||
-      (file.exists(descFile) &&
-       identical(as.character(read.dcf(descFile, fields = "Type")), "Package")))
-  {
-    warning(
-      "Loading R/ subdirectory for Shiny application, but this directory appears ",
-      "to contain an R package. Sourcing files in R/ may cause unexpected behavior."
-    )
-  }
-
   if (!is.null(globalrenv)){
     # Evaluate global.R, if it exists.
     globalPath <- file.path.ci(appDir, "global.R")
@@ -376,10 +427,12 @@ loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalren
   helpersDir <- file.path(appDir, "R")
 
   disabled <- list.files(helpersDir, pattern="^_disable_autoload\\.r$", recursive=FALSE, ignore.case=TRUE)
-  if (length(disabled) > 0){
+  if (length(disabled) > 0) {
     return(invisible(renv))
   }
 
+  warn_if_app_dir_is_package(appDir)
+
   helpers <- list.files(helpersDir, pattern="\\.[rR]$", recursive=FALSE, full.names=TRUE)
   # Ensure files in R/ are sorted according to the 'C' locale before sourcing.
   # This convention is based on the default for packages. For details, see:
@@ -394,6 +447,27 @@ loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalren
   invisible(renv)
 }
 
+warn_if_app_dir_is_package <- function(appDir) {
+  has_namespace <- file.exists(file.path.ci(appDir, "NAMESPACE"))
+  has_desc_pkg <- FALSE
+
+  if (!has_namespace) {
+    descFile <- file.path.ci(appDir, "DESCRIPTION")
+
+    has_desc_pkg <-
+      file.exists(descFile) &&
+      identical(as.character(read.dcf(descFile, fields = "Type")), "Package")
+  }
+
+  if (has_namespace || has_desc_pkg) {
+    warning(
+      "Loading R/ subdirectory for Shiny application, but this directory appears ",
+      "to contain an R package. Sourcing files in R/ may cause unexpected behavior. ",
+      "See `?loadSupport` for more details."
+    )
+  }
+}
+
 # This reads in an app dir for a single-file application (e.g. app.R), and
 # returns a shiny.appobj.
 # appDir must be a normalized (absolute) path, not a relative one
@@ -409,8 +483,6 @@ 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.
@@ -455,7 +527,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

R/shinyui.R

@@ -14,7 +14,11 @@ NULL
 #' # now we can just write "static" content without withMathJax()
 #' div("more math here $$\\sqrt{2}$$")
 withMathJax <- function(...) {
-  path <- 'https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
+  path <- paste0(
+    getOption("shiny.mathjax.url", "https://mathjax.rstudio.com/latest/MathJax.js"),
+    "?",
+    getOption("shiny.mathjax.config", "config=TeX-AMS-MML_HTMLorMML")
+  )
   tagList(
     tags$head(
       singleton(tags$script(src = path, type = 'text/javascript'))
@@ -39,7 +43,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
@@ -47,48 +51,75 @@ 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(jquery()),
+    list(jqueryDependency()),
     shinyDependencies()
   )
 
   if (testMode) {
     # Add code injection listener if in test mode
     shiny_deps[[length(shiny_deps) + 1]] <-
-      htmlDependency("shiny-testmode", shinyPackageVersion(),
-                     c(href="shared"), script = "shiny-testmode.js")
+      htmlDependency(
+        "shiny-testmode",
+        get_package_version("shiny"),
+        src = "www/shared",
+        package = "shiny",
+        script = "shiny-testmode.js",
+        all_files = FALSE
+      )
   }
 
+  if (in_devmode() || 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() {
   list(
     bslib::bs_dependency_defer(shinyDependencyCSS),
+    busyIndicatorDependency(),
     htmlDependency(
       name = "shiny-javascript",
-      version = shinyPackageVersion(),
-      src = c(href = "shared"),
+      version = get_package_version("shiny"),
+      src = "www/shared",
+      package = "shiny",
       script =
         if (isTRUE(
           get_devmode_option(
@@ -98,29 +129,38 @@ shinyDependencies <- function() {
         ))
           "shiny.min.js"
         else
-          "shiny.js"
+          "shiny.js",
+      all_files = FALSE
     )
   )
 }
 
+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 <- shinyPackageVersion()
+  version <- get_package_version("shiny")
 
   if (!is_bs_theme(theme)) {
     return(htmlDependency(
       name = "shiny-css",
       version = version,
-      src = c(href = "shared"),
-      stylesheet = "shiny.min.css"
+      src = "www/shared",
+      package = "shiny",
+      stylesheet = "shiny.min.css",
+      all_files = FALSE
     ))
   }
 
-  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)
+  bs_version <- bslib::theme_version(theme)
 
   bslib::bs_dependency(
-    input = scss_files,
+    input = shinyDependencySass(bs_version),
     theme = theme,
     name = "shiny-sass",
     version = version,
@@ -130,7 +170,7 @@ shinyDependencyCSS <- function(theme) {
 
 #' Create a Shiny UI handler
 #'
-#' @description \lifecycle{superseded}
+#' @description `r lifecycle::badge("superseded")`
 #'
 #' @description Historically this function was used in ui.R files to register a user
 #' interface with Shiny. It is no longer required as of Shiny 0.10; simply
@@ -138,7 +178,7 @@ shinyDependencyCSS <- function(theme) {
 #' This function is kept for backwards compatibility with older applications. It
 #' returns the value that is passed to it.
 #'
-#' @param ui A user interace definition
+#' @param ui A user interface definition
 #' @return The user interface definition, without modifications or side effects.
 #' @keywords internal
 #' @export

R/shinywrappers.R

@@ -2,12 +2,23 @@ utils::globalVariables('func', add = TRUE)
 
 #' 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.
+#'
 #' @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
@@ -37,7 +48,7 @@ utils::globalVariables('func', add = TRUE)
 #'   is able to serve JS and CSS resources.
 #' @return The `renderFunc` function, with annotations.
 #'
-#' @seealso [createRenderFunction()], [quoToFunction()]
+#' @seealso [createRenderFunction()]
 #' @export
 markRenderFunction <- function(
   uiFunc,
@@ -47,6 +58,12 @@ markRenderFunction <- function(
   cacheWriteHook = NULL,
   cacheReadHook = NULL
 ) {
+  # (Do not emit warning for superseded code, "since there’s no risk if you keep using it")
+  # # This method is called by the superseding function, createRenderFunction().
+  # if (in_devmode()) {
+  #   shinyDeprecated("1.1.0", "markRenderFunction()", "createRenderFunction()")
+  # }
+
   force(renderFunc)
 
   # a mutable object that keeps track of whether `useRenderFunction` has been
@@ -94,6 +111,7 @@ markRenderFunction <- function(
     # 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
     })
@@ -116,7 +134,14 @@ markRenderFunction <- function(
     else renderFunc(...)
   }
 
-  structure(
+  otelAttrs <-
+    otel_srcref_attributes(
+      attr(renderFunc, "wrappedFunc", exact = TRUE),
+      # Can't retrieve the render function used at this point, so just use NULL
+      fn_name = NULL
+    )
+
+  ret <- structure(
     wrappedRenderFunc,
     class          = c("shiny.render.function", "function"),
     outputFunc     = uiFunc,
@@ -124,8 +149,15 @@ markRenderFunction <- function(
     hasExecuted    = hasExecuted,
     cacheHint      = cacheHint,
     cacheWriteHook = cacheWriteHook,
-    cacheReadHook  = cacheReadHook
+    cacheReadHook  = cacheReadHook,
+    otelAttrs      = otelAttrs
   )
+
+  if (has_otel_collect("reactivity")) {
+    ret <- enable_otel_shiny_render_function(ret)
+  }
+
+  ret
 }
 
 #' @export
@@ -133,10 +165,27 @@ print.shiny.render.function <- function(x, ...) {
   cat_line("<shiny.render.function>")
 }
 
-#' Implement render functions
+#' Implement custom render functions
 #'
-#' This function is a wrapper for [markRenderFunction()] which provides support
-#' for async computation via promises.
+#' Developer-facing utilities for implementing a custom `renderXXX()` function.
+#' Before using these utilities directly, consider using the [`htmlwidgets`
+#' package](http://www.htmlwidgets.org/develop_intro.html) to implement custom
+#' outputs (i.e., custom `renderXXX()`/`xxxOutput()` functions). That said,
+#' these utilities can be used more directly if a full-blown htmlwidget isn't
+#' needed and/or the user-supplied reactive expression needs to be wrapped in
+#' additional call(s).
+#'
+#' To implement a custom `renderXXX()` function, essentially 2 things are needed:
+#'   1. Capture the user's reactive expression as a function.
+#'      * New `renderXXX()` functions can use `quoToFunction()` for this, but
+#'      already existing `renderXXX()` functions that contain `env` and `quoted`
+#'      parameters may want to continue using `installExprFunction()` for better
+#'      legacy support (see examples).
+#'   2. Flag the resulting function (from 1) as a Shiny rendering function and
+#'   also provide a UI container for displaying the result of the rendering
+#'   function.
+#'      * `createRenderFunction()` is currently recommended (instead of
+#'      [markRenderFunction()]) for this step (see examples).
 #'
 #' @param func A function without parameters, that returns user data. If the
 #'   returned value is a promise, then the render function will proceed in async
@@ -153,16 +202,24 @@ print.shiny.render.function <- function(x, ...) {
 #' @return An annotated render function, ready to be assigned to an
 #'   `output` slot.
 #'
-#' @seealso [quoToFunction()], [markRenderFunction()].
-#'
 #' @examples
-#' # A very simple render function
-#' renderTriple <- function(x) {
-#'   x <- substitute(x)
-#'   if (!rlang::is_quosure(x)) {
-#'     x <- rlang::new_quosure(x, env = parent.frame())
-#'   }
-#'   func <- quoToFunction(x, "renderTriple")
+#' # 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,
@@ -174,10 +231,38 @@ print.shiny.render.function <- function(x, ...) {
 #' }
 #'
 #' # Test render function from the console
-#' a <- 1
-#' r <- renderTriple({ a + 1 })
-#' a <- 2
+#' 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,
@@ -200,9 +285,7 @@ createRenderFunction <- function(
   # 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)
-  }
+  attr(renderFunc, "wrappedFunc") <- attr(func, "wrappedFunc", exact = TRUE)
 
   markRenderFunction(outputFunc, renderFunc, outputArgs, cacheHint,
                      cacheWriteHook, cacheReadHook)
@@ -250,7 +333,7 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 
 # Get relevant attributes from a render function object.
 renderFunctionAttributes <- function(x) {
-  attrs <- c("outputFunc", "outputArgs", "hasExecuted", "cacheHint")
+  attrs <- c("outputFunc", "outputArgs", "hasExecuted", "cacheHint", "otelAttrs")
   names(attrs) <- attrs
   lapply(attrs, function(name) attr(x, name, exact = TRUE))
 }
@@ -312,13 +395,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.
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
+#' @inheritParams renderUI
 #' @param deleteFile Should the file in `func()$src` be deleted after
 #'   it is sent to the client browser? Generally speaking, if the image is a
 #'   temp file generated within `func`, then this should be `TRUE`;
@@ -397,11 +480,10 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #'
 #' shinyApp(ui, server)
 #' }
-renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
+renderImage <- function(expr, env = parent.frame(), quoted = FALSE,
                         deleteFile, outputArgs=list())
 {
-  expr <- get_quosure(expr, env, quoted)
-  func <- quoToFunction(expr, "renderImage")
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderImage")
 
   # missing() must be used directly within the function with the given arg
   if (missing(deleteFile)) {
@@ -523,21 +605,19 @@ isTemp <- function(path, tempDir = tempdir(), mustExist) {
 #' function return [invisible()].
 #'
 #' @param expr An expression to evaluate.
-#' @param env The environment in which to evaluate `expr`. For expert use only.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
+#' @inheritParams renderUI
 #' @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())
 {
-  expr <- get_quosure(expr, env, quoted)
-  func <- quoToFunction(expr, "renderPrint")
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderPrint")
 
   # Set a promise domain that sets the console width
   #   and captures output
@@ -548,7 +628,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     domain <- createRenderPrintPromiseDomain(width)
     hybrid_chain(
       {
-        promises::with_promise_domain(domain, func())
+        with_promise_domain(domain, func())
       },
       function(value) {
         res <- withVisible(value)
@@ -569,7 +649,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     outputArgs,
     cacheHint = list(
       label = "renderPrint",
-      origUserExpr = get_expr(expr)
+      origUserExpr = installedFuncExpr(func)
     )
   )
 }
@@ -577,7 +657,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
 createRenderPrintPromiseDomain <- function(width) {
   f <- file()
 
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       force(onFulfilled)
       function(...) {
@@ -619,11 +699,10 @@ 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=" ") {
 
-  expr <- get_quosure(expr, env, quoted)
-  func <- quoToFunction(expr, "renderText")
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderText")
 
   createRenderFunction(
     func,
@@ -644,14 +723,18 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' @param expr An expression that returns a Shiny tag object, [HTML()],
 #'   or a list of such objects.
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
+#' @template param-env
+#' @templateVar x expr
+#' @templateVar env env
+#' @templateVar quoted quoted
+#' @template param-quoted
+#' @templateVar x expr
+#' @templateVar quoted quoted
 #' @param outputArgs A list of arguments to be passed through to the implicit
 #'   call to [uiOutput()] when `renderUI` is used in an
 #'   interactive R Markdown document.
 #'
-#' @seealso [uiOutput()]
+#' @seealso [uiOutput()], [outputOptions()]
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -675,8 +758,7 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
                      outputArgs = list())
 {
-  expr <- get_quosure(expr, env, quoted)
-  func <- quoToFunction(expr, "renderUI")
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderUI")
 
   createRenderFunction(
     func,
@@ -711,9 +793,9 @@ renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
 #'   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` or
-#'   `NA`, the content type will be guessed based on the filename
-#'   extension, or `application/octet-stream` if the extension is unknown.
+#'   example `"text/csv"` or `"image/png"`. If `NULL`, the content type
+#'   will be guessed based on the filename extension, or
+#'   `application/octet-stream` if the extension is unknown.
 #' @param outputArgs A list of arguments to be passed through to the implicit
 #'   call to [downloadButton()] when `downloadHandler` is used
 #'   in an interactive R Markdown document.
@@ -742,8 +824,15 @@ 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=NA, outputArgs=list()) {
+downloadHandler <- function(filename, content, contentType=NULL, outputArgs=list()) {
   renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
   }
@@ -755,16 +844,12 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #' Table output with the JavaScript DataTables library
 #'
 #' @description
-#' Makes a reactive version of the given function that returns a data frame (or
-#' matrix), which will be rendered with the [DataTables](https://datatables.net)
-#' library. Paging, searching, filtering, and sorting can be done on the R side
-#' using Shiny as the server infrastructure.
+#' `r lifecycle::badge("deprecated")`
 #'
-#' This function only provides the server-side version of DataTables (using R
-#' to process the data object on the server side). There is a separate
-#' [DT](https://github.com/rstudio/DT) that allows you to create both
-#' server-side and client-side DataTables, and supports additional features.
-#' Learn more at <https://rstudio.github.io/DT/shiny.html>.
+#' 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.
 #'
 #' @param expr An expression that returns a data frame or a matrix.
 #' @inheritParams renderTable
@@ -816,21 +901,62 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #'     }
 #'   )
 #' }
+#' @keywords internal
 renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             callback = 'function(oTable) {}', escape = TRUE,
                             env = parent.frame(), quoted = FALSE,
-                            outputArgs=list())
-{
+                            outputArgs = list()) {
 
-  if (in_devmode()) {
-    shinyDeprecated(
-      "0.11.1", "shiny::renderDataTable()", "DT::renderDataTable()",
-      details = "See <https://rstudio.github.io/DT/shiny.html> for more information"
-    )
+  legacy <- useLegacyDataTable(
+    from = "shiny::renderDataTable()",
+    to = "DT::renderDT()"
+  )
+
+  if (!quoted) {
+    expr <- substitute(expr)
+    quoted <- TRUE
   }
 
-  expr <- get_quosure(expr, env, quoted)
-  func <- quoToFunction(expr, "renderDataTable")
+  if (legacy) {
+
+    legacyRenderDataTable(
+      expr, env = env, quoted = quoted,
+      options = options,
+      searchDelay = searchDelay,
+      callback = callback,
+      escape = escape,
+      outputArgs = outputArgs
+    )
+
+  } else {
+
+    if (!missing(searchDelay)) {
+      warning("Ignoring renderDataTable()'s searchDelay value (since DT::renderDT() has no equivalent).")
+    }
+
+    force(options)
+    force(callback)
+    force(escape)
+    force(outputArgs)
+
+    DT::renderDataTable(
+      expr, env = env, quoted = quoted,
+      options = if (is.null(options)) list() else options,
+      # Turn function into a statement
+      callback = DT::JS(paste0("(", callback, ")(table)")),
+      escape = escape,
+      outputArgs = outputArgs
+    )
+  }
+}
+
+
+legacyRenderDataTable <- function(expr, options = NULL, searchDelay = 500,
+                                  callback = 'function(oTable) {}', escape = TRUE,
+                                  env = parent.frame(), quoted = FALSE,
+                                  outputArgs=list()) {
+
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderDataTable")
 
   renderFunc <- function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
@@ -883,7 +1009,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
 DT10Names <- function() {
   rbind(
     utils::read.table(
-      system.file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
+      system_file('www/shared/datatables/upgrade1.10.txt', package = 'shiny'),
       stringsAsFactors = FALSE
     ),
     c('aoColumns', 'Removed')  # looks like an omission on the upgrade guide
@@ -918,67 +1044,3 @@ checkDT9 <- function(options) {
   names(options)[i] <- nms10
   options
 }
-
-# Deprecated functions ------------------------------------------------------
-
-#' Deprecated reactive functions
-#'
-#' @description \lifecycle{superseded}
-#'
-#' @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("0.4.0", "reactivePlot()", "renderPlot()")
-  renderPlot({ func() }, width=width, height=height, ...)
-}
-
-#' Table output (deprecated)
-#'
-#' `reactiveTable` has been replaced by [renderTable()].
-#' @rdname deprecatedReactives
-#' @export
-reactiveTable <- function(func, ...) {
-  shinyDeprecated("0.4.0", "reactiveTable()", "renderTable()")
-  renderTable({ func() })
-}
-
-#' Print output (deprecated)
-#'
-#' `reactivePrint` has been replaced by [renderPrint()].
-#' @rdname deprecatedReactives
-#' @export
-reactivePrint <- function(func) {
-  shinyDeprecated("0.4.0", "reactivePrint()", "renderPrint()")
-  renderPrint({ func() })
-}
-
-#' UI output (deprecated)
-#'
-#' `reactiveUI` has been replaced by [renderUI()].
-#' @rdname deprecatedReactives
-#' @export
-reactiveUI <- function(func) {
-  shinyDeprecated("0.4.0", "reactiveUI()", "renderUI()")
-  renderUI({ func() })
-}
-
-#' Text output (deprecated)
-#'
-#' `reactiveText` has been replaced by [renderText()].
-#' @rdname deprecatedReactives
-#' @export
-reactiveText <- function(func) {
-  shinyDeprecated("0.4.0", "reactiveText()", "renderText()")
-  renderText({ func() })
-}

R/showcase.R

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

R/stack.R

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

R/staticimports.R

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

R/test.R

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

R/update-input.R

@@ -37,7 +37,11 @@
 updateTextInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL, placeholder = NULL) {
   validate_session_object(session)
 
-  message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
+  message <- dropNulls(list(
+    label = if (!is.null(label)) processDeps(label, session),
+    value = value,
+    placeholder = placeholder
+  ))
   session$sendInputMessage(inputId, message)
 }
 
@@ -111,7 +115,10 @@ updateTextAreaInput <- updateTextInput
 updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL) {
   validate_session_object(session)
 
-  message <- dropNulls(list(label=label, value=value))
+  message <- dropNulls(list(
+    label = if (!is.null(label)) processDeps(label, session),
+    value = value
+  ))
   session$sendInputMessage(inputId, message)
 }
 
@@ -119,6 +126,8 @@ 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()]
@@ -148,13 +157,13 @@ updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, l
 #'       label = "New label",
 #'       icon = icon("calendar"))
 #'
-#'     # Leaves goButton2's label unchaged and
+#'     # Leaves goButton2's label unchanged and
 #'     # removes its icon
 #'     updateActionButton(session, "goButton2",
 #'       icon = character(0))
 #'
 #'     # Leaves goButton3's icon, if it exists,
-#'     # unchaged and changes its label
+#'     # unchanged and changes its label
 #'     updateActionButton(session, "goButton3",
 #'       label = "New label 3")
 #'
@@ -169,16 +178,21 @@ updateCheckboxInput <- function(session = getDefaultReactiveDomain(), inputId, l
 #' }
 #' @rdname updateActionButton
 #' @export
-updateActionButton <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL) {
+updateActionButton <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL, disabled = NULL) {
   validate_session_object(session)
 
-  if (!is.null(icon)) icon <- as.character(validateIcon(icon))
-  message <- dropNulls(list(label=label, icon=icon))
+  message <- dropNulls(list(
+    label = if (!is.null(label)) processDeps(label, session),
+    icon = if (!is.null(icon)) processDeps(validateIcon(icon), session),
+    disabled = disabled
+  ))
   session$sendInputMessage(inputId, message)
 }
 #' @rdname updateActionButton
 #' @export
-updateActionLink <- updateActionButton
+updateActionLink <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, icon = NULL) {
+  updateActionButton(session, inputId=inputId, label=label, icon=icon)
+}
 
 
 #' Change the value of a date input on the client
@@ -221,7 +235,12 @@ updateDateInput <- function(session = getDefaultReactiveDomain(), inputId, label
   min   <- dateYMD(min, "min")
   max   <- dateYMD(max, "max")
 
-  message <- dropNulls(list(label=label, value=value, min=min, max=max))
+  message <- dropNulls(list(
+    label = if (!is.null(label)) processDeps(label, session),
+    value = value,
+    min = min,
+    max = max
+  ))
   session$sendInputMessage(inputId, message)
 }
 
@@ -271,7 +290,7 @@ updateDateRangeInput <- function(session = getDefaultReactiveDomain(), inputId,
   max <- dateYMD(max, "max")
 
   message <- dropNulls(list(
-    label = label,
+    label = if (!is.null(label)) processDeps(label, session),
     value = dropNulls(list(start = start, end = end)),
     min = min,
     max = max
@@ -370,13 +389,16 @@ updateNavlistPanel <- updateTabsetPanel
 #' }
 #' @export
 updateNumericInput <- function(session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL,
-    min = NULL, max = NULL, step = NULL) {
+  min = NULL, max = NULL, step = NULL) {
 
   validate_session_object(session)
 
   message <- dropNulls(list(
-    label = label, value = formatNoSci(value),
-    min = formatNoSci(min), max = formatNoSci(max), step = formatNoSci(step)
+    label = if (!is.null(label)) processDeps(label, session),
+    value = formatNoSci(value),
+    min = formatNoSci(min),
+    max = formatNoSci(max),
+    step = formatNoSci(step)
   ))
   session$sendInputMessage(inputId, message)
 }
@@ -423,6 +445,23 @@ updateSliderInput <- function(session = getDefaultReactiveDomain(), inputId, lab
 {
   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)
@@ -439,7 +478,7 @@ updateSliderInput <- function(session = getDefaultReactiveDomain(), inputId, lab
   }
 
   message <- dropNulls(list(
-    label = label,
+    label = if (!is.null(label)) processDeps(label, session),
     value = formatNoSci(value),
     min = formatNoSci(min),
     max = formatNoSci(max),
@@ -470,7 +509,11 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
     ))
   }
 
-  message <- dropNulls(list(label = label, options = options, value = selected))
+  message <- dropNulls(list(
+    label = if (!is.null(label)) processDeps(label, session),
+    options = options,
+    value = selected
+  ))
 
   session$sendInputMessage(inputId, message)
 }
@@ -623,7 +666,11 @@ updateSelectInput <- function(session = getDefaultReactiveDomain(), inputId, lab
   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 = label, options = options, value = selected))
+  message <- dropNulls(list(
+    label = if (!is.null(label)) processDeps(label, session),
+    options = options,
+    value = selected
+  ))
   session$sendInputMessage(inputId, message)
 }
 

R/utils-lang.R

@@ -51,60 +51,213 @@ formalsAndBody <- function(x) {
 }
 
 
-# This function is to be called from functions like `reactive()`, `observe()`,
-# and the various render functions. It handles the following cases:
-# - The typical case where x is an unquoted expression, and `env` and `quoted`
-#   are not used.
-# - New-style metaprogramming cases, where rlang::inject() is used to inline a
-#   quosure into the AST, as in `inject(reactive(!!x))`.
-# - Old-style metaprogramming cases, where `env` and/or `quoted` are used.
-#
-# Much of the complexity is handling old-style metaprogramming cases. The code
-# in this function is more complicated because it needs to look at unevaluated
-# expressions in the _calling_ function. If this code were put directly in the
-# calling function, it would look like this:
-#
-# if (!missing(env) || !missing(quoted)) {
-#   deprecatedEnvQuotedMessage()
-#   if (!quoted) x <- substitute(x)
-#   x <- new_quosure(x, env)
-#
-# } else {
-#   x <- substitute(x)
-#   if (!is_quosure(x)) {
-#     x <- new_quosure(x, env = parent.frame())
-#   }
-# }
-#
-# In the future, the calling functions will not need to have the `env` and
-# `quoted` arguments -- `rlang::inject()` and quosures can be used instead.
-# Instead of using this function, `get_quosure()`, the caller can instead use
-# just the following code:
-#
-# x <- substitute(x)
-# if (!is_quosure(x)) {
-#   x <- new_quosure(x, env = parent.frame())
-# }
-#
-get_quosure <- function(x, env, quoted) {
-  if (!eval(substitute(missing(env)), parent.frame()) ||
-      !eval(substitute(missing(quoted)), parent.frame()))
-  {
-    deprecatedEnvQuotedMessage()
-    if (!quoted) {
-      x <- eval(substitute(substitute(x)), parent.frame())
-    }
-    x <- new_quosure(x, env)
+#' @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)
+}
 
-  } else {
-    x <- eval(substitute(substitute(x)), parent.frame())
-
-    # At this point, x can be a quosure if rlang::inject() is used, but the
-    # typical case is that x is not a quosure.
-    if (!is_quosure(x)) {
-      x <- new_quosure(x, env = parent.frame(2L))
+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),
+      function_name
+    )
+    label <- as_default_label(label)
+  }
+  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)
+
+  as_default_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)
+
+  as_default_label(
+    sprintf(
+      '%s(%s)',
+      functionLabel,
+      quoToLabelBody(q)
+    )
+  )
+}
+
+as_default_label <- function(x) {
+  class(x) <- c("default_label", class(x))
   x
 }
+is_default_label <- function(x) {
+  inherits(x, "default_label")
+}

R/utils-tags.R

@@ -0,0 +1,21 @@
+# Check if `x` is a tag(), tagList(), or HTML()
+# @param strict If `FALSE`, also consider a normal list() of 'tags' to be a tag list.
+isTagLike <- function(x, strict = FALSE) {
+  isTag(x) || isTagList(x, strict = strict) || isTRUE(attr(x, "html"))
+}
+
+isTag <- function(x) {
+  inherits(x, "shiny.tag")
+}
+
+isTagList <- function(x, strict = TRUE) {
+  if (strict) {
+    return(inherits(x, "shiny.tag.list"))
+  }
+
+  if (!is.list(x)) {
+    return(FALSE)
+  }
+
+  all(vapply(x, isTagLike, logical(1)))
+}

R/utils.R

@@ -2,6 +2,11 @@
 #' @include map.R
 NULL
 
+# @staticimports pkg:staticimports
+#   is_installed get_package_version system_file
+#   s3_register
+#   any_named any_unnamed
+
 #' Make a random number generator repeatable
 #'
 #' Given a function that generates random data, returns a wrapped version of
@@ -126,34 +131,6 @@ dropNullsOrEmpty <- function(x) {
   x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
 }
 
-# Given a vector/list, return TRUE if any elements are named, FALSE otherwise.
-anyNamed <- function(x) {
-  # Zero-length vector
-  if (length(x) == 0) return(FALSE)
-
-  nms <- names(x)
-
-  # List with no name attribute
-  if (is.null(nms)) return(FALSE)
-
-  # List with name attribute; check for any ""
-  any(nzchar(nms))
-}
-
-# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
-anyUnnamed <- function(x) {
-  # Zero-length vector
-  if (length(x) == 0) return(FALSE)
-
-  nms <- names(x)
-
-  # List with no name attribute
-  if (is.null(nms)) return(TRUE)
-
-  # List with name attribute; check for any ""
-  any(!nzchar(nms))
-}
-
 
 # Given a vector/list, returns a named vector/list (the labels will be blank).
 asNamed <- function(x) {
@@ -173,7 +150,7 @@ empty_named_list <- function() {
 # name as elements in a, the element in a is dropped. Also, if there are any
 # duplicated names in a or b, only the last one with that name is kept.
 mergeVectors <- function(a, b) {
-  if (anyUnnamed(a) || anyUnnamed(b)) {
+  if (any_unnamed(a) || any_unnamed(b)) {
     stop("Vectors must be either NULL or have names for all elements")
   }
 
@@ -185,15 +162,27 @@ mergeVectors <- function(a, b) {
 # Sort a vector by the names of items. If there are multiple items with the
 # same name, preserve the original order of those items. For empty
 # vectors/lists/NULL, return the original value.
-sortByName <- function(x) {
-  if (anyUnnamed(x))
+sortByName <- function(x, method = "auto") {
+  if (any_unnamed(x))
     stop("All items must be named")
 
   # Special case for empty vectors/lists, and NULL
   if (length(x) == 0)
     return(x)
 
-  x[order(names(x))]
+  # Must provide consistent sort order
+  #  https://github.com/rstudio/shinytest/issues/409
+  # Using a flag in the snapshot url to determine the method
+  # `method="radix"` uses `C` locale, which is consistent across platforms
+  # Even if two platforms share `en_us.UTF-8`, they may not sort consistently
+  #  https://blog.zhimingwang.org/macos-lc_collate-hunt
+  #  (macOS) $ LC_ALL=en_US.UTF-8 sort <<<$'python-dev\npython3-dev'
+  #  python-dev
+  #  python3-dev
+  #  (Linux) $ LC_ALL=en_US.UTF-8 sort <<<$'python-dev\npython3-dev'
+  #  python3-dev
+  #  python-dev
+  x[order(names(x), method = method)]
 }
 
 # Sort a vector. If a character vector, sort using C locale, which is consistent
@@ -404,164 +393,6 @@ getContentType <- function(file, defaultType = 'application/octet-stream') {
   mime::guess_type(file, unknown = defaultType, subtype = subtype)
 }
 
-# Create a zero-arg function from a quoted expression and environment
-# @examples
-# makeFunction(body=quote(print(3)))
-makeFunction <- function(args = pairlist(), body, env = parent.frame()) {
-  eval(call("function", args, body), env)
-}
-
-#' Convert an expression to a function
-#'
-#' This is to be called from another function, because it will attempt to get
-#' an unquoted expression from two calls back. Note: as of Shiny 1.6.0, it is
-#' recommended to use [quoToFunction()] instead.
-#'
-#' If expr is a quoted expression, then this just converts it to a function.
-#' If expr is a function, then this simply returns expr (and prints a
-#'   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. Note: as of
-#' Shiny 1.6.0, it is recommended to use [quoToFunction()] instead.
-#'
-#' 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)
-}
-
-#' Convert a quosure to a function for a Shiny render function
-#'
-#' This takes a quosure and label, and wraps them into a function that should be
-#' passed to [createRenderFunction()] or [markRenderFunction()].
-#'
-#' This function was added in Shiny 1.6.0. Previously, it was recommended to use
-#' [installExprFunction()] or [exprToFunction()] in render functions, but now we
-#' recommend using [quoToFunction()], because it does not require `env` and
-#' `quoted` arguments -- that information is captured by quosures provided by
-#' \pkg{rlang}.
-#'
-#' @param q A quosure.
-#' @inheritParams installExprFunction
-#' @seealso [createRenderFunction()] for example usage.
-#'
-#' @export
-quoToFunction <- function(q, label, ..stacktraceon = FALSE) {
-  q <- as_quosure(q)
-  # Use new_function() instead of as_function(), because as_function() adds an
-  # extra parent environment. (This may not actually be a problem, though.)
-  func <- new_function(NULL, get_expr(q), get_env(q))
-  wrapFunctionLabel(func, label, ..stacktraceon = ..stacktraceon)
-}
-
-
-# Utility function for creating a debugging label, given an expression.
-# `expr` is a quoted expression.
-# `function_name` is the name of the calling function.
-# `label` is an optional user-provided label. If NULL, it will be inferred.
-exprToLabel <- function(expr, function_name, label = NULL) {
-  srcref <- attr(expr, "srcref", exact = TRUE)
-  if (is.null(label)) {
-    label <- rexprSrcrefToLabel(
-      srcref[[1]],
-      sprintf('%s(%s)', function_name, paste(deparse(expr), collapse = '\n'))
-    )
-  }
-  if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
-  attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
-  label
-}
-
 #' Parse a GET query string from a URL
 #'
 #' Returns a named list of key-value pairs.
@@ -653,7 +484,7 @@ shinyCallingHandlers <- function(expr) {
   withCallingHandlers(captureStackTraces(expr),
     error = function(e) {
       # Don't intercept shiny.silent.error (i.e. validation errors)
-      if (inherits(e, "shiny.silent.error"))
+      if (cnd_inherits(e, "shiny.silent.error"))
         return()
 
       handle <- getOption('shiny.error')
@@ -662,7 +493,6 @@ shinyCallingHandlers <- function(expr) {
   )
 }
 
-
 #' Register a function with the debugger (if one is active).
 #'
 #' Call this function after exprToFunction to give any active debugger a hook
@@ -940,22 +770,45 @@ 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)
-  mtime <- NA
+  dir <- normalizePath(dir, mustWork = TRUE)
+
   value <- NULL
+  last_mtime_file <- NA
+  last_autoreload <- 0
+
   function(...) {
-    fname <- if (case.sensitive)
+    fname <- if (case.sensitive) {
       file.path(dir, file)
-    else
+    } else {
       file.path.ci(dir, file)
+    }
 
     now <- file.info(fname)$mtime
-    if (!identical(mtime, now)) {
+    autoreload <- last_autoreload < cachedAutoReloadLastChanged$get()
+    if (autoreload || !identical(last_mtime_file, now)) {
       value <<- func(fname, ...)
-      mtime <<- now
+      last_mtime_file <<- now
+      last_autoreload <<- cachedAutoReloadLastChanged$get()
     }
     value
   }
@@ -1111,52 +964,39 @@ reactiveStop <- function(message = "", class = NULL) {
 
 #' Validate input values and other conditions
 #'
-#' For an output rendering function (e.g. [renderPlot()]), you may
-#' need to check that certain input values are available and valid before you
-#' can render the output. `validate` gives you a convenient mechanism for
-#' doing so.
+#' @description
+#' `validate()` provides convenient mechanism for validating that an output
+#' has all the inputs necessary for successful rendering. It takes any number
+#' of (unnamed) arguments, each representing a condition to test. If any
+#' of condition fails (i.e. is not ["truthy"][isTruthy]), a special type of
+#' error is signaled to stop execution. If this error is not handled by
+#' application-specific code, it is displayed to the user by Shiny.
 #'
-#' The `validate` function takes any number of (unnamed) arguments, each of
-#' which represents a condition to test. If any of the conditions represent
-#' failure, then a special type of error is signaled which stops execution. If
-#' this error is not handled by application-specific code, it is displayed to
-#' the user by Shiny.
+#' If you use `validate()` in a [reactive()] validation failures will
+#' automatically propagate to outputs that use the reactive.
 #'
-#' An easy way to provide arguments to `validate` is to use the `need`
-#' function, which takes an expression and a string; if the expression is
-#' considered a failure, then the string will be used as the error message. The
-#' `need` function considers its expression to be a failure if it is any of
-#' the following:
+#' @section `need()`:
+#' An easy way to provide arguments to `validate()` is to use `need()`, which
+#' takes an expression and a string. If the expression is not
+#' ["truthy"][isTruthy] then the string will be used as the error message.
 #'
-#' \itemize{
-#'   \item{`FALSE`}
-#'   \item{`NULL`}
-#'   \item{`""`}
-#'   \item{An empty atomic vector}
-#'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all `FALSE` or missing values}
-#'   \item{An object of class `"try-error"`}
-#'   \item{A value that represents an unclicked [actionButton()]}
+#' If "truthiness" is flexible for your use case, you'll need to explicitly
+#' generate a logical values. For example, if you want allow `NA` but not
+#' `NULL`, you can `!is.null(input$foo)`.
+#'
+#' If you need validation logic that differs significantly from `need()`, you
+#' can create your own validation test functions. A passing test should return
+#' `NULL`. A failing test should return either a string providing the error
+#' to display to the user, or if the failure should happen silently, `FALSE`.
+#'
+#' Alternatively you can use `validate()` within an `if` statement, which is
+#' particularly useful for more complex conditions:
+#'
+#' ```
+#' if (input$x < 0 && input$choice == "positive") {
+#'   validate("If choice is positive then x must be greater than 0")
 #' }
-#'
-#' If any of these values happen to be valid, you can explicitly turn them to
-#' logical values. For example, if you allow `NA` but not `NULL`, you
-#' can use the condition `!is.null(input$foo)`, because `!is.null(NA)
-#' == TRUE`.
-#'
-#' If you need validation logic that differs significantly from `need`, you
-#' can create other validation test functions. A passing test should return
-#' `NULL`. A failing test should return an error message as a
-#' single-element character vector, or if the failure should happen silently,
-#' `FALSE`.
-#'
-#' Because validation failure is signaled as an error, you can use
-#' `validate` in reactive expressions, and validation failures will
-#' automatically propagate to outputs that use the reactive expression. In
-#' other words, if reactive expression `a` needs `input$x`, and two
-#' outputs use `a` (and thus depend indirectly on `input$x`), it's
-#' not necessary for the outputs to validate `input$x` explicitly, as long
-#' as `a` does validate it.
+#' ```
 #'
 #' @param ... A list of tests. Each test should equal `NULL` for success,
 #'   `FALSE` for silent failure, or a string for failure with an error
@@ -1171,7 +1011,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #'
 #' ui <- fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
-#'   selectizeInput('in2', 'Select a state', choices = state.name),
+#'   selectizeInput('in2', 'Select a state', choices = c("", state.name)),
 #'   plotOutput('plot')
 #' )
 #'
@@ -1189,7 +1029,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #'
 #' }
 validate <- function(..., errorClass = character(0)) {
-  results <- sapply(list(...), function(x) {
+  results <- sapply(list2(...), function(x) {
     # Detect NULL or NA
     if (is.null(x))
       return(NA_character_)
@@ -1233,7 +1073,7 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 
 #' Check for required values
 #'
-#' Ensure that values are available ("truthy"--see Details) before proceeding
+#' Ensure that values are available (["truthy"][isTruthy]) before proceeding
 #' with a calculation or action. If any of the given values is not truthy, the
 #' operation is stopped by raising a "silent" exception (not logged by Shiny,
 #' nor displayed in the Shiny app's UI).
@@ -1242,11 +1082,13 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' is to call it like a statement (ignoring its return value) before attempting
 #' operations using the required values:
 #'
-#' \preformatted{rv <- reactiveValues(state = FALSE)
+#' ```
+#' rv <- reactiveValues(state = FALSE)
 #' r <- reactive({
 #'   req(input$a, input$b, rv$state)
 #'   # Code that uses input$a, input$b, and/or rv$state...
-#' })}
+#' })
+#' ```
 #'
 #' In this example, if `r()` is called and any of `input$a`,
 #' `input$b`, and `rv$state` are `NULL`, `FALSE`, `""`,
@@ -1255,62 +1097,29 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #'
 #' The second is to use it to wrap an expression that must be truthy:
 #'
-#' \preformatted{output$plot <- renderPlot({
+#' ```
+#' output$plot <- renderPlot({
 #'   if (req(input$plotType) == "histogram") {
 #'     hist(dataset())
 #'   } else if (input$plotType == "scatter") {
 #'     qplot(dataset(), aes(x = x, y = y))
 #'   }
-#' })}
+#' })
+#' ```
 #'
 #' In this example, `req(input$plotType)` first checks that
 #' `input$plotType` is truthy, and if so, returns it. This is a convenient
 #' way to check for a value "inline" with its first use.
 #'
-#' **Truthy and falsy values**
-#'
-#' The terms "truthy" and "falsy" generally indicate whether a value, when
-#' coerced to a [base::logical()], is `TRUE` or `FALSE`. We use
-#' the term a little loosely here; our usage tries to match the intuitive
-#' notions of "Is this value missing or available?", or "Has the user provided
-#' an answer?", or in the case of action buttons, "Has the button been
-#' clicked?".
-#'
-#' For example, a `textInput` that has not been filled out by the user has
-#' a value of `""`, so that is considered a falsy value.
-#'
-#' To be precise, `req` considers a value truthy *unless* it is one
-#' of:
-#'
-#' \itemize{
-#'   \item{`FALSE`}
-#'   \item{`NULL`}
-#'   \item{`""`}
-#'   \item{An empty atomic vector}
-#'   \item{An atomic vector that contains only missing values}
-#'   \item{A logical vector that contains all `FALSE` or missing values}
-#'   \item{An object of class `"try-error"`}
-#'   \item{A value that represents an unclicked [actionButton()]}
-#' }
-#'
-#' Note in particular that the value `0` is considered truthy, even though
-#' `as.logical(0)` is `FALSE`.
-#'
-#' If the built-in rules for truthiness do not match your requirements, you can
-#' always work around them. Since `FALSE` is falsy, you can simply provide
-#' the results of your own checks to `req`:
-#'
-#' `req(input$a != 0)`
-#'
-#' **Using `req(FALSE)`**
+#' @section Using `req(FALSE)`:
 #'
 #' You can use `req(FALSE)` (i.e. no condition) if you've already performed
 #' all the checks you needed to by that point and just want to stop the reactive
-#' chain now. There is no advantange to this, except perhaps ease of readibility
+#' chain now. There is no advantage to this, except perhaps ease of readability
 #' if you have a complicated condition to check for (or perhaps if you'd like to
 #' divide your condition into nested `if` statements).
 #'
-#' **Using `cancelOutput = TRUE`**
+#' @section Using `cancelOutput = TRUE`:
 #'
 #' When `req(..., cancelOutput = TRUE)` is used, the "silent" exception is
 #' also raised, but it is treated slightly differently if one or more outputs are
@@ -1328,8 +1137,10 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' @param ... Values to check for truthiness.
 #' @param cancelOutput If `TRUE` and an output is being evaluated, stop
 #'   processing as usual but instead of clearing the output, leave it in
-#'   whatever state it happens to be in.
-#' @param x An expression whose truthiness value we want to determine
+#'   whatever state it happens to be in. If `"progress"`, do the same as `TRUE`,
+#'   but also keep the output in recalculating state; this is intended for cases
+#'   when an in-progress calculation will not be completed in this reactive
+#'   flush cycle, but is still expected to provide a result in the future.
 #' @return The first value that was passed in.
 #' @export
 #' @examples
@@ -1361,6 +1172,8 @@ req <- function(..., cancelOutput = FALSE) {
     if (!isTruthy(item)) {
       if (isTRUE(cancelOutput)) {
         cancelOutput()
+      } else if (identical(cancelOutput, "progress")) {
+        reactiveStop(class = "shiny.output.progress")
       } else {
         reactiveStop(class = "validation")
       }
@@ -1419,23 +1232,47 @@ cancelOutput <- function() {
 #
 # Can be used to facilitate short-circuit eval on dots.
 dotloop <- function(fun_, ...) {
-  for (i in 1:(nargs()-1)) {
+  for (i in seq_len(nargs() - 1)) {
     fun_(eval(as.symbol(paste0("..", i))))
   }
   invisible()
 }
 
+#' Truthy and falsy values
+#'
+#' The terms "truthy" and "falsy" generally indicate whether a value, when
+#' coerced to a [base::logical()], is `TRUE` or `FALSE`. We use
+#' the term a little loosely here; our usage tries to match the intuitive
+#' notions of "Is this value missing or available?", or "Has the user provided
+#' an answer?", or in the case of action buttons, "Has the button been
+#' clicked?".
+#'
+#' For example, a `textInput` that has not been filled out by the user has
+#' a value of `""`, so that is considered a falsy value.
+#'
+#' To be precise, a value is truthy *unless* it is one of:
+#'
+#' * `FALSE`
+#' * `NULL`
+#' * `""`
+#' * An empty atomic vector
+#' * An atomic vector that contains only missing values
+#' * A logical vector that contains all `FALSE` or missing values
+#' * An object of class `"try-error"`
+#' * A value that represents an unclicked [actionButton()]
+#'
+#' Note in particular that the value `0` is considered truthy, even though
+#' `as.logical(0)` is `FALSE`.
+#'
+#' @param x An expression whose truthiness value we want to determine
 #' @export
-#' @rdname req
 isTruthy <- function(x) {
-  if (inherits(x, 'try-error'))
-    return(FALSE)
-
-  if (!is.atomic(x))
-    return(TRUE)
-
   if (is.null(x))
     return(FALSE)
+  if (inherits(x, 'try-error'))
+    return(FALSE)
+  if (!is.atomic(x))
+    return(TRUE)
   if (length(x) == 0)
     return(FALSE)
   if (all(is.na(x)))
@@ -1596,7 +1433,11 @@ URLencode <- function(value, reserved = FALSE) {
 dateYMD <- function(date = NULL, argName = "value") {
   if (!length(date)) return(NULL)
   tryCatch({
-      res <- format(as.Date(date), "%Y-%m-%d")
+      if (inherits(date, "POSIXt")) {
+        res <- format(date, "%Y-%m-%d")
+      } else {
+        res <- format(as.Date(date), "%Y-%m-%d")
+      }
       if (any(is.na(res))) stop()
       date <- res
     },
@@ -1615,21 +1456,37 @@ dateYMD <- function(date = NULL, argName = "value") {
 # function which calls the original function using the specified name. This can
 # be helpful for profiling, because the specified name will show up on the stack
 # trace.
-wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE) {
+wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE, dots = TRUE) {
   if (name == "name" || name == "func" || name == "relabelWrapper") {
     stop("Invalid name for wrapFunctionLabel: ", name)
   }
+  if (nchar(name, "bytes") > 10000) {
+    # Max variable length in R is 10000 bytes. Truncate to a shorter number of
+    # chars because some characters could be multi-byte.
+    name <- substr(name, 1, 5000)
+  }
+
   assign(name, func, environment())
   registerDebugHook(name, environment(), name)
 
-  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(...))) })
+  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 {
-    body <- expr({ (!!name)(!!quote(...)) })
+    # 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 <- new_function(pairlist2(... =), body, environment())
 
   # Preserve the original function that was passed in; is used for caching.
   attr(relabelWrapper, "wrappedFunc") <- func
@@ -1672,7 +1529,7 @@ promise_chain <- function(promise, ..., catch = NULL, finally = NULL,
   }
 
   if (!is.null(domain)) {
-    promises::with_promise_domain(domain, do(), replace = replace)
+    with_promise_domain(domain, do(), replace = replace)
   } else {
     do()
   }
@@ -1689,7 +1546,7 @@ hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
       {
         captureStackTraces({
           result <- withVisible(force(expr))
-          if (promises::is.promising(result$value)) {
+          if (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)
@@ -1723,7 +1580,7 @@ hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
   }
 
   if (!is.null(domain)) {
-    promises::with_promise_domain(domain, do(), replace = replace)
+    with_promise_domain(domain, do(), replace = replace)
   } else {
     do()
   }
@@ -1741,7 +1598,7 @@ createVarPromiseDomain <- function(env, name, value) {
   force(name)
   force(value)
 
-  promises::new_promise_domain(
+  new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       function(...) {
         orig <- env[[name]]
@@ -1883,24 +1740,20 @@ findEnclosingApp <- function(path = ".") {
   }
 }
 
-# Check if a package is installed, and if version is specified,
-# that we have at least that version
-is_available <- function(package, version = NULL) {
-  installed <- nzchar(system.file(package = package))
-  if (is.null(version)) {
-    return(installed)
-  }
-  installed && isTRUE(utils::packageVersion(package) >= version)
+# Until `rlang::cnd_inherits()` is on CRAN
+cnd_inherits <- function(cnd, class) {
+  cnd_some(cnd, ~ inherits(.x, class))
 }
+cnd_some <- function(.cnd, .p, ...) {
+  .p <- rlang::as_function(.p)
 
-
-# cached version of utils::packageVersion("shiny")
-shinyPackageVersion <- local({
-  version <- NULL
-  function() {
-    if (is.null(version)) {
-      version <<- utils::packageVersion("shiny")
+  while (rlang::is_condition(.cnd)) {
+    if (.p(.cnd, ...)) {
+      return(TRUE)
     }
-    version
+
+    .cnd <- .cnd$parent
   }
-})
+
+  FALSE
+}

R/version_bs_date_picker.R

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

R/version_ion_range_slider.R

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

R/version_jquery.R

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

R/version_jqueryui.R

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

R/version_selectize.R

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

R/version_strftime.R

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

README-npm.md

@@ -0,0 +1,14 @@
+@posit/shiny
+============
+
+This npm package contains TypeScript type definitions for Shiny's client-side JavaScript libraries.
+
+It does not include the Shiny framework itself, though that may change in the future.
+
+[Shiny](https://github.com/rstudio/shiny) is a web application framework for both R and Python, developed by Posit PBC.
+
+## Installation
+
+```bash
+npm install @posit/shiny
+```

README.md

@@ -2,8 +2,8 @@
 
 <!-- badges: start -->
 [![CRAN](https://www.r-pkg.org/badges/version/shiny)](https://CRAN.R-project.org/package=shiny)
-[![R build status](https://github.com/rstudio/shiny/workflows/R-CMD-check/badge.svg)](https://github.com/rstudio/shiny/actions)
-[![RStudio community](https://img.shields.io/badge/community-shiny-blue?style=social&logo=rstudio&logoColor=75AADB)](https://community.rstudio.com/new-topic?category=shiny&tags=shiny)
+[![R build status](https://github.com/rstudio/shiny/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/rstudio/shiny/actions)
+[![RStudio community](https://img.shields.io/badge/community-shiny-blue?style=social&logo=rstudio&logoColor=75AADB)](https://forum.posit.co/new-topic?category=shiny&tags=shiny)
 
 <!-- badges: end -->
 
@@ -16,7 +16,7 @@ Easily build rich and productive interactive web apps in R &mdash; no HTML/CSS/J
 * A prebuilt set of highly sophisticated, customizable, and easy-to-use widgets (e.g., plots, tables, sliders, dropdowns, date pickers, and more).
 * An attractive default look based on [Bootstrap](https://getbootstrap.com/) which can also be easily customized with the [bslib](https://github.com/rstudio/bslib) package or avoided entirely with more direct R bindings to HTML/CSS/JavaScript.
 * Seamless integration with [R Markdown](https://shiny.rstudio.com/articles/interactive-docs.html), making it easy to embed numerous applications natively within a larger dynamic document.
-* Tools for improving and monitoring performance, including native support for [async programming](https://blog.rstudio.com/2018/06/26/shiny-1-1-0/), [caching](https://talks.cpsievert.me/20201117), [load testing](https://rstudio.github.io/shinyloadtest/), and [more](https://support.rstudio.com/hc/en-us/articles/231874748-Scaling-and-Performance-Tuning-in-RStudio-Connect).
+* Tools for improving and monitoring performance, including native support for [async programming](https://posit.co/blog/shiny-1-1-0/), [caching](https://talks.cpsievert.me/20201117), [load testing](https://rstudio.github.io/shinyloadtest/), and more.
 * [Modules](https://shiny.rstudio.com/articles/modules.html): a framework for reducing code duplication and complexity.
 * An ability to [bookmark application state](https://shiny.rstudio.com/articles/bookmarking-state.html) and/or [generate code to reproduce output(s)](https://github.com/rstudio/shinymeta).
 * A rich ecosystem of extension packages for more [custom widgets](http://www.htmlwidgets.org/), [input validation](https://github.com/rstudio/shinyvalidate), [unit testing](https://github.com/rstudio/shinytest), and more.
@@ -45,16 +45,24 @@ For more examples and inspiration, check out the [Shiny User Gallery](https://sh
 
 For help with learning fundamental Shiny programming concepts, check out the [Mastering Shiny](https://mastering-shiny.org/) book and the [Shiny Tutorial](https://shiny.rstudio.com/tutorial/). The former is currently more up-to-date with modern Shiny features, whereas the latter takes a deeper, more visual, dive into fundamental concepts.
 
+## Join the conversation
+
+If you want to chat about Shiny, meet other developers, or help us decide what to work on next, [join us on Discord](https://discord.com/invite/yMGCamUMnS).
+
 ## Getting Help
 
-To ask a question about Shiny, please use the [RStudio Community website](https://community.rstudio.com/new-topic?category=shiny&tags=shiny). 
+To ask a question about Shiny, please use the [RStudio Community website](https://forum.posit.co/new-topic?category=shiny&tags=shiny).
 
-For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues) and also keep in mind that by [writing a good bug report](https://github.com/rstudio/shiny/wiki/Writing-Good-Bug-Reports), you're more likely to get help with your problem. 
+For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues) and also keep in mind that by [writing a good bug report](https://github.com/rstudio/shiny/wiki/Writing-Good-Bug-Reports), you're more likely to get help with your problem.
 
 ## Contributing
 
-We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.md](https://github.com/rstudio/shiny/blob/master/.github/CONTRIBUTING.md) file for detailed guidelines of how to contribute.
+We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.md](https://github.com/rstudio/shiny/blob/main/.github/CONTRIBUTING.md) file for detailed guidelines of how to contribute.
 
 ## License
 
-The shiny package as a whole is licensed under the GPLv3. See the [LICENSE](LICENSE) file for more details.
+The shiny package as a whole is licensed under the MIT License. See the [LICENSE](LICENSE) file for more details.
+
+## R version support
+
+Shiny is supported on the latest release version of R, as well as the previous four minor release versions of R. For example, if the latest release R version is 4.3, then that version is supported, as well as 4.2, 4.1, 4.0, 3.6.