Fix/update news

Co-authored-by: Barret Schloerke <barret@rstudio.com>
Co-authored-by: Barret Schloerke <schloerke@gmail.com>
Co-authored-by: Winston Chang <winston@stdout.org>

.Rbuildignore

@@ -21,3 +21,19 @@
 ^TODO-promises.md$
 ^manualtests$
 ^\.github$
+
+^\.yarn$
+^\.vscode$
+^\.madgerc$
+^\.prettierrc\.yml$
+^babel\.config\.json$
+^jest\.config\.js$
+^package\.json$
+^tsconfig\.json$
+^yarn\.lock$
+^node_modules$
+^coverage$
+^.ignore$
+^\.browserslistrc$
+^\.eslintrc\.yml$
+^\.yarnrc\.yml$

.eslintrc.yml

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

.gitattributes

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

.github/shiny-workflows/routine.sh

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

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

@@ -1,150 +1,23 @@
-name: R-CMD-check
+# Workflow derived from https://github.com/rstudio/shiny-workflows
+#
+# NOTE: This Shiny team GHA workflow is overkill for most R packages.
+# For most R packages it is better to use https://github.com/r-lib/actions
 on:
   push:
-    branches:
-      - master
+    branches: [main, rc-**]
   pull_request:
-    branches:
-      - master
+    branches: [main]
+  schedule:
+    - cron: '0 5 * * 1' # every monday
 
+name: Package checks
 
 jobs:
-
+  website:
+    uses: rstudio/shiny-workflows/.github/workflows/website.yaml@v1
+  routine:
+    uses: rstudio/shiny-workflows/.github/workflows/routine.yaml@v1
+    with:
+      node-version: "14.x"
   R-CMD-check:
-    runs-on: ${{ matrix.config.os }}
-
-    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
-
-    strategy:
-      fail-fast: false
-      matrix:
-        config:
-          - {os: macOS-latest,   r: 'devel'}
-          - {os: macOS-latest,   r: '4.0'}
-          - {os: windows-latest, r: '4.0'}
-          - {os: ubuntu-16.04,   r: '4.0', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.6', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.5', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-
-    env:
-      _R_CHECK_FORCE_SUGGESTS_: false
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      RSPM: ${{ matrix.config.rspm }}
-      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
-
-    steps:
-      # https://github.com/actions/checkout/issues/135
-      - name: Set git to use LF
-        if: runner.os == 'Windows'
-        run: |
-          git config --system core.autocrlf false
-          git config --system core.eol lf
-
-      - uses: actions/checkout@v2
-
-      - uses: r-lib/actions/setup-r@master
-        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)
-      
-      # https://stackoverflow.com/a/66568545/591574
-      #> fatal error: 'X11/Intrinsic.h' file not found
-      - name: Install Cairo macOS R devel dependency
-        if: runner.os == 'macOS' && matrix.config.r == 'devel'
-        run: |
-          brew install libxt
-
-      # 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
-          _R_CHECK_FORCE_SUGGESTS_: ${{ matrix.config.r != 'devel' }}
-        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

.github/workflows/rituals.yaml

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

.gitignore

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

.madgerc

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

.vscode/settings.json

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

.yarnrc.yml

@@ -3,5 +3,7 @@ nodeLinker: node-modules
 plugins:
   - path: .yarn/plugins/@yarnpkg/plugin-outdated.cjs
     spec: "https://github.com/mskelton/yarn-plugin-outdated/raw/main/bundles/@yarnpkg/plugin-outdated.js"
+  - path: .yarn/plugins/@yarnpkg/plugin-interactive-tools.cjs
+    spec: "@yarnpkg/plugin-interactive-tools"
 
 yarnPath: .yarn/releases/yarn-2.4.0.cjs

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.6.0.9000
+Version: 1.7.1.9003
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com", comment = c(ORCID = "0000-0002-1576-2126")),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -79,7 +79,7 @@ Imports:
     jsonlite (>= 0.9.16),
     xtable,
     fontawesome (>= 0.2.1),
-    htmltools (>= 0.5.1.9003),
+    htmltools (>= 0.5.2),
     R6 (>= 2.0),
     sourcetools,
     later (>= 1.0.0),
@@ -91,7 +91,7 @@ Imports:
     withr,
     commonmark (>= 1.7),
     glue (>= 1.3.2),
-    bslib (>= 0.2.4.9003),
+    bslib (>= 0.3.0),
     cachem,
     ellipsis,
     lifecycle (>= 0.2.0)
@@ -105,17 +105,12 @@ Suggests:
     ggplot2,
     reactlog (>= 1.0.0),
     magrittr,
-    shinytest (>= 1.4.0.9003),
     yaml,
     future,
     dygraphs,
     ragg,
     showtext,
     sass
-Remotes:
-    r-lib/rlang,
-    rstudio/bslib,
-    rstudio/htmltools
 URL: https://shiny.rstudio.com/
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
@@ -193,16 +188,23 @@ 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'
+    'version_bs_date_picker.R'
+    'version_ion_range_slider.R'
     'version_jquery.R'
+    'version_selectize.R'
+    'version_strftime.R'
     'viewer.R'
-RoxygenNote: 7.1.1
+RoxygenNote: 7.2.0
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RdMacros: lifecycle
 Config/testthat/edition: 3
+Config/Needs/check:
+  rstudio/shinytest2

NAMESPACE

@@ -378,6 +378,7 @@ importFrom(htmltools,tags)
 importFrom(htmltools,validateCssUnit)
 importFrom(htmltools,withTags)
 importFrom(lifecycle,deprecated)
+importFrom(lifecycle,is_present)
 importFrom(promises,"%...!%")
 importFrom(promises,"%...>%")
 importFrom(promises,as.promise)
@@ -386,14 +387,18 @@ importFrom(promises,promise)
 importFrom(promises,promise_reject)
 importFrom(promises,promise_resolve)
 importFrom(rlang,"%||%")
+importFrom(rlang,"fn_body<-")
+importFrom(rlang,"fn_fmls<-")
 importFrom(rlang,as_function)
 importFrom(rlang,as_quosure)
 importFrom(rlang,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,4 +413,8 @@ importFrom(rlang,new_function)
 importFrom(rlang,new_quosure)
 importFrom(rlang,pairlist2)
 importFrom(rlang,quo)
+importFrom(rlang,quo_get_expr)
+importFrom(rlang,quo_is_missing)
+importFrom(rlang,quo_set_env)
+importFrom(rlang,quo_set_expr)
 importFrom(rlang,zap_srcref)

NEWS.md

@@ -1,28 +1,90 @@
-shiny 1.6.0.9000
+shiny development
 ================
 
 ## Full changelog
 
 ### Breaking changes
 
+### Minor new features and improvements
+
+* Shiny's internal HTML dependencies are now mounted dynamically instead of statically. (#3537)
+
+* HTML dependencies that are sent to dynamic UI now have better type checking, and no longer require a `dep.src.href` field. (#3537)
+
+* Default for `ref` input in `runGithub()` changed from `"master"` to `"HEAD"`. (#3346)
+
+* When taking a test snapshot, the sort order of the json keys of the `input`, `output`, and `export` fields is currently sorted using the locale of the machine. This can lead to inconsistent test snapshot results. To opt-in to a consistent ordering of snapshot fields with `{shinytest}`, please set the global option `options(shiny.snapshotsortc = TRUE)`. `{shinytest2}` users do not need to set this value. (#3515)
+
+* The auto-reload feature (`options(shiny.autoreload=TRUE)`) was not being activated by `devmode(TRUE)`, despite a console message asserting that it was. (#3620)
+
+* Add `shiny.mathjax.url` and `shiny.mathjax.config` options for configuring the MathJax URL used by `withMathJax`. Thanks, @Neutron3529! (#3639)
+
+### Bug fixes
+
+* Closed tidyverse/dplyr#5552: Compatibility of dplyr 1.0 (and rlang chained errors in general) with `req()`, `validate()`, and friends.
+
+* Closed #1545: `insertUI()` now executes `<script>` tags. (#3630)
+
+* Closed #2955: Input and output bindings previously attempted to use `el['data-input-id']`, but that never worked. They now use `el.getAttribute('data-input-id')` instead. (#3538)
+
+* Closed tidyverse/dplyr#6154: Values from an `actionButton()` had S3 classes in the incorrect order.
+
+* Fixed a bug where updating an input value without a corresponding Input binding element did not trigger a JavaScript `shiny:inputchanged` event. Now, if no Input binding element is found, the `shiny:inputchanged` event is triggered on `window.document`. (#3584)
+
+* Restored the previous behavior of automatically guessing the `Content-Type` header for `downloadHandler` functions when no explicit `contentType` argument is supplied. (#3393)
+
+* Closed #3619: In R 4.2, `splitLayout()` raised warnings about incorrect length in an `if` statement. (Thanks to @dmenne, #3625)
+
+* Closed #2297: If an error occurred in parsing a value in a bookmark query string, an error would be thrown and nothing would be restored. Now a message is displayed and that value is ignored. (Thanks to @daattali, #3385)
+
+* `fileInput()` can set the `capture` attribute to facilitates user access to a device's media capture mechanism, such as a camera, or microphone, from within a file upload control ([W3C HTML Media Capture](https://www.w3.org/TR/html-media-capture/)). (Thanks to khaled-alshamaa, #3481)
+
+* Fixed rstudio/shinytest2#222: When restoring a context (i.e., bookmarking) from a URL, Shiny now better handles a trailing `=` after `_inputs_` and `_values_`. (#3648)
+
+
+shiny 1.7.1
+===========
+
+## Bug Fixes
+
+* Closed #3516: Fix regression in repeated calls to `appendTab()` when `navbarMenu()` is already present within a `tabsetPanel()`/`navbarPage()`. (#3518)
+
+* Re-arranged conditions for testthat 1.0.0 compatibility. (#3512)
+
+
+shiny 1.7.0
+===========
+
+## Full changelog
+
+### Breaking changes
+
 * The `format` and `locale` arguments to `sliderInput()` have been removed. They have been deprecated since 0.10.2.2 (released on 2014-12-08).
 
+* Closed #3403: `insertTab()`'s `position` parameter now defaults to `"after"` instead of `"before"`. This has the benefit of allowing us to fix a bug in positioning when `target = NULL`, but has the drawback of changing the default behavior when `target` is not `NULL`. (#3404)
+
 ### New features and improvements
 
+* Bootstrap 5 support. (#3410 and rstudio/bslib#304)
+  * As explained [here](https://rstudio.github.io/bslib/index.html#basic-usage), to opt-in to Bootstrap 5, provide `bslib::bs_theme(version = 5)` to a page layout function with a `theme` argument (e.g., `fluidPage()`, `navbarPage()`, etc).
+
+* Closed #3322, #3313, #1823, #3321, #3320, #1928, and #2310: Various improvements to `navbarPage()`, `tabsetPanel()`, `tabPanel()`, `navbarMenu()`, etc. Also, these functions are now powered by the `{bslib}` package's new `nav()` API (consider using `{bslib}`'s API to create better looking and more fully featured navs). (#3388)
+
 * All uses of `list(...)` have been replaced with `rlang::list2(...)`. This means that you can use trailing `,` without error and use rlang's `!!!` operator to "splice" a list of argument values into `...`. We think this'll be particularly useful for passing a list of `tabPanel()` to their consumers (i.e., `tabsetPanel()`, `navbarPage()`, etc). For example, `tabs <- list(tabPanel("A", "a"), tabPanel("B", "b")); navbarPage(!!!tabs)`. (#3315 and #3328)
 
-* Numerous improvements tabset panels (i.e., `tabPanel()`, `navbarMenu()`, `tabsetPanel()`, `navbarPage()`, etc) (#3315):
-  * Closed #3322: `tabsetPanel()` and `navlistPanel()` gain `header`/`footer` arguments (inspired by `navbarPage()`'s already existing `header`/`footer`), making it easier to include content that should appear on every tab.
-  * Closed #3313 and #1823: More informative error when non-`tabPanel()`/`shiny.tag` objects are supplied to `...`.
-  * Closed #3321: New informative warning when `shiny.tag` object(s) are supplied to `...`. In this case we will continue to create an "empty" nav item and include the content on every tab, but the warning will mention the (new) `header`/`footer` args, which is likely what the user wants.
-  * Closed #3320: The HTML markup that `tabPanel()` et. al generate (for Bootstrap nav) is now Bootstrap 4+ compliant when used with `theme = bslib::bs_theme()`.
-  * Closed #1928: `NULL` values are now dropped instead of producing an empty nav item.
-  
+* `installExprFunction()` and `exprToFunction()` are now able to handle quosures when `quoted = TRUE`. So `render`-functions which call these functions (such as with `htmlwidgets`) can now understand quosures. Users can also use `rlang::inject()` to unquote a quosure for evaluation.  This also means that `render` function no longer need `env` and `quoted` parameters; that information can be embedded into a quosure which is then passed to the `render` function. Better documentation was added for how to create `render` functions. (#3472)
+
 * `icon(lib="fontawesome")` is now powered by the `{fontawesome}` package, which will make it easier to use the latest FA icons in the future (by updating the `{fontawesome}` package). (#3302)
 
+* Closed #3397: `renderPlot()` new uses `ggplot2::get_alt_text()` to inform an `alt` text default (for `{ggplot2}` plots). (#3398)
+
+* `modalDialog()` gains support for `size = "xl"`. (#3410)
+
+* Addressed #2521: Updated the list of TCP ports that will be rejected by default in runapp.R, adding 5060, 5061 and 6566. Added documentation describing the port range (3000:8000) and which ports are rejected. (#3456)
+
 ### Other improvements
 
-* Shiny's core JavaScript code was converted to TypeScript. For the latest development information, please see the [README.md in `./srcts`](https://github.com/rstudio/shiny/tree/master/srcts). (#3296)
+* Shiny's core JavaScript code was converted to TypeScript. For the latest development information, please see the [README.md in `./srcts`](https://github.com/rstudio/shiny/tree/v1.7.0/srcts). (#3296)
 
 * Switched from `digest::digest()` to `rlang::hash()` for hashing. (#3264)
 
@@ -34,10 +96,14 @@ shiny 1.6.0.9000
 
 * Closed #3345: Shiny now correctly renders `htmltools::htmlDependency()`(s) with a `list()` of `script` attributes when used in a dynamic UI context. This fairly new `htmlDependency()` feature was added in `{htmltools}` v0.5.1. (#3395)
 
-* Closed #3374: `quoToFunction()` now works correctly with nested quosures; and as a result, quasi-quotation with rendering function (e.g., `renderPrint()`, `renderPlot()`, etc) now works as expected with nested quosures. (#3373) 
+* Fixed [#2666](https://github.com/rstudio/shiny/issues/2666) and [#2670](https://github.com/rstudio/shiny/issues/2670): `nearPoints()` and `brushedPoints()` weren't properly account for missing values (#2666 was introduced in v1.4.0). ([#2668](https://github.com/rstudio/shiny/pull/2668))
+
+* Closed #3374: `quoToFunction()` now works correctly with nested quosures; and as a result, quasi-quotation with rendering function (e.g., `renderPrint()`, `renderPlot()`, etc) now works as expected with nested quosures. (#3373)
 
 * Exported `register_devmode_option()`. This method was described in the documentation for `devmode()` but was never exported. See `?devmode()` for more details on how to register Shiny Developer options using `register_devmode_option()`. (#3364)
 
+* Closed #3484: In the RStudio IDE on Mac 11.5, selected checkboxes and radio buttons were not visible. (#3485)
+
 ### Library updates
 
 * Closed #3286: Updated to Font-Awesome 5.15.2. (#3288)
@@ -51,7 +117,7 @@ This release focuses on improvements in three main areas:
 
 1. Better theming (and Bootstrap 4) support:
   * The `theme` argument of `fluidPage()`, `navbarPage()`, and `bootstrapPage()` all now understand `bslib::bs_theme()` objects, which can be used to opt-into Bootstrap 4, use any Bootswatch theme, and/or implement custom themes without writing any CSS.
-  * The `session` object now includes `$setCurrentTheme()` and `$getCurrentTheme()` methods to dynamically update (or obtain) the page's `theme` after initial load, which is useful for things such as [adding a dark mode switch to an app](https://rstudio.github.io/bslib/articles/theming.html#dynamic-shiny) or some other "real-time" theming tool like `bslib::bs_themer()`.
+  * The `session` object now includes `$setCurrentTheme()` and `$getCurrentTheme()` methods to dynamically update (or obtain) the page's `theme` after initial load, which is useful for things such as [adding a dark mode switch to an app](https://rstudio.github.io/bslib/articles/bslib.html#dynamic) or some other "real-time" theming tool like `bslib::bs_themer()`.
   * For more details, see [`{bslib}`'s website](https://rstudio.github.io/bslib/)
 
 2. Caching of `reactive()` and `render*()` (e.g. `renderText()`, `renderTable()`, etc) expressions.
@@ -173,7 +239,7 @@ shiny 1.5.0
 
 * The new `moduleServer` function provides a simpler interface for creating and using modules. (#2773)
 
-* Resolved #2732: `markdown()` is a new function for writing Markdown with Github extensions directly in Shiny UIs. Markdown rendering is performed by the [commonmark](https://github.com/jeroen/commonmark) package. (#2737)
+* Resolved #2732: `markdown()` is a new function for writing Markdown with Github extensions directly in Shiny UIs. Markdown rendering is performed by the [commonmark](https://github.com/r-lib/commonmark) package. (#2737)
 
 * The `getCurrentOutputInfo()` function can now return the background color (`bg`), foreground color (`fg`), `accent` (i.e., hyperlink) color, and `font` information of the output's HTML container. This information is reported by `plotOutput()`, `imageOutput()`, and any other output bindings containing a class of `.shiny-report-theme`. This feature allows developers to style an output's contents based on the container's CSS styling.  (#2740)
 

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,11 @@
 #' |   |- example-module.R
 #' |   `- example.R
 #' `- tests
-#'     |- shinytest.R
-#'     |- shinytest
-#'     |   `- mytest.R
 #'     |- testthat.R
 #'     `- testthat
 #'         |- test-examplemodule.R
 #'         |- test-server.R
+#'         |- test-shinytest2.R
 #'         `- test-sort.R
 #' ```
 #'
@@ -45,20 +42,20 @@
 #' * `tests/` contains various tests for the application. You may
 #'   choose to use or remove any of them. They can be executed by the
 #'   [runTests()] function.
-#' * `tests/shinytest.R` is a test runner for test files in the
-#'   `tests/shinytest/` directory.
-#' * `tests/shinytest/mytest.R` is a test that uses the
-#'   [shinytest](https://rstudio.github.io/shinytest/) package to do
-#'   snapshot-based testing.
 #' * `tests/testthat.R` is a test runner for test files in the
-#'   `tests/testthat/` directory using the [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/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 +76,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 +125,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")
   }
 
   # =======================================================
@@ -152,7 +143,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 +199,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 +270,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

@@ -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()`:

R/bookmark-state.R

@@ -321,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 <- ""
@@ -359,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)
+                message("Failed to parse URL parameter \"", name, "\"")
               }
             )
           }
         )
+        valsParsed[varsUnparsed] <- NULL
+        valsParsed
       }
 
       inputs <- valuesFromJSON(inputs)

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

@@ -13,7 +13,7 @@
 #'   Can also be set as a side effect of the [titlePanel()] function.
 #' @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
@@ -111,7 +111,7 @@ fluidRow <- function(...) {
 #' @param title The browser window title (defaults to the host URL of the page)
 #' @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
@@ -516,7 +516,7 @@ splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
   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)

R/bootstrap.R

@@ -24,7 +24,7 @@ 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.
@@ -138,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
@@ -215,11 +214,10 @@ registerThemeDependency <- function(func) {
 
 bootstrapDependency <- function(theme) {
   htmlDependency(
-    "bootstrap", bootstrapVersion,
-    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)
@@ -380,12 +378,14 @@ collapseSizes <- function(padding) {
 #'   (useful for viewing on smaller touchscreen device)
 #' @param fluid `TRUE` to use a fluid layout. `FALSE` to use a fixed
 #'   layout.
-#' @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
@@ -425,70 +425,18 @@ navbarPage <- function(title,
                        collapsible = FALSE,
                        fluid = TRUE,
                        theme = NULL,
-                       windowTitle = title,
+                       windowTitle = NA,
                        lang = NULL) {
-
-  # alias title so we can avoid conflicts w/ title in withTags
-  pageTitle <- title
-
-  # navbar class based on options
-  # TODO: tagFunction() the navbar logic?
-  navbarClass <- "navbar navbar-default"
-  position <- match.arg(position)
-  if (!is.null(position))
-    navbarClass <- paste0(navbarClass, " navbar-", position)
-  if (inverse)
-    navbarClass <- paste(navbarClass, "navbar-inverse")
-
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
-  # build the tabset
-  tabset <- buildTabset(..., ulClass = "nav navbar-nav", id = id, selected = selected)
-
-  containerClass <- paste0("container", if (fluid) "-fluid")
-
-  # built the container div dynamically to support optional collapsibility
-  if (collapsible) {
-    navId <- paste0("navbar-collapse-", p_randomInt(1000, 10000))
-    containerDiv <- div(class=containerClass,
-      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=containerClass,
-      div(class="navbar-header",
-        span(class="navbar-brand", pageTitle)
-      ),
-      tabset$navList
-    )
-  }
-
-  # build the main tab content div
-  contentDiv <- div(class=containerClass)
-  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,
+  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
@@ -498,19 +446,7 @@ navbarPage <- function(title,
 #' @rdname navbarPage
 #' @export
 navbarMenu <- function(title, ..., menuName = title, icon = NULL) {
-  icon <- prepTabIcon(icon)
-  structure(list(title = title,
-                 menuName = menuName,
-                 tabs = list2(...),
-                 # Here for legacy reasons
-                 # https://github.com/cran/miniUI/blob/74c87d3/R/layout.R#L369
-                 iconClass = tagGetAttribute(icon, "class"),
-                 icon = icon),
-            class = "shiny.navbarmenu")
-}
-
-isNavbarMenu <- function(x) {
-  inherits(x, "shiny.navbarmenu")
+  bslib::nav_menu(title, ..., value = menuName, icon = icon)
 }
 
 #' Create a well panel
@@ -645,39 +581,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) {
-  icon <- prepTabIcon(icon)
-  pane <- div(
-    class = "tab-pane",
-    title = title,
-    `data-value` = value,
-    # Here for legacy reasons
-    # https://github.com/cran/miniUI/blob/74c87d/R/layout.R#L395
-    `data-icon-class` = tagGetAttribute(icon, "class"),
-    ...
-  )
-  attr(pane, "_shiny_icon") <- icon
-  pane
-}
-
-isTabPanel <- function(x) {
-  if (!inherits(x, "shiny.tag")) return(FALSE)
-  class <- tagGetAttribute(x, "class") %||% ""
-  "tab-pane" %in% strsplit(class, "\\s+")[[1]]
+  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
@@ -753,20 +664,17 @@ tabsetPanel <- function(...,
                         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
+  )
 
-  type <- match.arg(type)
-  tabset <- buildTabset(..., ulClass = paste0("nav nav-", type), id = id, selected = selected)
-
-  tags$div(
-    class = "tabbable",
-    !!!dropNulls(list(
-      tabset$navList,
-      header,
-      tabset$content,
-      footer
-    ))
+  # 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)
   )
 }
 
@@ -822,275 +730,18 @@ navlistPanel <- function(...,
                          well = TRUE,
                          fluid = TRUE,
                          widths = c(4, 8)) {
-
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
-  tabset <- buildTabset(
-    ..., ulClass = "nav nav-pills nav-stacked",
-    textFilter = function(text) tags$li(class = "navbar-brand", text),
-    id = id, selected = selected
-  )
-
-  row <- if (fluid) fluidRow else fixedRow
-
-  row(
-    column(widths[[1]], class = if (well) "well", tabset$navList),
-    column(
-      widths[[2]],
-      !!!dropNulls(list(header, tabset$content, footer))
-    )
-  )
+  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(x) {
-    if (foundSelected || is.character(x)) {
-      # Strings are not selectable items
-
-    } else if (isNavbarMenu(x)) {
-      # Recur for navbarMenus
-      res <- findAndMarkSelectedTab(x$tabs, selected, foundSelected)
-      x$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
-        x <- markTabAsSelected(x)
-      } else {
-        tabValue <- x$attribs$`data-value` %||% x$attribs$title
-        if (identical(selected, tabValue)) {
-          foundSelected <<- TRUE
-          x <- markTabAsSelected(x)
-        }
-      }
-    }
-    return(x)
-  })
-  return(list(tabs = tabs, foundSelected = foundSelected))
-}
-
-prepTabIcon <- function(x = NULL) {
-  if (is.null(x)) return(NULL)
-  if (!inherits(x, "shiny.tag")) {
-    stop(
-      "`icon` must be a `shiny.tag` object. ",
-      "Try passing `icon()` (or `tags$i()`) to the `icon` parameter.",
-      call. = FALSE
-    )
-  }
-
-  is_fa <- grepl("fa-", tagGetAttribute(x, "class") %||% "", fixed = TRUE)
-  if (!is_fa) {
-    return(x)
-  }
-
-  # for font-awesome we specify fixed-width
-  tagAppendAttributes(x, class = "fa-fw")
-}
-
-# 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(..., ulClass, textFilter = NULL, id = NULL,
-                        selected = NULL, foundSelected = FALSE) {
-
-  tabs <- dropNulls(list2(...))
-  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, "[[", "liTag"))
-
-  tabContent <- tags$div(class = "tab-content",
-                  `data-tabsetid` = tabsetId, !!!lapply(tabs, "[[", "divTag"))
-
-  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 <- divTag %||% tabs[[index]]
-
-  # Handles navlistPanel() headers and dropdown dividers
-  if (is.character(divTag) && !is.null(textFilter)) {
-    return(list(liTag = textFilter(divTag), divTag = NULL))
-  }
-
-  if (isNavbarMenu(divTag)) {
-    # tabPanelMenu item: build the child tabset
-    tabset <- buildTabset(
-      !!!divTag$tabs, ulClass = "dropdown-menu",
-      textFilter = navbarMenuTextFilter,
-      foundSelected = foundSelected
-    )
-    return(buildDropdown(divTag, tabset))
-  }
-
-  if (isTabPanel(divTag)) {
-    return(buildNavItem(divTag, tabsetId, index))
-  }
-
-  # The behavior is undefined at this point, so construct a condition message
-  msg <- paste0(
-    "Expected a collection `tabPanel()`s",
-    if (is.null(textFilter)) " and `navbarMenu()`.",
-    if (!is.null(textFilter)) ", `navbarMenu()`, and/or character strings.",
-    " Consider using `header` or `footer` if you wish to place content above (or below) every panel's contents"
-  )
-
-  # Luckily this case has never worked, so it's safe to throw here
-  # https://github.com/rstudio/shiny/issues/3313
-  if (!inherits(divTag, "shiny.tag"))  {
-    stop(msg, call. = FALSE)
-  }
-
-  # Unfortunately, this 'off-label' use case creates an 'empty' nav and includes
-  # the divTag content on every tab. There shouldn't be any reason to be relying on
-  # this behavior since we now have pre/post arguments, so throw a warning, but still
-  # support the use case since we don't make breaking changes
-  warning(msg, call. = FALSE)
-
-  return(buildNavItem(divTag, tabsetId, index))
-}
-
-buildNavItem <- function(divTag, tabsetId, index) {
-  id <- paste("tab", tabsetId, index, sep = "-")
-  # Get title attribute directory (not via tagGetAttribute()) so that contents
-  # don't get passed to as.character().
-  # https://github.com/rstudio/shiny/issues/3352
-  title <- divTag$attribs[["title"]]
-  value <- divTag$attribs[["data-value"]]
-  active <- isTabSelected(divTag)
-  divTag <- tagAppendAttributes(divTag, class = if (active) "active")
-  divTag$attribs$id <- id
-  divTag$attribs$title <- NULL
-  list(
-    divTag = divTag,
-    liTag = tagAddRenderHook(
-      liTag(id, title, value, attr(divTag, "_shiny_icon")),
-      function(x) {
-        if (isTRUE(getCurrentThemeVersion() >= 4)) {
-          tagQuery(x)$
-            addClass("nav-item")$
-            find("a")$
-            addClass(c("nav-link", if (active) "active"))$
-            allTags()
-        } else {
-          tagAppendAttributes(x, class = if (active) "active")
-        }
-      }
-    )
-  )
-}
-
-liTag <- function(id, title, value, icon) {
-  tags$li(
-    tags$a(
-      href = paste0("#", id),
-      `data-toggle` = "tab",
-      `data-value` = value,
-       icon, title
-    )
-  )
-}
-
-buildDropdown <- function(divTag, tabset) {
-
-  navList <- tagAddRenderHook(
-    tabset$navList,
-    function(x) {
-      if (isTRUE(getCurrentThemeVersion() >= 4)) {
-        tagQuery(x)$
-          find(".nav-item")$
-          removeClass("nav-item")$
-          find(".nav-link")$
-          removeClass("nav-link")$
-          addClass("dropdown-item")$
-          allTags()
-      } else {
-        x
-      }
-    }
-  )
-
-  active <- containsSelectedTab(divTag$tabs)
-
-  dropdown <- tags$li(
-    class = "dropdown",
-    tags$a(
-      href = "#",
-      class = "dropdown-toggle",
-      `data-toggle` = "dropdown",
-      `data-value` = divTag$menuName,
-      divTag$icon,
-      divTag$title,
-      tags$b(class = "caret")
-    ),
-    navList,
-    .renderHook = function(x) {
-      if (isTRUE(getCurrentThemeVersion() >= 4)) {
-        tagQuery(x)$
-          addClass("nav-item")$
-          find(".dropdown-toggle")$
-          addClass("nav-link")$
-          allTags()
-      } else {
-        x
-      }
-    }
-  )
-
-  list(
-    divTag = tabset$content$children,
-    liTag = dropdown
-  )
-}
-
 #' Create a text output element
 #'
 #' Render a reactive output variable as text within an application page.
@@ -1456,11 +1107,17 @@ tableOutput <- function(outputId) {
 
 dataTableDependency <- list(
   htmlDependency(
-    "datatables", "1.10.5", c(href = "shared/datatables"),
+    "datatables",
+    "1.10.5",
+    src = "www/shared/datatables",
+    package = "shiny",
     script = "js/jquery.dataTables.min.js"
   ),
   htmlDependency(
-    "datatables-bootstrap", "1.10.5", c(href = "shared/datatables"),
+    "datatables-bootstrap",
+    "1.10.5",
+    src = "www/shared/datatables",
+    package = "shiny",
     stylesheet = c("css/dataTables.bootstrap.css", "css/dataTables.extra.css"),
     script = "js/dataTables.bootstrap.js"
   )
@@ -1500,7 +1157,7 @@ dataTableOutput <- function(outputId) {
 htmlOutput <- function(outputId, inline = FALSE,
   container = if (inline) span else div, ...)
 {
-  if (anyUnnamed(list(...))) {
+  if (any_unnamed(list(...))) {
     warning("Unnamed elements in ... will be replaced with dynamic UI.")
   }
   container(id = outputId, class="shiny-html-output", ...)

R/conditions.R

@@ -228,7 +228,9 @@ withLogErrors <- function(expr,
       if (promises::is.promise(result)) {
         result <- promises::catch(result, function(cond) {
           # Don't print shiny.silent.error (i.e. validation errors)
-          if (inherits(cond, "shiny.silent.error")) return()
+          if (cnd_inherits(cond, "shiny.silent.error")) {
+            return()
+          }
           if (isTRUE(getOption("show.error.messages"))) {
             printError(cond, full = full, offset = offset)
           }
@@ -239,7 +241,7 @@ withLogErrors <- function(expr,
     },
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
-      if (inherits(cond, "shiny.silent.error")) return()
+      if (cnd_inherits(cond, "shiny.silent.error")) return()
       if (isTRUE(getOption("show.error.messages"))) {
         printError(cond, full = full, offset = offset)
       }

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

@@ -1,55 +1,6 @@
 # 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
@@ -62,9 +13,9 @@ register_upgrade_message <- function(pkg, version) {
 
   # 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")
+  s3_register("knitr::knit_print", "reactive")
+  s3_register("knitr::knit_print", "shiny.appobj")
+  s3_register("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

R/graph.R

@@ -4,7 +4,7 @@
 # @param version The version of the package
 check_suggested <- function(package, version = NULL) {
 
-  if (is_available(package, version)) {
+  if (is_installed(package, version)) {
     return()
   }
 
@@ -115,22 +115,28 @@ check_reactlog <- function() {
 }
 # 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_version <- local({
+  version <- NULL
+  function() {
+    if (!is.null(version)) return(version)
 
-  reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
-  if (length(reactlog_info) == 0) {
-    stop("reactlog can not be found in shiny DESCRIPTION file")
+    desc <- read.dcf(system_file("DESCRIPTION", package = "shiny"))
+    suggests <- desc[1,"Suggests"][[1]]
+    suggests_pkgs <- strsplit(suggests, "\n")[[1]]
+
+    reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
+    if (length(reactlog_info) == 0) {
+      stop("reactlog can not be found in shiny DESCRIPTION file")
+    }
+
+    reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
+    reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
+    reactlog_info <- sub("^[>= ]*", "", reactlog_info)
+
+    version <<- package_version(reactlog_info)
+    version
   }
-
-  reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
-  reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
-  reactlog_info <- sub("^[>= ]*", "", reactlog_info)
-
-  package_version(reactlog_info)
-}
+})
 
 
 RLog <- R6Class(
@@ -512,7 +518,7 @@ MessageLogger = R6Class(
       return(txt)
     },
     singleLine = function(txt) {
-      gsub("[^\\]\\n", "\\\\n", txt)
+      gsub("([^\\])\\n", "\\1\\\\n", txt)
     },
     valueStr = function(valueStr) {
       paste0(

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

@@ -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)
 
@@ -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

@@ -4,12 +4,12 @@ startPNG <- function(filename, width, height, res, ...) {
   # 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")) {
+  if ((getOption('shiny.useragg') %||% FALSE) && is_installed("ragg")) {
     pngfun <- ragg::agg_png
   } else if (capabilities("aqua")) {
     # i.e., png(type = 'quartz')
     pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %||% TRUE) && is_available("Cairo")) {
+  } else if ((getOption('shiny.usecairo') %||% TRUE) && is_installed("Cairo")) {
     pngfun <- Cairo::CairoPNG
   } else {
     # i.e., png(type = 'cairo')

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.
@@ -158,19 +157,20 @@ 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")
+  scss_file <- system_file(package = "shiny", "www/shared/datepicker/scss/build3.scss")
 
   bslib::bs_dependency(
     input = sass::sass_file(scss_file),
     theme = theme,
     name = "bootstrap-datepicker",
-    version = datePickerVersion,
-    cache_key_extra = shinyPackageVersion()
+    version = version_bs_date_picker,
+    cache_key_extra = get_package_version("shiny")
   )
 }

R/input-file.R

@@ -23,7 +23,18 @@
 #' @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()) {
@@ -73,7 +84,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)
 
@@ -101,6 +113,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-select.R

@@ -213,14 +213,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,19 +236,14 @@ 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/")
+  selectizeDir <- system_file(package = "shiny", "www/shared/selectize/")
+  bs_version <- bslib::theme_version(theme)
   stylesheet <- file.path(
-    selectizeDir, "scss",
-    if ("3" %in% bslib::theme_version(theme)) {
-      "selectize.bootstrap3.scss"
-    } else {
-      "selectize.bootstrap4.scss"
-    }
+    selectizeDir, "scss", paste0("selectize.bootstrap", bs_version, ".scss")
   )
   # It'd be cleaner to ship the JS in a separate, href-based,
   # HTML dependency (which we currently do for other themable widgets),
@@ -271,16 +259,18 @@ selectizeDependencyFunc <- function(theme) {
     input = sass::sass_file(stylesheet),
     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)
   )
 }
 
 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",

R/input-slider.R

@@ -201,19 +201,21 @@ 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)
@@ -224,36 +226,24 @@ 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 = list(
+      list(accent = "$component-active-bg"),
+      sass::sass_file(
+        system_file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss")
+      )
+    ),
     theme = theme,
     name = "ionRangeSlider",
-    version = ionRangeSliderVersion,
-    cache_key_extra = shinyPackageVersion()
+    version = version_ion_range_slider,
+    cache_key_extra = get_package_version("shiny")
   )
 }
 

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

@@ -79,8 +79,8 @@ absolutePanel <- function(...,
   if (isTRUE(draggable)) {
     divTag <- tagAppendAttributes(divTag, class='draggable')
     return(tagList(
-      singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
       divTag,
+      jqueryuiDependency(),
       tags$script('$(".draggable").draggable();')
     ))
   } else {
@@ -99,3 +99,14 @@ fixedPanel <- function(...,
                 width=width, height=height, draggable=draggable, cursor=match.arg(cursor),
                 fixed=TRUE)
 }
+
+
+jqueryuiDependency <- function() {
+  htmlDependency(
+    'jqueryui',
+    '1.12.1',
+    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,

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()) {

R/modal.R

@@ -151,18 +151,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 +178,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/reactives.R

@@ -875,8 +875,7 @@ Observable <- R6Class(
         invisible(.value)
     },
     format = function() {
-      label <- sprintf('reactive(%s)', paste(deparse(body(.origFunc)), collapse='\n'))
-      strsplit(label, "\n")[[1]]
+      simpleExprToFunction(fn_body(.origFunc), "reactive")
     },
     .updateValue = function() {
       ctx <- Context$new(.domain, .label, type = 'observable',
@@ -945,14 +944,15 @@ Observable <- R6Class(
 #' See the [Shiny tutorial](https://shiny.rstudio.com/tutorial/) for
 #' more information about reactive expressions.
 #'
-#' @param x For `reactive`, an expression (quoted or unquoted). For
-#'   `is.reactive`, an object to test.
-#' @param env The parent environment for the reactive expression. By default,
-#'   this is the calling environment, the same as when defining an ordinary
-#'   non-reactive expression.
-#' @param quoted Is the expression quoted? By default, this is `FALSE`.
-#'   This is useful when you want to use an expression that is stored in a
-#'   variable; to do so, it must be quoted with `quote()`.
+#' @param x For `is.reactive()`, an object to test. For `reactive()`, an expression. When passing in a [`quo()`]sure with `reactive()`, remember to use [`rlang::inject()`] to distinguish that you are passing in the content of your quosure, not the expression of the quosure.
+#' @template param-env
+#' @templateVar x x
+#' @templateVar env env
+#' @templateVar quoted quoted
+#' @template param-quoted
+#' @templateVar x x
+#' @templateVar quoted quoted
+
 #' @param label A label for the reactive expression, useful for debugging.
 #' @param domain See [domains].
 #' @param ..stacktraceon Advanced use only. For stack manipulation purposes; see
@@ -961,46 +961,56 @@ Observable <- R6Class(
 #' @return a function, wrapped in a S3 class "reactive"
 #'
 #' @examples
+#' library(rlang)
 #' values <- reactiveValues(A=1)
 #'
 #' reactiveB <- reactive({
 #'   values$A + 1
 #' })
-#'
-#' # Can use quoted expressions
-#' reactiveC <- reactive(quote({ values$A + 2 }), quoted = TRUE)
-#'
-#' # To store expressions for later conversion to reactive, use quote()
-#' expr_q <- quote({ values$A + 3 })
-#' reactiveD <- reactive(expr_q, quoted = TRUE)
-#'
 #' # View the values from the R console with isolate()
 #' isolate(reactiveB())
+#' # 2
+#'
+#' # To store expressions for later conversion to reactive, use quote()
+#' myquo <- rlang::quo(values$A + 2)
+#' # Unexpected value! Sending a quosure directly will not work as expected.
+#' reactiveC <- reactive(myquo)
+#' # We'd hope for `3`, but instead we get the quosure that was supplied.
 #' isolate(reactiveC())
+#'
+#' # Instead, the quosure should be `rlang::inject()`ed
+#' reactiveD <- rlang::inject(reactive(!!myquo))
 #' isolate(reactiveD())
+#' # 3
+#'
+#' # (Legacy) Can use quoted expressions
+#' expr <- quote({ values$A + 3 })
+#' reactiveE <- reactive(expr, quoted = TRUE)
+#' isolate(reactiveE())
+#' # 4
+#'
 #' @export
-reactive <- function(x, env = parent.frame(), quoted = FALSE,
+reactive <- function(
+  x,
+  env = parent.frame(),
+  quoted = FALSE,
   ...,
   label = NULL,
   domain = getDefaultReactiveDomain(),
-  ..stacktraceon = TRUE)
-{
+  ..stacktraceon = TRUE
+) {
   check_dots_empty()
 
-  x <- get_quosure(x, env, quoted)
-  fun <- as_function(x)
-  # as_function returns a function that takes `...`. We need one that takes no
-  # args.
-  formals(fun) <- list()
-
+  func <- installExprFunction(x, "func", env, quoted, wrappedWithLabel = FALSE)
   # Attach a label and a reference to the original user source for debugging
-  label <- exprToLabel(get_expr(x), "reactive", label)
+  userExpr <- fn_body(func)
+  label <- exprToLabel(userExpr, "reactive", label)
 
-  o <- Observable$new(fun, label, domain, ..stacktraceon = ..stacktraceon)
+  o <- Observable$new(func, label, domain, ..stacktraceon = ..stacktraceon)
   structure(
     o$getValue,
     observable = o,
-    cacheHint = list(userExpr = zap_srcref(get_expr(x))),
+    cacheHint = list(userExpr = zap_srcref(userExpr)),
     class = c("reactiveExpr", "reactive", "function")
   )
 }
@@ -1193,7 +1203,7 @@ Observer <- R6Class(
             # validation = function(e) NULL,
             # shiny.output.cancel = function(e) NULL
 
-            if (inherits(e, "shiny.silent.error")) {
+            if (cnd_inherits(e, "shiny.silent.error")) {
               return()
             }
 
@@ -1325,12 +1335,7 @@ Observer <- R6Class(
 #'
 #' @param x An expression (quoted or unquoted). Any return value will be
 #'   ignored.
-#' @param env The parent environment for the reactive expression. By default,
-#'   this is the calling environment, the same as when defining an ordinary
-#'   non-reactive expression.
-#' @param quoted Is the expression quoted? By default, this is `FALSE`.
-#'   This is useful when you want to use an expression that is stored in a
-#'   variable; to do so, it must be quoted with `quote()`.
+#' @inheritParams reactive
 #' @param label A label for the observer, useful for debugging.
 #' @param suspended If `TRUE`, start the observer in a suspended state. If
 #'   `FALSE` (the default), start in a non-suspended state.
@@ -1389,18 +1394,21 @@ Observer <- R6Class(
 #'   print(values$A + 1)
 #' })
 #'
-#' # Can use quoted expressions
-#' obsC <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
+#' # To store expressions for later conversion to observe, use rlang::quo()
+#' myquo <- rlang::quo({ print(values$A + 3) })
+#' obsC <- rlang::inject(observe(!!myquo))
 #'
-#' # To store expressions for later conversion to observe, use quote()
-#' expr_q <- quote({ print(values$A + 3) })
-#' obsD <- observe(expr_q, quoted = TRUE)
+#' # (Legacy) Can use quoted expressions
+#' obsD <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
 #'
 #' # In a normal Shiny app, the web client will trigger flush events. If you
 #' # are at the console, you can force a flush with flushReact()
 #' shiny:::flushReact()
 #' @export
-observe <- function(x, env = parent.frame(), quoted = FALSE,
+observe <- function(
+  x,
+  env = parent.frame(),
+  quoted = FALSE,
   ...,
   label = NULL,
   suspended = FALSE,
@@ -1411,18 +1419,11 @@ observe <- function(x, env = parent.frame(), quoted = FALSE,
 {
   check_dots_empty()
 
-  x <- get_quosure(x, env, quoted)
-  fun <- as_function(x)
-  # as_function returns a function that takes `...`. We need one that takes no
-  # args.
-  formals(fun) <- list()
-
-  if (is.null(label)) {
-    label <- sprintf('observe(%s)', paste(deparse(get_expr(x)), collapse='\n'))
-  }
+  func <- installExprFunction(x, "func", env, quoted)
+  label <- funcToLabel(func, "observe", label)
 
   o <- Observer$new(
-    fun,
+    func,
     label = label,
     suspended = suspended,
     priority = priority,
@@ -2144,23 +2145,30 @@ maskReactiveContext <- function(expr) {
 #' @param valueExpr The expression that produces the return value of the
 #'   `eventReactive`. It will be executed within an [isolate()]
 #'   scope.
-#' @param event.env The parent environment for `eventExpr`. By default,
-#'   this is the calling environment.
-#' @param event.quoted Is the `eventExpr` expression quoted? By default,
-#'   this is `FALSE`. This is useful when you want to use an expression
-#'   that is stored in a variable; to do so, it must be quoted with
-#'   `quote()`.
-#' @param handler.env The parent environment for `handlerExpr`. By default,
-#'   this is the calling environment.
-#' @param handler.quoted Is the `handlerExpr` expression quoted? By
-#'   default, this is `FALSE`. This is useful when you want to use an
-#'   expression that is stored in a variable; to do so, it must be quoted with
-#'   `quote()`.
-#' @param value.env The parent environment for `valueExpr`. By default,
-#'   this is the calling environment.
-#' @param value.quoted Is the `valueExpr` expression quoted? By default,
-#'   this is `FALSE`. This is useful when you want to use an expression
-#'   that is stored in a variable; to do so, it must be quoted with `quote()`.
+#' @param event.env The parent environment for the reactive expression. By default,
+#'   this is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression. If `eventExpr` is a quosure and `event.quoted` is `TRUE`,
+#'   then `event.env` is ignored.
+#' @param event.quoted If it is `TRUE`, then the [`quote()`]ed value of `eventExpr`
+#'   will be used when `eventExpr` is evaluated. If `eventExpr` is a quosure and you
+#'   would like to use its expression as a value for `eventExpr`, then you must set
+#'  `event.quoted` to `TRUE`.
+#' @param handler.env The parent environment for the reactive expression. By default,
+#'   this is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression. If `handlerExpr` is a quosure and `handler.quoted` is `TRUE`,
+#'   then `handler.env` is ignored.
+#' @param handler.quoted If it is `TRUE`, then the [`quote()`]ed value of `handlerExpr`
+#'   will be used when `handlerExpr` is evaluated. If `handlerExpr` is a quosure and you
+#'   would like to use its expression as a value for `handlerExpr`, then you must set
+#'  `handler.quoted` to `TRUE`.
+#' @param value.env The parent environment for the reactive expression. By default,
+#'   this is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression. If `valueExpr` is a quosure and `value.quoted` is `TRUE`,
+#'   then `value.env` is ignored.
+#' @param value.quoted If it is `TRUE`, then the [`quote()`]ed value of `valueExpr`
+#'   will be used when `valueExpr` is evaluated. If `valueExpr` is a quosure and you
+#'   would like to use its expression as a value for `valueExpr`, then you must set
+#'  `value.quoted` to `TRUE`.
 #' @param label A label for the observer or reactive, useful for debugging.
 #' @param suspended If `TRUE`, start the observer in a suspended state. If
 #'   `FALSE` (the default), start in a non-suspended state.
@@ -2274,15 +2282,13 @@ observeEvent <- function(eventExpr, handlerExpr,
 {
   check_dots_empty()
 
-  eventExpr   <- get_quosure(eventExpr,   event.env,   event.quoted)
-  handlerExpr <- get_quosure(handlerExpr, handler.env, handler.quoted)
+  eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
+  handlerQ <- exprToQuo(handlerExpr, handler.env, handler.quoted)
 
-  if (is.null(label)) {
-    label <- sprintf('observeEvent(%s)', paste(deparse(get_expr(eventExpr)), collapse='\n'))
-  }
+  label <- quoToLabel(eventQ, "observeEvent", label)
 
   handler <- inject(observe(
-    !!handlerExpr,
+    !!handlerQ,
     label = label,
     suspended = suspended,
     priority = priority,
@@ -2296,7 +2302,7 @@ observeEvent <- function(eventExpr, handlerExpr,
     ignoreInit = ignoreInit,
     once = once,
     label = label,
-    !!eventExpr,
+    !!eventQ,
     x = handler
   ))
 
@@ -2314,19 +2320,17 @@ eventReactive <- function(eventExpr, valueExpr,
 {
   check_dots_empty()
 
-  eventExpr <- get_quosure(eventExpr, event.env, event.quoted)
-  valueExpr <- get_quosure(valueExpr, value.env, value.quoted)
+  eventQ <- exprToQuo(eventExpr, event.env, event.quoted)
+  valueQ <- exprToQuo(valueExpr, value.env, value.quoted)
 
-  if (is.null(label)) {
-    label <- sprintf('eventReactive(%s)', paste(deparse(get_expr(eventExpr)), collapse='\n'))
-  }
+  label <- quoToLabel(eventQ, "eventReactive", label)
 
   invisible(inject(bindEvent(
     ignoreNULL = ignoreNULL,
     ignoreInit = ignoreInit,
     label = label,
-    !!eventExpr,
-    x = reactive(!!valueExpr, domain = domain, label = label)
+    !!eventQ,
+    x = reactive(!!valueQ, domain = domain, label = label)
   )))
 }
 

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

@@ -36,17 +36,17 @@
 #' @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
 #'   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 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 [grDevices::png()].
 #'   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,7 +187,7 @@ 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
@@ -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)
   )
@@ -288,6 +291,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 +306,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 +343,24 @@ custom_print.ggplot <- function(x) {
   ), class = "ggplot_build_gtable")
 }
 
+# Infer alt text description from renderPlot() value
+# (currently just ggplot2 is supported)
+getAltText <- function(x, default = "Plot object") {
+  # Since, inside renderPlot(), custom_print.ggplot()
+  # overrides print.ggplot, this class indicates a ggplot()
+  if (!inherits(x, "ggplot_build_gtable")) {
+    return(default)
+  }
+  # ggplot2::get_alt_text() was added in v3.3.4
+  # https://github.com/tidyverse/ggplot2/pull/4482
+  get_alt <- getNamespace("ggplot2")$get_alt_text
+  if (!is.function(get_alt)) {
+    return(default)
+  }
+  alt <- paste(get_alt(x$build), collapse = " ")
+  if (nzchar(alt)) alt else default
+}
+
 # The coordmap extraction functions below return something like the examples
 # below. For base graphics:
 # plot(mtcars$wt, mtcars$mpg)
@@ -590,7 +612,7 @@ getGgplotCoordmap <- function(p, width, height, res) {
 find_panel_info <- function(b) {
   # Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
   # an API for extracting the necessary information.
-  ggplot_ver <- utils::packageVersion("ggplot2")
+  ggplot_ver <- get_package_version("ggplot2")
 
   if (ggplot_ver > "2.2.1") {
     find_panel_info_api(b)

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
@@ -301,7 +304,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
           }
         }
@@ -463,7 +467,7 @@ runExample <- function(example=NA,
                        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')
+  examplesDir <- system_file('examples', package='shiny')
   dir <- resolve(examplesDir, example)
   if (is.null(dir)) {
     if (is.na(example)) {

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

@@ -41,12 +41,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){
@@ -181,7 +181,7 @@ registerInputHandler("shiny.datetime", function(val, ...){
 
 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")
+  class(val) <- c("shinyActionButtonValue", class(val))
   val
 })
 

R/server.R

@@ -128,7 +128,7 @@ 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
@@ -385,7 +385,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

@@ -94,6 +94,10 @@ getShinyOption <- function(name, default = NULL) {
 #'   numbers to JSON format to send to the client web browser.}
 #' \item{shiny.launch.browser (defaults to `interactive()`)}{A boolean which controls the default behavior
 #'   when an app is run. See [runApp()] for more information.}
+#' \item{shiny.mathjax.url (defaults to `"https://mathjax.rstudio.com/latest/MathJax.js"`)}{
+#'   The URL that should be used to load MathJax, via [withMathJax()].}
+#' \item{shiny.mathjax.config (defaults to `"config=TeX-AMS-MML_HTMLorMML"`)}{The querystring
+#'   used to load MathJax, via [withMathJax()].}
 #' \item{shiny.maxRequestSize (defaults to 5MB)}{This is a number which specifies the maximum
 #'   web request size, which serves as a size limit for file uploads.}
 #' \item{shiny.minified (defaults to `TRUE`)}{By default
@@ -125,6 +129,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),

R/shiny-package.R

@@ -2,7 +2,7 @@
 
 ## 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 %...!%
@@ -11,11 +11,13 @@
 #'    promise promise_resolve promise_reject is.promising
 #'    as.promise
 #' @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 list2
 #'    missing_arg is_missing maybe_missing
+#'    quo_is_missing fn_fmls<- fn_body fn_body<-
 #' @importFrom ellipsis
 #'    check_dots_empty check_dots_unnamed
 #' @import htmltools

R/shiny.R

@@ -403,7 +403,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))
@@ -478,6 +478,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 +549,7 @@ ShinySession <- R6Class(
               }
             )
 
-            values$input <- sortByName(values$input)
+            values$input <- sortByName(values$input, method = sortMethod)
           }
 
           if (!is.null(params$output)) {
@@ -548,7 +577,7 @@ ShinySession <- R6Class(
               }
             )
 
-            values$output <- sortByName(values$output)
+            values$output <- sortByName(values$output, method = sortMethod)
           }
 
           if (!is.null(params$export)) {
@@ -569,7 +598,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
@@ -825,7 +854,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))
@@ -913,7 +942,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.")
           }
 
@@ -1114,7 +1143,12 @@ 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 (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
@@ -1701,7 +1735,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 +1748,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 +1762,7 @@ ShinySession <- R6Class(
         reqString("input", input),
         reqString("output", output),
         reqString("export", export),
+        reqString("sortC", sortC),
         paste0("format=", format),
         sep = "&"
       )

R/shinyapp.R

@@ -193,7 +193,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     staticPaths <- list()
   }
 
-  fallbackWWWDir <- system.file("www-dir", package = "shiny")
+  fallbackWWWDir <- system_file("www-dir", package = "shiny")
 
   serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE,
     function(serverR) {
@@ -286,7 +286,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
-  if (!getOption("shiny.autoreload", FALSE)) {
+  if (!get_devmode_option("shiny.autoreload", FALSE)) {
     return(function(){})
   }
 
@@ -339,7 +339,7 @@ initAutoReloadMonitor <- function(dir) {
 #' @param appDir The application directory. If `appDir` is `NULL` or
 #'   not supplied, the nearest enclosing directory that is a Shiny app, starting
 #'   with the current directory, is used.
-#' @param renv The environmeny in which the files in the `R/` directory should
+#' @param renv The environment in which the files in the `R/` directory should
 #'   be evaluated.
 #' @param globalrenv The environment in which `global.R` should be evaluated. If
 #'   `NULL`, `global.R` will not be evaluated at all.
@@ -455,7 +455,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
@@ -55,8 +59,14 @@ renderPage <- function(ui, showcase=0, testMode=FALSE) {
   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
+      )
   }
 
   html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
@@ -68,23 +78,19 @@ jqueryDependency <- function() {
   if (version == 3) {
     return(htmlDependency(
       "jquery", version_jquery,
-      src = c(
-        href = "shared",
-        file = "www/shared"
-      ),
+      src = "www/shared",
       package = "shiny",
-      script = "jquery.min.js"
+      script = "jquery.min.js",
+      all_files = FALSE
     ))
   }
   if (version == 1) {
     return(htmlDependency(
       "jquery", "1.12.4",
-      src = c(
-        href = "shared/legacy",
-        file = "www/shared/legacy"
-      ),
+      src = "www/shared/legacy",
       package = "shiny",
-      script = "jquery.min.js"
+      script = "jquery.min.js",
+      all_files = FALSE
     ))
   }
   stop("Unsupported version of jQuery: ", version)
@@ -95,8 +101,9 @@ shinyDependencies <- function() {
     bslib::bs_dependency_defer(shinyDependencyCSS),
     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(
@@ -106,24 +113,27 @@ shinyDependencies <- function() {
         ))
           "shiny.min.js"
         else
-          "shiny.js"
+          "shiny.js",
+      all_files = FALSE
     )
   )
 }
 
 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_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)
 

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
     })
@@ -133,10 +151,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 +188,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 +217,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,
@@ -316,9 +387,7 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
 #'   the output, see [plotPNG()].
 #'
 #' @param expr An expression that returns a list.
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
+#' @inheritParams renderUI
 #' @param deleteFile Should the file in `func()$src` be deleted after
 #'   it is sent to the client browser? Generally speaking, if the image is a
 #'   temp file generated within `func`, then this should be `TRUE`;
@@ -397,11 +466,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,9 +591,7 @@ 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
@@ -536,8 +602,7 @@ isTemp <- function(path, tempDir = tempdir(), mustExist) {
 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
@@ -569,7 +634,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
     outputArgs,
     cacheHint = list(
       label = "renderPrint",
-      origUserExpr = get_expr(expr)
+      origUserExpr = installedFuncExpr(func)
     )
   )
 }
@@ -619,11 +684,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,9 +708,13 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' @param expr An expression that returns a Shiny tag object, [HTML()],
 #'   or a list of such objects.
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)? This
-#'   is useful if you want to save an expression in a variable.
+#' @template param-env
+#' @templateVar x expr
+#' @templateVar env env
+#' @templateVar quoted quoted
+#' @template param-quoted
+#' @templateVar x expr
+#' @templateVar quoted quoted
 #' @param outputArgs A list of arguments to be passed through to the implicit
 #'   call to [uiOutput()] when `renderUI` is used in an
 #'   interactive R Markdown document.
@@ -675,8 +743,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 +778,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.
@@ -743,7 +810,7 @@ renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
 #' shinyApp(ui, server)
 #' }
 #' @export
-downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()) {
+downloadHandler <- function(filename, content, contentType=NULL, outputArgs=list()) {
   renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
   }
@@ -755,6 +822,10 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #' Table output with the JavaScript DataTables library
 #'
 #' @description
+#' `r lifecycle::badge("superseded")` Please use
+#' \href{https://rstudio.github.io/DT/shiny.html}{\code{DT::renderDataTable()}}.
+#' (Shiny 0.11.1)
+#'
 #' 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
@@ -829,8 +900,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     )
   }
 
-  expr <- get_quosure(expr, env, quoted)
-  func <- quoToFunction(expr, "renderDataTable")
+  func <- installExprFunction(expr, "func", env, quoted, label = "renderDataTable")
 
   renderFunc <- function(shinysession, name, ...) {
     if (is.function(options)) options <- options()
@@ -883,7 +953,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

R/showcase.R

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

R/staticimports.R

@@ -0,0 +1,216 @@
+# 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)
+  }
+  installed && isTRUE(get_package_version(pkg) >= version)
+}
+
+register_upgrade_message <- function(pkg, version, error = FALSE) {
+
+  msg <- sprintf(
+    "This version of '%s' is designed to work with '%s' >= %s.
+    Please upgrade via install.packages('%s').",
+    environmentName(environment(register_upgrade_message)),
+    pkg, version, pkg
+  )
+
+  cond <- if (error) stop else packageStartupMessage
+
+  if (pkg %in% loadedNamespaces() && !is_installed(pkg, version)) {
+    cond(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_installed(pkg, version)) cond(msg)
+    }
+  )
+}
+
+# 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 results, because
+# `system.file()` can be slow. Note that because of caching, if
+# `system_file_cached()` is called on a package that isn't installed, then the
+# package is installed, and then `system_file_cached()` is called again, it will
+# still return "".
+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)
+      pkg_dir_cache[[package]] <<- pkg_dir
+    } else {
+      pkg_dir <- pkg_dir_cache[[package]]
+    }
+
+    file.path(pkg_dir, ...)
+  }
+})

R/utils-lang.R

@@ -51,60 +51,199 @@ 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 [`enquo0()`] to not unquote the
+#'   object too early. See [`enquo0()`] for more details.
+#' @inheritParams installExprFunction
+#' @export
+quoToFunction <- function(
+  q,
+  label = sys.call(-1)[[1]],
+  ..stacktraceon = FALSE
+) {
+  func <- quoToSimpleFunction(as_quosure(q))
+  wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
+}
 
-  } 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({})
   }
 
-  x
+  # `as_function()` returns a function that takes `...`. We need one that takes no
+  # args.
+  fn_fmls(fun) <- list()
+
+  fun
+}
+
+
+#' Convert an expression to a function
+#'
+#' `r lifecycle::badge("superseded")` Please use [`installExprFunction()`] for a better
+#' debugging experience (Shiny 0.8.0). If the `expr` and `quoted` parameters are not needed, please see
+#' [`quoToFunction()`] (Shiny 1.6.0).
+#'
+#' Similar to [installExprFunction()] but doesn't register debug hooks.
+#'
+#' @param expr A quoted or unquoted expression, or a quosure.
+#' @param env The desired environment for the function. Defaults to the
+#'   calling environment two steps back.
+#' @param quoted Is the expression quoted?
+#' @seealso [`installExprFunction()`] for the modern approach to converting an expression to a function
+#' @export
+#' @keywords internal
+exprToFunction <- function(expr, env = parent.frame(), quoted = FALSE) {
+  # If `expr` is a raw quosure, must say `quoted = TRUE`; (env is ignored)
+  # If `inject()` a quosure, env is ignored, and quoted should be FALSE (aka ignored).
+  # Make article of usage
+  # * (by joe)
+
+  if (!quoted) {
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+  # MUST call with `quoted = TRUE` as exprToQuo() will not reach high enough
+  q <- exprToQuo(expr, env, quoted = TRUE)
+
+  # MUST call `as_function()`. Can NOT call `new_function()`
+  # rlang has custom logic for handling converting a quosure to a function
+  quoToSimpleFunction(q)
+}
+# For internal use only; External users should be using `exprToFunction()` or `installExprFunction()`
+# MUST be the exact same logic as `exprToFunction()`, but without the `quoToSimpleFunction()` call
+exprToQuo <- function(expr, env = parent.frame(), quoted = FALSE) {
+  if (!quoted) {
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+  q <-
+    if (is_quosure(expr)) {
+      # inject()ed quosure
+      # do nothing
+      expr
+    } else if (is.language(expr) || rlang::is_atomic(expr) || is.null(expr)) {
+      # Most common case...
+      new_quosure(expr, env = env)
+    } else {
+      stop("Don't know how to convert '", class(expr)[1], "' to a function; a quosure or quoted expression was expected")
+    }
+  q
+}
+
+#' @describeIn createRenderFunction converts a user's reactive `expr` into a
+#'   function that's assigned to a `name` in the `assign.env`.
+#'
+#' @param name The name the function should be given
+#' @param eval.env The desired environment for the function. Defaults to the
+#'   calling environment two steps back.
+#' @param assign.env The environment in which the function should be assigned.
+#' @param label A label for the object to be shown in the debugger. Defaults to
+#'   the name of the calling function.
+#' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
+#'   [stacktrace()].
+#' @inheritParams exprToFunction
+#' @export
+installExprFunction <- function(expr, name, eval.env = parent.frame(2),
+                                quoted = FALSE,
+                                assign.env = parent.frame(1),
+                                label = sys.call(-1)[[1]],
+                                wrappedWithLabel = TRUE,
+                                ..stacktraceon = FALSE) {
+  if (!quoted) {
+    quoted <- TRUE
+    expr <- eval(substitute(substitute(expr)), parent.frame())
+  }
+
+  func <- exprToFunction(expr, eval.env, quoted)
+  if (length(label) > 1) {
+    # Just in case the deparsed code is more complicated than we imagine. If we
+    # have a label with length > 1 it causes warnings in wrapFunctionLabel.
+    label <- paste0(label, collapse = "\n")
+  }
+  wrappedWithLabel <- isTRUE(wrappedWithLabel)
+  if (wrappedWithLabel) {
+    func <- wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
+  }
+  assign(name, func, envir = assign.env)
+  if (!wrappedWithLabel) {
+    registerDebugHook(name, assign.env, label)
+  }
+
+  invisible(func)
+}
+
+# Utility function for creating a debugging label, given an expression.
+# `expr` is a quoted expression.
+# `function_name` is the name of the calling function.
+# `label` is an optional user-provided label. If NULL, it will be inferred.
+exprToLabel <- function(expr, function_name, label = NULL) {
+  srcref <- attr(expr, "srcref", exact = TRUE)
+  if (is.null(label)) {
+    label <- rexprSrcrefToLabel(
+      srcref[[1]],
+      simpleExprToFunction(expr, function_name)
+    )
+  }
+  if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
+  attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
+  label
+}
+simpleExprToFunction <- function(expr, function_name) {
+  sprintf('%s(%s)', function_name, paste(deparse(expr), collapse='\n'))
+}
+
+installedFuncExpr <- function(func) {
+  fn_body(attr(func, "wrappedFunc", exact = TRUE))
+}
+
+funcToLabelBody <- function(func) {
+  paste(deparse(installedFuncExpr(func)), collapse='\n')
+}
+funcToLabel <- function(func, functionLabel, label = NULL) {
+  if (!is.null(label)) return(label)
+
+  sprintf(
+    '%s(%s)',
+    functionLabel,
+    funcToLabelBody(func)
+  )
+}
+quoToLabelBody <- function(q) {
+  paste(deparse(quo_get_expr(q)), collapse='\n')
+}
+quoToLabel <- function(q, functionLabel, label = NULL) {
+  if (!is.null(label)) return(label)
+
+  sprintf(
+    '%s(%s)',
+    functionLabel,
+    quoToLabelBody(q)
+  )
 }

R/utils.R

@@ -2,6 +2,11 @@
 #' @include map.R
 NULL
 
+# @staticimports pkg:staticimports
+#   is_installed get_package_version system_file
+#   s3_register register_upgrade_message
+#   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,165 +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)
-  func <- as_function(q)
-  # as_function returns a function that takes `...`. We want one that takes no
-  # args.
-  formals(func) <- list()
-  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.
@@ -654,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')
@@ -1159,7 +989,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')
 #' )
 #'
@@ -1597,21 +1427,31 @@ 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)
   }
   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
@@ -1865,24 +1705,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.9.0"

R/version_ion_range_slider.R

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

R/version_selectize.R

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

R/version_strftime.R

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

README.md

@@ -2,7 +2,7 @@
 
 <!-- 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)
+[![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://community.rstudio.com/new-topic?category=shiny&tags=shiny)
 
 <!-- badges: end -->
@@ -47,14 +47,18 @@ For help with learning fundamental Shiny programming concepts, check out the [Ma
 
 ## 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://community.rstudio.com/new-topic?category=shiny&tags=shiny).
 
-For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues) and also keep in mind that by [writing a good bug report](https://github.com/rstudio/shiny/wiki/Writing-Good-Bug-Reports), you're more likely to get help with your problem. 
+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.
+
+## 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.1, then that version is supported, as well as 4.0, 3.6, 3.5, and 3.4.

babel.config.json

@@ -5,7 +5,7 @@
       "@babel/preset-env",
       {
         "useBuiltIns": "usage",
-        "corejs": "3.9"
+        "corejs": "3.12"
       }
     ]
   ],

inst/app_template/tests/shinytest.R

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

inst/app_template/tests/shinytest/mytest.R

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

inst/app_template/tests/testthat.R

@@ -1,9 +1 @@
-library(testthat)
-
-test_dir(
-  "./testthat",
-  # Run in the app's environment containing all support methods.
-  env = shiny::loadSupport(),
-  # Display the regular progress output and throw an error if any test error is found
-  reporter = c("progress", "fail")
-)
+shinytest2::test_app()

inst/app_template/tests/testthat/test-server.R

@@ -14,5 +14,4 @@ if (isTRUE(rdir)) {
   expect_equal(output$sequence, "1 2 3 4 5 6 7 8 9 10 11 12")
 '
 }
-}}
-})
+}}})

inst/app_template/tests/testthat/test-shinytest2.R

@@ -0,0 +1,18 @@
+library(shinytest2)
+
+test_that("Initial snapshot values are consistent", {
+  app <- AppDriver$new(name = "init")
+  app$expect_values()
+}){{
+if (isTRUE(module)) {
+HTML('
+
+
+test_that("Module values are consistent", {
+  app <- AppDriver$new(name = "mod")
+  app$click("examplemodule1-button")
+  app$click("examplemodule1-button")
+  app$expect_values()
+})')
+}
+}}

inst/www/shared/ionrangeslider/css/ion.rangeSlider.css

@@ -13,8 +13,13 @@
   -moz-user-select: none;
   -ms-user-select: none;
   user-select: none;
-  font-size: 12px;
-  font-family: Arial, sans-serif;
+  /* https://github.com/rstudio/shiny/issues/3443 */
+  /* https://css-tricks.com/inheriting-box-sizing-probably-slightly-better-best-practice/ */
+  box-sizing: border-box;
+}
+
+.irs *, .irs *:before, .irs *:after {
+  box-sizing: inherit;
 }
 
 .irs-line {
@@ -92,7 +97,6 @@
   left: 0;
   width: 1px;
   height: 8px;
-  background: #000;
 }
 
 .irs-grid-pol.small {
@@ -108,7 +112,6 @@
   font-size: 9px;
   line-height: 9px;
   padding: 0 3px;
-  color: #000;
 }
 
 .irs-disable-mask {
@@ -153,7 +156,7 @@
 }
 
 .irs {
-  font-family: Arial, sans-serif;
+  font-family: "Helvetica Neue", Helvetica, Arial, sans-serif;
 }
 
 .irs--shiny {
@@ -167,7 +170,7 @@
 .irs--shiny .irs-line {
   top: 25px;
   height: 8px;
-  background: linear-gradient(to bottom, #dedede -50%, white 150%);
+  background: linear-gradient(to bottom, #dedede -50%, #fff 150%);
   background-color: #ededed;
   border: 1px solid #cccccc;
   border-radius: 8px;
@@ -207,14 +210,13 @@
 }
 
 .irs--shiny .irs-handle.state_hover, .irs--shiny .irs-handle:hover {
-  background: white;
+  background: #fff;
 }
 
 .irs--shiny .irs-min,
 .irs--shiny .irs-max {
   top: 0;
   padding: 1px 3px;
-  color: #333333;
   text-shadow: none;
   background-color: rgba(0, 0, 0, 0.1);
   border-radius: 3px;
@@ -250,12 +252,11 @@
 }
 
 .irs--shiny .irs-grid-pol {
-  background-color: black;
+  background-color: #000;
 }
 
 .irs--shiny .irs-grid-text {
   bottom: 5px;
-  color: #1a1a1a;
 }
 
 .irs--shiny .irs-grid-pol.small {

inst/www/shared/ionrangeslider/scss/_base.scss

@@ -4,8 +4,12 @@
     @include pos-r();
     -webkit-touch-callout: none;
     @include no-click();
-    font-size: 12px;
-    font-family: Arial, sans-serif;
+    /* https://github.com/rstudio/shiny/issues/3443 */
+    /* https://css-tricks.com/inheriting-box-sizing-probably-slightly-better-best-practice/ */
+    box-sizing: border-box;
+    *, *:before, *:after {
+      box-sizing: inherit;
+    }
 
     &-line {
         @include pos-r();
@@ -83,7 +87,6 @@
             left: 0;
             width: 1px;
             height: 8px;
-            background: #000;
 
             &.small {
                 height: 4px;
@@ -99,7 +102,6 @@
             font-size: 9px;
             line-height: 9px;
             padding: 0 3px;
-            color: #000;
         }
     }
 

inst/www/shared/ionrangeslider/scss/shiny.scss

@@ -19,8 +19,7 @@
 
 ////////////////////////////////////////////////////////////////////////////
 
-// Re-define font-family on .irs to make it configurable
-$font-family: Arial, sans-serif !default;
+$font-family: $font-family-base !default;
 .irs {
   font-family: $font-family;
 }
@@ -36,8 +35,8 @@ $font-family: Arial, sans-serif !default;
   $custom_radius: 3px !default;
 
   // "High-level" coloring
-  $bg:     white !default;
-  $fg:     black !default;
+  $bg:     $body-bg !default;
+  $fg:     color-contrast($body-bg) !default;
   $accent: #428bca !default;
 
   // "Low-level" coloring, borders, and fonts
@@ -52,7 +51,7 @@ $font-family: Arial, sans-serif !default;
   $handle_border:      1px solid mix($bg, $fg, 67%) !default;
   $handle_box_shadow:  1px 1px 3px rgba($bg, 0.3) !default;
 
-  $minmax_text_color:  mix($bg, $fg, 20%) !default;
+  $minmax_text_color:  null !default;
   $minmax_bg_color:    rgba($fg, 0.1) !default;
   $minmax_font_size:   10px !default;
   $minmax_line_height: 1.333 !default;
@@ -64,7 +63,7 @@ $font-family: Arial, sans-serif !default;
 
   $grid_major_color:  $fg !default;
   $grid_minor_color:  mix($bg, $fg, 60%) !default;
-  $grid_text_color:   mix($bg, $fg, 10%) !default;
+  $grid_text_color:   null !default;
 
 
   height: 40px;

inst/www/shared/selectize/scss/selectize.bootstrap4.scss

@@ -13,7 +13,7 @@ $selectize-color-text: $input-color !default;
 $selectize-color-highlight: rgba(255,237,40,0.4) !default;
 $selectize-color-input: $input-bg !default;
 $selectize-color-input-full: $input-bg !default;
-$selectize-color-input-error: theme-color("danger") !default;
+$selectize-color-input-error: $danger !default;
 $selectize-color-input-error-focus: darken($selectize-color-input-error, 10%) !default;
 $selectize-color-disabled: $input-bg !default;
 $selectize-color-item: mix($selectize-color-input, $selectize-color-text, 90%) !default;

inst/www/shared/selectize/scss/selectize.bootstrap5.scss

@@ -0,0 +1,3 @@
+$input-line-height-sm: $form-select-line-height !default;
+@import 'selectize.bootstrap4';
+.selectize-control{padding:0;}

inst/www/shared/shiny-showcase.css

@@ -1,87 +1,2 @@
-#showcase-well {
-  border-radius: 0;
-  -webkit-border-radius: 0;
-  -moz-border-radius: 0;
-}
-
-.shiny-code {
-  background-color: white;
-  margin-bottom: 0;
-}
-
-.shiny-code code {
-  font-family: Menlo, Consolas, "Courier New", monospace;
-}
-
-.shiny-code-container {
-  margin-top: 20px;
-  clear: both;
-}
-
-.shiny-code-container h3 {
-  display: inline;
-  margin-right: 15px;
-}
-
-.showcase-header {
-  font-size: 16px;
-  font-weight: normal;
-}
-
-.showcase-code-link {
-  text-align: right;
-  padding: 15px;
-}
-
-#showcase-app-container {
-  vertical-align: top;
-}
-
-#showcase-code-tabs pre {
-  border: none;
-  line-height: 1em;
-}
-
-#showcase-code-tabs .nav, 
-#showcase-code-tabs ul {
-  margin-bottom: 0px;
-}
-
-#showcase-app-code {
-  width: 100%;
-}
-
-#showcase-code-tabs {
-  margin-right: 15px;
-}
-
-#showcase-code-tabs .tab-content {
-  border-style: solid;
-  border-color: #e5e5e5;
-  border-width: 0px 1px 1px 1px;
-  overflow:auto;
-  -webkit-border-bottom-right-radius: 4px;
-  -webkit-border-bottom-left-radius: 4px;
-  -moz-border-radius-bottomright: 4px;
-  -moz-border-radius-bottomleft: 4px;
-  border-bottom-right-radius: 4px;
-  border-bottom-left-radius: 4px;
-}
-
-#showcase-code-position-toggle {
-  float: right;
-}
-
-#showcase-sxs-code {
-  padding-top: 20px;
-  vertical-align: top;
-}
-
-.showcase-code-license {
-  display: block;
-  text-align: right;
-}
-
-#showcase-code-content pre {
-  background-color: white;
-}
+/*! shiny 1.7.1.9003 | (c) 2012-2022 RStudio, PBC. | License: GPL-3 | file LICENSE */
+#showcase-well{border-radius:0}.shiny-code{background-color:#fff;margin-bottom:0}.shiny-code code{font-family:Menlo,Consolas,"Courier New",monospace}.shiny-code-container{margin-top:20px;clear:both}.shiny-code-container h3{display:inline;margin-right:15px}.showcase-header{font-size:16px;font-weight:normal}.showcase-code-link{text-align:right;padding:15px}#showcase-app-container{vertical-align:top}#showcase-code-tabs{margin-right:15px}#showcase-code-tabs pre{border:none;line-height:1em}#showcase-code-tabs .nav{margin-bottom:0}#showcase-code-tabs ul{margin-bottom:0}#showcase-code-tabs .tab-content{border-style:solid;border-color:#e5e5e5;border-width:0px 1px 1px 1px;overflow:auto;border-bottom-right-radius:4px;border-bottom-left-radius:4px}#showcase-app-code{width:100%}#showcase-code-position-toggle{float:right}#showcase-sxs-code{padding-top:20px;vertical-align:top}.showcase-code-license{display:block;text-align:right}#showcase-code-content pre{background-color:#fff}

inst/www/shared/shiny-testmode.js

@@ -1,8 +1,3 @@
-// Listen for messages from parent frame. This file is only added when the
-// shiny.testmode option is TRUE.
-window.addEventListener("message", function(e) {
-  var message = e.data;
-
-  if (message.code)
-    eval(message.code);
-});
+/*! shiny 1.7.1.9003 | (c) 2012-2022 RStudio, PBC. | License: GPL-3 | file LICENSE */
+(function(){var a=eval;window.addEventListener("message",function(i){var e=i.data;e.code&&a(e.code)});})();
+//# sourceMappingURL=shiny-testmode.js.map

inst/www/shared/shiny-testmode.js.map

@@ -0,0 +1,7 @@
+{
+  "version": 3,
+  "sources": ["../../../srcts/src/utils/eval.ts", "../../../srcts/extras/shiny-testmode.ts"],
+  "sourcesContent": ["//esbuild.github.io/content-types/#direct-eval\n//tl/dr;\n// * Direct usage of `eval(\"x\")` is bad with bundled code.\n// * Instead, use indirect calls to `eval` such as `indirectEval(\"x\")`\n//   * Even just renaming the function works well enough.\n// > This is known as \"indirect eval\" because eval is not being called directly, and so does not trigger the grammatical special case for direct eval in the JavaScript VM. You can call indirect eval using any syntax at all except for an expression of the exact form eval('x'). For example, var eval2 = eval; eval2('x') and [eval][0]('x') and window.eval('x') are all indirect eval calls.\n// > When you use indirect eval, the code is evaluated in the global scope instead of in the inline scope of the caller.\nvar indirectEval = eval;\nexport { indirectEval };", "/* eslint-disable unicorn/filename-case */\nimport { indirectEval } from \"../src/utils/eval\"; // Listen for messages from parent frame. This file is only added when the\n// shiny.testmode option is TRUE.\n\nwindow.addEventListener(\"message\", function (e) {\n  var message = e.data;\n  if (message.code) indirectEval(message.code);\n});"],
+  "mappings": ";YAOA,GAAI,GAAe,KCHnB,OAAO,iBAAiB,UAAW,SAAU,EAAG,CAC9C,GAAI,GAAU,EAAE,KAChB,AAAI,EAAQ,MAAM,EAAa,EAAQ",
+  "names": []
+}

inst/www/shared/shiny_scss/shiny.scss

@@ -295,6 +295,15 @@ pre.shiny-text-output {
   margin-top: 0px;
 }
 
+/* Workaround for radio buttons and checkboxes not showing on Qt on Mac.
+   This occurs in the RStudio IDE on macOS 11.5.
+   https://github.com/rstudio/shiny/issues/3484
+*/
+.qtmac input[type="radio"],
+.qtmac input[type="checkbox"] {
+  zoom: 1.0000001;
+}
+
 /* consistency with bootstrap.css for selectize.js */
 .selectize-control {
   margin-bottom: 10px;

man-roxygen/param-env.R

@@ -0,0 +1,6 @@
+# Also update observeEvent param descriptions!
+# https://github.com/r-lib/roxygen2/issues/1241
+#' @param <%= env %> The parent environment for the reactive expression. By default,
+#'   this is the calling environment, the same as when defining an ordinary
+#'   non-reactive expression. If `<%= x %>` is a quosure and `<%= quoted %>` is `TRUE`,
+#'   then `<%= env %>` is ignored.

man-roxygen/param-quoted.R

@@ -0,0 +1,6 @@
+# Also update observeEvent param descriptions!
+# https://github.com/r-lib/roxygen2/issues/1241
+#' @param <%= quoted %> If it is `TRUE`, then the [`quote()`]ed value of `<%= x %>`
+#'   will be used when `<%= x %>` is evaluated. If `<%= x %>` is a quosure and you
+#'   would like to use its expression as a value for `<%= x %>`, then you must set
+#'  `<%= quoted %>` to `TRUE`.