Firefox compatibility; visual tweaks

.Rbuildignore

@@ -1,23 +1,11 @@
 ^\.Rproj\.user$
 ^\.git$
 ^examples$
+^README\.md$
 ^shiny\.Rproj$
 ^shiny\.sh$
 ^shiny\.cmd$
 ^run\.R$
 ^\.gitignore$
-^smoketests$
 ^res$
-^man-roxygen$
-^\.travis\.yml$
-^staticdocs$
 ^tools$
-^srcjs$
-^CONTRIBUTING.md$
-^cran-comments.md$
-^.*\.o$
-^appveyor\.yml$
-^revdep$
-^TODO-promises.md$
-^manualtests$
-^\.github$

.Rinstignore

@@ -1,2 +0,0 @@
-^tools$
-^Rmd$

.gitattributes

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

.github/CONTRIBUTING.md

@@ -1,40 +0,0 @@
-We welcome contributions to the **shiny** package. To submit a contribution:
-
-1. [Fork](https://github.com/rstudio/shiny/fork) the repository and make your changes.
-
-2. Submit a [pull request](https://help.github.com/articles/using-pull-requests).
-
-3. Ensure that you have signed the contributor license agreement. It will appear as a "Check"
-   on your PR and a comment from "CLAassistant" will also appear explaining whether you have
-   yet to sign. After you sign, you can click the "Recheck" link in that comment and the check
-   will flip to reflect that you've signed.
-
-We generally do not merge pull requests that update included web libraries (such as Bootstrap or jQuery) because it is difficult for us to verify that the update is done correctly; we prefer to update these libraries ourselves.
-
-## How to make changes
-
-Before you submit a pull request, please do the following:
-
-* Add an entry to NEWS.md concisely describing what you changed.
-
-* If appropriate, add unit tests in the tests/ directory.
-
-* If you made any changes to the JavaScript files in the srcjs/ directory, make sure you build the output JavaScript files. See tools/README.md file for information on using the build system.
-
-* Run Build->Check Package in the RStudio IDE, or `devtools::check()`, to make sure your change did not add any messages, warnings, or errors.
-
-Doing these things will make it easier for the Shiny development team to evaluate your pull request. Even so, we may still decide to modify your code or even not merge it at all. Factors that may prevent us from merging the pull request include:
-
-* breaking backward compatibility
-* adding a feature that we do not consider relevant for Shiny
-* is hard to understand
-* is hard to maintain in the future
-* is computationally expensive
-* is not intuitive for people to use
-
-We will try to be responsive and provide feedback in case we decide not to merge your pull request.
-
-
-## Filing issues
-
-If you find a bug in Shiny, you can also [file an issue](https://github.com/rstudio/shiny/issues/new). Please provide as much relevant information as you can, and include a minimal reproducible example if possible.

.github/ISSUE_TEMPLATE/bug_report.md

@@ -1,40 +0,0 @@
----
-name  : Bug report
-about : Report a bug in Shiny.
----
-
-<!--
-This issue tracker is for bugs and feature requests in the Shiny package. If you're having trouble with Shiny Server or a related package, please file an issue in the appropriate repository. 
-
-If you're having trouble with shinyapps.io, and you have a paid account (Starter, Basic, Standard, or Pro), please file a support ticket via https://support.rstudio.com. If you have a Free account, please post to the RStudio Community with the shinyappsio tag: https://community.rstudio.com/tags/shinyappsio.
-
-Finally, if you are an RStudio customer and are having trouble with one of our Pro products, get in touch with our support team at support@rstudio.com.
-
-Before you file an issue, please upgrade to the latest version of Shiny from CRAN and confirm that the problem persists.
-
-# First, restart R.
-# To install latest shiny from CRAN:
-install.packages("shiny")
-
-See our guide to writing good bug reports for further guidance: https://github.com/rstudio/shiny/wiki/Writing-Good-Bug-Reports. The better your report is, the likelier we are to be able to reproduce and ultimately solve it.
--->
-
-### System details
-
-Browser Version: <!-- If applicable -->
-
-Output of `sessionInfo()`:
-
-```
-# sessionInfo() output goes here
-```
-
-### Example application *or* steps to reproduce the problem
-
-<!-- If you're able to create one, a reproducible example is extremely helpful to us. For instructions on how to create one, please see: https://github.com/rstudio/shiny/wiki/Creating-a-Reproducible-Example --> 
-
-```R
-# Minimal, self-contained example app code goes here
-```
-
-### Describe the problem in detail

.github/ISSUE_TEMPLATE/feature_request.md

@@ -1,17 +0,0 @@
----
-name  : Feature request
-about : Request a new feature.
----
-
-<!--
-
-Thanks for taking the time to file a feature request! Please take the time to search for an existing feature request, to avoid creating duplicate requests. If you find an existing feature request, please give it a thumbs-up reaction, as we'll use these reactions to help prioritize the implementation of these features in the future.
-
-If the feature has not yet been filed, then please describe the feature you'd like to see become a part of Shiny. See:
-
-https://github.com/rstudio/shiny/wiki/Writing-Good-Feature-Requests
-
-for a guide on how to write good feature requests.
-
--->
-

.github/ISSUE_TEMPLATE/question.md

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

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

@@ -1,198 +0,0 @@
-name: R-CMD-check
-on:
-  push:
-    branches:
-      - master
-  pull_request:
-    branches:
-      - master
-
-
-jobs:
-
-  R-CMD-check:
-    runs-on: ${{ matrix.config.os }}
-
-    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
-
-    strategy:
-      fail-fast: false
-      matrix:
-        config:
-          - {os: macOS-latest,   r: 'devel'}
-          - {os: macOS-latest,   r: '4.0'}
-          - {os: windows-latest, r: '4.0'}
-          - {os: ubuntu-16.04,   r: '4.0', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.6', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.5', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
-
-    env:
-      _R_CHECK_FORCE_SUGGESTS_: false
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      RSPM: ${{ matrix.config.rspm }}
-      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
-
-    steps:
-      # https://github.com/actions/checkout/issues/135
-      - name: Set git to use LF
-        if: runner.os == 'Windows'
-        run: |
-          git config --system core.autocrlf false
-          git config --system core.eol lf
-
-      - uses: actions/checkout@v2
-
-      - uses: r-lib/actions/setup-r@master
-        with:
-          r-version: ${{ matrix.config.r }}
-
-      - uses: r-lib/actions/setup-pandoc@master
-
-      - name: Query dependencies
-        run: |
-          install.packages('remotes')
-          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
-        shell: Rscript {0}
-
-      - name: Cache R packages
-        if: runner.os != 'Windows'
-        uses: actions/cache@v1
-        with:
-          path: ${{ env.R_LIBS_USER }}
-          key: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-1-${{ hashFiles('.github/depends.Rds') }}
-          restore-keys: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-1-
-
-      - name: Install system dependencies
-        if: runner.os == 'Linux'
-        env:
-          RHUB_PLATFORM: linux-x86_64-ubuntu-gcc
-        run: |
-          Rscript -e "remotes::install_github('r-hub/sysreqs')"
-          sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))")
-          sudo -s eval "$sysreqs"
-
-      - name: Install dependencies
-        run: |
-          remotes::install_deps(dependencies = TRUE)
-          remotes::install_cran("rcmdcheck")
-        shell: Rscript {0}
-
-      - name: Find PhantomJS path
-        id: phantomjs
-        run: |
-          echo "::set-output name=path::$(Rscript -e 'cat(shinytest:::phantom_paths()[[1]])')"
-      - name: Cache PhantomJS
-        uses: actions/cache@v1
-        with:
-          path: ${{ steps.phantomjs.outputs.path }}
-          key: ${{ runner.os }}-phantomjs
-          restore-keys: ${{ runner.os }}-phantomjs
-      - name: Install PhantomJS
-        run: >
-          Rscript
-          -e "if (!shinytest::dependenciesInstalled()) shinytest::installDependencies()"
-
-      - name: Session info
-        run: |
-          options(width = 100)
-          pkgs <- installed.packages()[, "Package"]
-          sessioninfo::session_info(pkgs, include_base = TRUE)
-        shell: Rscript {0}
-
-      - name: Check
-        env:
-          _R_CHECK_CRAN_INCOMING_: false
-        run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check")
-        shell: Rscript {0}
-
-      - name: Show testthat output
-        if: always()
-        run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
-        shell: bash
-
-      - name: Upload check results
-        if: failure()
-        uses: actions/upload-artifact@v2
-        with:
-          name: ${{ runner.os }}-r${{ matrix.config.r }}-results
-          path: check
-
-
-  documentation:
-    runs-on: ${{ matrix.config.os }}
-    name: documentation
-
-    strategy:
-      fail-fast: false
-      matrix:
-        config:
-          - {os: macOS-latest, r: '4.0'}
-
-    env:
-      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
-
-    steps:
-      - uses: actions/checkout@v2
-
-      - uses: r-lib/actions/setup-r@master
-        with:
-          r-version: ${{ matrix.config.r }}
-
-      - name: Query dependencies
-        run: |
-          install.packages('remotes')
-          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
-        shell: Rscript {0}
-      - name: Cache R packages
-        uses: actions/cache@v1
-        with:
-          path: ${{ env.R_LIBS_USER }}
-          key: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-2-${{ hashFiles('.github/depends.Rds') }}
-          restore-keys: ${{ matrix.config.os }}-r-${{ matrix.config.r }}-2-
-      - name: Remove dependencies file
-        run: |
-          rm .github/depends.Rds
-
-      - name: Install dependencies
-        run: |
-          install.packages(c("remotes"))
-          remotes::install_deps(dependencies = TRUE)
-          remotes::install_cran("devtools")
-          remotes::install_cran("rprojroot")
-        shell: Rscript {0}
-
-      - name: Check documentation
-        run: |
-          ./tools/documentation/checkDocsCurrent.sh
-
-
-  node_js:
-    runs-on: macOS-latest
-    name: node_js
-
-    steps:
-      - uses: actions/checkout@v2
-
-      - uses: actions/setup-node@v1
-        with:
-          node-version: '12.x'
-
-      # https://github.com/actions/cache/blame/ccf96194800dbb7b7094edcd5a7cf3ec3c270f10/examples.md#L185-L200
-      - name: Get yarn cache directory path
-        id: yarn-cache-dir-path
-        run: echo "::set-output name=dir::$(yarn cache dir)"
-      - name: yarn cache
-        uses: actions/cache@v1
-        id: yarn-cache # use this to check for `cache-hit` (`steps.yarn-cache.outputs.cache-hit != 'true'`)
-        with:
-          path: ${{ steps.yarn-cache-dir-path.outputs.dir }}
-          key: ${{ runner.os }}-yarn-${{ hashFiles('**/yarn.lock') }}
-          restore-keys: |
-            ${{ runner.os }}-yarn-
-
-      - name: Check node build
-        run: |
-          ./tools/checkJSCurrent.sh

.github/workflows/pr-commands.yaml

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

.gitignore

@@ -6,7 +6,4 @@
 *.so
 /src-i386/
 /src-x86_64/
-shinyapps/
 README.html
-.*.Rnb.cached
-tools/yarn-error.log

DESCRIPTION

@@ -1,203 +1,51 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.5.0.9004
-Authors@R: c(
-    person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
-    person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
-    person("JJ", "Allaire", role = "aut", email = "jj@rstudio.com"),
-    person("Carson", "Sievert", role = "aut", email = "carson@rstudio.com"),
-    person("Barret", "Schloerke", role = "aut", email = "barret@rstudio.com"),
-    person("Yihui", "Xie", role = "aut", email = "yihui@rstudio.com"),
-    person("Jeff", "Allen", role = "aut", email = "jeff@rstudio.com"),
-    person("Jonathan", "McPherson", role = "aut", email = "jonathan@rstudio.com"),
-    person("Alan", "Dipert", role = "aut"),
-    person("Barbara", "Borges", role = "aut"),
-    person(family = "RStudio", role = "cph"),
-    person(family = "jQuery Foundation", role = "cph",
-    comment = "jQuery library and jQuery UI library"),
-    person(family = "jQuery contributors", role = c("ctb", "cph"),
-    comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
-    person(family = "jQuery UI contributors", role = c("ctb", "cph"),
-    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
-    person("Mark", "Otto", role = "ctb",
-    comment = "Bootstrap library"),
-    person("Jacob", "Thornton", role = "ctb",
-    comment = "Bootstrap library"),
-    person(family = "Bootstrap contributors", role = "ctb",
-    comment = "Bootstrap library"),
-    person(family = "Twitter, Inc", role = "cph",
-    comment = "Bootstrap library"),
-    person("Prem Nawaz", "Khan", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
-    person("Victor", "Tsaran", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
-    person("Dennis", "Lembree", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
-    person("Srinivasu", "Chakravarthula", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
-    person("Cathy", "O'Connor", role = "ctb",
-    comment = "Bootstrap accessibility plugin"),
-    person(family = "PayPal, Inc", role = "cph",
-    comment = "Bootstrap accessibility plugin"),
-    person("Stefan", "Petre", role = c("ctb", "cph"),
-    comment = "Bootstrap-datepicker library"),
-    person("Andrew", "Rowls", role = c("ctb", "cph"),
-    comment = "Bootstrap-datepicker library"),
-    person("Dave", "Gandy", role = c("ctb", "cph"),
-    comment = "Font-Awesome font"),
-    person("Brian", "Reavis", role = c("ctb", "cph"),
-    comment = "selectize.js library"),
-    person("Salmen", "Bejaoui", role = c("ctb", "cph"),
-    comment = "selectize-plugin-a11y library"),
-    person("Denis", "Ineshin", role = c("ctb", "cph"),
-    comment = "ion.rangeSlider library"),
-    person("Sami", "Samhuri", role = c("ctb", "cph"),
-    comment = "Javascript strftime library"),
-    person(family = "SpryMedia Limited", role = c("ctb", "cph"),
-    comment = "DataTables library"),
-    person("John", "Fraser", role = c("ctb", "cph"),
-    comment = "showdown.js library"),
-    person("John", "Gruber", role = c("ctb", "cph"),
-    comment = "showdown.js library"),
-    person("Ivan", "Sagalaev", role = c("ctb", "cph"),
-    comment = "highlight.js library"),
-    person(family = "R Core Team", role = c("ctb", "cph"),
-    comment = "tar implementation from R")
-    )
-Description: Makes it incredibly easy to build interactive web
+Version: 0.6.0.99
+Date: 2013-01-23
+Author: RStudio, Inc.
+Maintainer: Winston Chang <winston@rstudio.com>
+Description: Shiny makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
-    outputs and extensive prebuilt widgets make it possible to build
+    outputs and extensive pre-built widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
-License: GPL-3 | file LICENSE
+License: GPL-3
 Depends:
-    R (>= 3.0.2),
-    methods
+    R (>= 2.14.1)
 Imports:
-    utils,
-    grDevices,
-    httpuv (>= 1.5.2),
-    mime (>= 0.3),
-    jsonlite (>= 0.9.16),
-    xtable,
-    digest,
-    htmltools (>= 0.5.0.9001),
-    R6 (>= 2.0),
-    sourcetools,
-    later (>= 1.0.0),
-    promises (>= 1.1.0),
+    stats,
     tools,
-    crayon,
-    rlang (>= 0.4.0),
-    fastmap (>= 1.0.0),
-    withr,
-    commonmark (>= 1.7),
-    glue (>= 1.3.2),
-    bootstraplib (>= 0.2.0.9001)
-Suggests:
+    utils,
     datasets,
-    Cairo (>= 1.5-5),
-    testthat (>= 2.1.1),
-    knitr (>= 1.6),
+    methods,
+    httpuv (>= 1.0.6.2),
+    caTools,
+    RJSONIO,
+    xtable,
+    digest
+Suggests:
     markdown,
-    rmarkdown,
-    ggplot2,
-    reactlog (>= 1.0.0),
-    magrittr,
-    shinytest,
-    yaml,
-    future,
-    dygraphs,
-    ragg,
-    showtext,
-    sass
-Remotes:
-    rstudio/htmltools,
-    rstudio/sass,
-    rstudio/bootstraplib
-URL: http://shiny.rstudio.com
+    Cairo,
+    testthat
+URL: http://www.rstudio.com/shiny/
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
-    'globals.R'
-    'app-state.R'
-    'app_template.R'
-    'bookmark-state-local.R'
-    'stack.R'
-    'bookmark-state.R'
-    'bootstrap-deprecated.R'
-    'bootstrap-layout.R'
-    'conditions.R'
     'map.R'
-    'utils.R'
-    'bootstrap.R'
-    'cache-disk.R'
-    'cache-memory.R'
-    'cache-utils.R'
-    'diagnose.R'
-    'fileupload.R'
-    'font-awesome.R'
-    'graph.R'
-    'reactives.R'
-    'reactive-domains.R'
-    'history.R'
-    'hooks.R'
-    'html-deps.R'
-    'htmltools.R'
-    'image-interact-opts.R'
-    'image-interact.R'
-    'imageutils.R'
-    'input-action.R'
-    'input-checkbox.R'
-    'input-checkboxgroup.R'
-    'input-date.R'
-    'input-daterange.R'
-    'input-file.R'
-    'input-numeric.R'
-    'input-password.R'
-    'input-radiobuttons.R'
-    'input-select.R'
-    'input-slider.R'
-    'input-submit.R'
-    'input-text.R'
-    'input-textarea.R'
-    'input-utils.R'
-    'insert-tab.R'
-    'insert-ui.R'
-    'jqueryui.R'
-    'knitr.R'
-    'middleware-shiny.R'
-    'middleware.R'
-    'timer.R'
-    'shiny.R'
-    'mock-session.R'
-    'modal.R'
-    'modules.R'
-    'notifications.R'
     'priorityqueue.R'
-    'progress.R'
-    'react.R'
-    'reexports.R'
-    'render-cached-plot.R'
-    'render-plot.R'
-    'render-table.R'
-    'run-url.R'
-    'runapp.R'
-    'serializers.R'
-    'server-input-handlers.R'
-    'server-resource-paths.R'
-    'server.R'
-    'shiny-options.R'
-    'shinyapp.R'
-    'shinyui.R'
-    'shinywrappers.R'
-    'showcase.R'
-    'snapshot.R'
+    'utils.R'
     'tar.R'
-    'test-export.R'
-    'test-server.R'
-    'test.R'
+    'timer.R'
+    'tags.R'
+    'cache.R'
+    'graph.R'
+    'react.R'
+    'reactives.R'
+    'fileupload.R'
+    'shiny.R'
+    'shinywrappers.R'
+    'shinyui.R'
+    'slider.R'
+    'bootstrap.R'
+    'run-url.R'
+    'imageutils.R'
     'update-input.R'
-    'viewer.R'
-RoxygenNote: 7.1.1
-Encoding: UTF-8
-Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -1,109 +1,45 @@
-# Generated by roxygen2: do not edit by hand
-
-S3method("$",mockclientdata)
 S3method("$",reactivevalues)
-S3method("$",session_proxy)
 S3method("$",shinyoutput)
 S3method("$<-",reactivevalues)
-S3method("$<-",session_proxy)
 S3method("$<-",shinyoutput)
-S3method("[",mockclientdata)
 S3method("[",reactivevalues)
 S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
 S3method("[<-",shinyoutput)
-S3method("[[",mockclientdata)
 S3method("[[",reactivevalues)
-S3method("[[",session_proxy)
 S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
 S3method("[[<-",shinyoutput)
 S3method("names<-",reactivevalues)
+S3method(as.character,shiny.tag)
+S3method(as.character,shiny.tag.list)
 S3method(as.list,reactivevalues)
-S3method(as.shiny.appobj,character)
-S3method(as.shiny.appobj,list)
-S3method(as.shiny.appobj,shiny.appobj)
-S3method(as.tags,shiny.appobj)
-S3method(as.tags,shiny.render.function)
-S3method(format,reactiveExpr)
-S3method(format,reactiveVal)
+S3method(format,shiny.tag)
+S3method(format,shiny.tag.list)
 S3method(names,reactivevalues)
-S3method(print,reactive)
-S3method(print,reactivevalues)
-S3method(print,shiny.appobj)
-S3method(print,shiny.render.function)
-S3method(print,shiny_runtests)
-S3method(str,reactivevalues)
-export("conditionStackTrace<-")
-export(..stacktraceoff..)
-export(..stacktraceon..)
+S3method(print,shiny.tag)
+S3method(print,shiny.tag.list)
 export(HTML)
-export(MockShinySession)
-export(NS)
-export(Progress)
 export(a)
-export(absolutePanel)
 export(actionButton)
-export(actionLink)
 export(addResourcePath)
 export(animationOptions)
-export(appendTab)
-export(as.shiny.appobj)
 export(basicPage)
-export(bookmarkButton)
-export(bootstrapLib)
 export(bootstrapPage)
 export(br)
-export(browserViewer)
-export(brushOpts)
-export(brushedPoints)
-export(callModule)
-export(captureStackTraces)
 export(checkboxGroupInput)
 export(checkboxInput)
-export(clickOpts)
 export(code)
-export(column)
-export(conditionStackTrace)
 export(conditionalPanel)
-export(createRenderFunction)
-export(createWebDependency)
-export(dataTableOutput)
 export(dateInput)
 export(dateRangeInput)
-export(dblclickOpts)
-export(debounce)
-export(dialogViewer)
-export(diskCache)
 export(div)
 export(downloadButton)
 export(downloadHandler)
 export(downloadLink)
 export(em)
-export(enableBookmarking)
-export(eventReactive)
-export(exportTestValues)
 export(exprToFunction)
-export(extractStackTrace)
 export(fileInput)
-export(fillCol)
-export(fillPage)
-export(fillRow)
-export(fixedPage)
-export(fixedPanel)
-export(fixedRow)
-export(flowLayout)
-export(fluidPage)
-export(fluidRow)
-export(formatStackTrace)
-export(freezeReactiveVal)
-export(freezeReactiveValue)
-export(getCurrentOutputInfo)
-export(getCurrentTheme)
-export(getDefaultReactiveDomain)
-export(getQueryString)
-export(getShinyOption)
-export(getUrlHash)
 export(h1)
 export(h2)
 export(h3)
@@ -112,102 +48,36 @@ export(h5)
 export(h6)
 export(headerPanel)
 export(helpText)
-export(hideTab)
-export(hoverOpts)
-export(hr)
 export(htmlOutput)
-export(htmlTemplate)
-export(httpResponse)
-export(icon)
 export(imageOutput)
 export(img)
-export(incProgress)
 export(includeCSS)
 export(includeHTML)
 export(includeMarkdown)
 export(includeScript)
 export(includeText)
-export(inputPanel)
-export(insertTab)
-export(insertUI)
-export(installExprFunction)
 export(invalidateLater)
-export(is.key_missing)
-export(is.reactive)
-export(is.reactivevalues)
-export(is.shiny.appobj)
-export(is.singleton)
-export(isRunning)
-export(isTruthy)
 export(isolate)
-export(key_missing)
-export(loadSupport)
 export(mainPanel)
-export(makeReactiveBinding)
-export(markRenderFunction)
-export(markdown)
-export(maskReactiveContext)
-export(memoryCache)
-export(modalButton)
-export(modalDialog)
-export(moduleServer)
-export(navbarMenu)
-export(navbarPage)
-export(navlistPanel)
-export(nearPoints)
-export(need)
-export(ns.sep)
 export(numericInput)
 export(observe)
-export(observeEvent)
-export(onBookmark)
-export(onBookmarked)
-export(onFlush)
-export(onFlushed)
-export(onReactiveDomainEnded)
-export(onRestore)
-export(onRestored)
-export(onSessionEnded)
-export(onStop)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
-export(paneViewer)
 export(parseQueryString)
-export(passwordInput)
 export(plotOutput)
 export(plotPNG)
 export(pre)
-export(prependTab)
-export(printError)
-export(printStackTrace)
 export(radioButtons)
 export(reactive)
-export(reactiveConsole)
-export(reactiveFileReader)
 export(reactivePlot)
-export(reactivePoll)
 export(reactivePrint)
 export(reactiveTable)
 export(reactiveText)
 export(reactiveTimer)
 export(reactiveUI)
-export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
-export(reactlog)
-export(reactlogReset)
-export(reactlogShow)
-export(registerInputHandler)
-export(registerThemeDependency)
-export(removeInputHandler)
-export(removeModal)
-export(removeNotification)
-export(removeResourcePath)
-export(removeTab)
-export(removeUI)
-export(renderCachedPlot)
-export(renderDataTable)
 export(renderImage)
 export(renderPlot)
 export(renderPrint)
@@ -215,150 +85,51 @@ export(renderTable)
 export(renderText)
 export(renderUI)
 export(repeatable)
-export(req)
-export(resourcePaths)
-export(restoreInput)
 export(runApp)
 export(runExample)
-export(runGadget)
 export(runGist)
 export(runGitHub)
-export(runTests)
 export(runUrl)
-export(safeError)
 export(selectInput)
-export(selectizeInput)
-export(serverInfo)
-export(setBookmarkExclude)
-export(setProgress)
-export(setSerializer)
-export(shinyApp)
-export(shinyAppDir)
-export(shinyAppFile)
-export(shinyAppTemplate)
-export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
-export(showBookmarkUrlModal)
-export(showModal)
-export(showNotification)
 export(showReactLog)
-export(showTab)
-export(sidebarLayout)
 export(sidebarPanel)
 export(singleton)
-export(sizeGrowthRatio)
 export(sliderInput)
-export(snapshotExclude)
-export(snapshotPreprocessInput)
-export(snapshotPreprocessOutput)
 export(span)
-export(splitLayout)
 export(stopApp)
 export(strong)
 export(submitButton)
-export(suppressDependencies)
 export(tabPanel)
-export(tabPanelBody)
 export(tableOutput)
 export(tabsetPanel)
 export(tag)
-export(tagAppendAttributes)
 export(tagAppendChild)
 export(tagAppendChildren)
-export(tagGetAttribute)
-export(tagHasAttribute)
 export(tagList)
 export(tagSetChildren)
 export(tags)
-export(testServer)
-export(textAreaInput)
 export(textInput)
 export(textOutput)
-export(throttle)
-export(titlePanel)
 export(uiOutput)
-export(updateActionButton)
-export(updateActionLink)
 export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
 export(updateDateRangeInput)
-export(updateNavbarPage)
-export(updateNavlistPanel)
 export(updateNumericInput)
-export(updateQueryString)
 export(updateRadioButtons)
 export(updateSelectInput)
-export(updateSelectizeInput)
 export(updateSliderInput)
 export(updateTabsetPanel)
-export(updateTextAreaInput)
 export(updateTextInput)
-export(updateVarSelectInput)
-export(updateVarSelectizeInput)
-export(urlModal)
-export(validate)
 export(validateCssUnit)
-export(varSelectInput)
-export(varSelectizeInput)
 export(verbatimTextOutput)
-export(verticalLayout)
 export(wellPanel)
-export(withLogErrors)
-export(withMathJax)
-export(withProgress)
-export(withReactiveDomain)
 export(withTags)
-import(R6)
+export(writeReactLog)
+import(RJSONIO)
+import(caTools)
 import(digest)
-import(htmltools)
 import(httpuv)
-import(methods)
-import(mime)
 import(xtable)
-importFrom(fastmap,fastmap)
-importFrom(fastmap,is.key_missing)
-importFrom(fastmap,key_missing)
-importFrom(grDevices,dev.cur)
-importFrom(grDevices,dev.set)
-importFrom(htmltools,HTML)
-importFrom(htmltools,a)
-importFrom(htmltools,br)
-importFrom(htmltools,code)
-importFrom(htmltools,div)
-importFrom(htmltools,em)
-importFrom(htmltools,h1)
-importFrom(htmltools,h2)
-importFrom(htmltools,h3)
-importFrom(htmltools,h4)
-importFrom(htmltools,h5)
-importFrom(htmltools,h6)
-importFrom(htmltools,hr)
-importFrom(htmltools,htmlTemplate)
-importFrom(htmltools,img)
-importFrom(htmltools,includeCSS)
-importFrom(htmltools,includeHTML)
-importFrom(htmltools,includeMarkdown)
-importFrom(htmltools,includeScript)
-importFrom(htmltools,includeText)
-importFrom(htmltools,is.singleton)
-importFrom(htmltools,p)
-importFrom(htmltools,pre)
-importFrom(htmltools,singleton)
-importFrom(htmltools,span)
-importFrom(htmltools,strong)
-importFrom(htmltools,suppressDependencies)
-importFrom(htmltools,tag)
-importFrom(htmltools,tagAppendAttributes)
-importFrom(htmltools,tagAppendChild)
-importFrom(htmltools,tagAppendChildren)
-importFrom(htmltools,tagGetAttribute)
-importFrom(htmltools,tagHasAttribute)
-importFrom(htmltools,tagList)
-importFrom(htmltools,tagSetChildren)
-importFrom(htmltools,tags)
-importFrom(htmltools,validateCssUnit)
-importFrom(htmltools,withTags)
-importFrom(promises,"%...!%")
-importFrom(promises,"%...>%")

NEWS

@@ -0,0 +1,298 @@
+shiny 0.6.0.99
+--------------------------------------------------------------------------------
+
+
+shiny 0.6.0
+--------------------------------------------------------------------------------
+
+* `tabsetPanel()` can be directed to start with a specific tab selected.
+
+* Fix bug where multiple file uploads with 3 or more files result in incorrect
+  data.
+
+* Add `withTags()` function.
+
+* Add dateInput and dateRangeInput.
+
+* `shinyServer()` now takes an optional `session` argument, which is used for
+  communication with the session object.
+
+* Add functions to update values of existing inputs on a page, instead of
+  replacing them entirely.
+
+* Allow listening on domain sockets.
+
+* Added `actionButton()` to Shiny.
+
+* The server can now send custom JSON messages to the client. On the client
+  side, functions can be registered to handle these messages.
+
+* Callbacks can be registered to be called at the end of a client session.
+
+* Add ability to set priority of observers and outputs. Each priority level
+  gets its own queue.
+
+* Fix bug where the presence of a submit button would prevent sending of
+  metadata until the button was clicked.
+
+* `reactiveTimer()` and `invalidateLater()` by default no longer invalidate
+  reactive objects after the client session has closed.
+
+* Shiny apps can be run without a server.r and ui.r file.
+
+shiny 0.5.0
+--------------------------------------------------------------------------------
+
+* Switch from websockets package for handling websocket connections to httpuv.
+
+* New method for detecting hidden output objects. Instead of checking that
+  height and width are 0, it checks that the object or any ancestor in the DOM
+  has style display:none.
+
+* Add `clientData` reactive values object, which carries information about the
+  client. This includes the hidden status of output objects, height/width plot
+  output objects, and the URL of the browser.
+
+* Add `parseQueryString()` function.
+
+* Add `renderImage()` function for sending arbitrary image files to the client,
+  and its counterpart, `imageOutput()`.
+
+* Add support for high-resolution (Retina) displays.
+
+* Fix bug #55, where `renderTable()` would throw error with an empty data frame.
+
+shiny 0.4.1
+--------------------------------------------------------------------------------
+
+* Fix bug where width and height weren't passed along properly from
+  `reactivePlot` to `renderPlot`.
+
+* Fix bug where infinite recursion would happen when `reactivePlot` was passed
+  a function for width or height.
+
+shiny 0.4.0
+--------------------------------------------------------------------------------
+
+* Added suspend/resume capability to observers.
+
+* Output objects are automatically suspended when they are hidden on the user's
+  web browser.
+
+* `runGist()` accepts GitHub's new URL format, which includes the username.
+
+* `reactive()` and `observe()` now take expressions instead of functions.
+
+* `reactiveText()`, `reactivePlot()`, and so on, have been renamed to
+  `renderText()`, `renderPlot()`, etc.  They also now take expressions instead
+  of functions.
+
+* Fixed a bug where empty values in a numericInput were sent to the R process
+  as 0. They are now sent as NA.
+
+shiny 0.3.1
+--------------------------------------------------------------------------------
+
+* Fix issue #91: bug where downloading files did not work.
+
+* Add [[<- operator for shinyoutput object, making it possible to assign values
+  with `output[['plot1']] <- ...`.
+
+* Reactive functions now preserve the visible/invisible state of their returned
+  values.
+
+shiny 0.3.0
+--------------------------------------------------------------------------------
+
+* Reactive functions are now evaluated lazily.
+
+* Add `reactiveValues()`.
+
+* Using `as.list()` to convert a reactivevalues object (like `input`) to a list
+  is deprecated. The new function `reactiveValuesToList()` should be used
+  instead.
+
+* Add `isolate()`. This function is used for accessing reactive functions,
+  without them invalidating their parent contexts.
+
+* Fix issue #58: bug where reactive functions are not re-run when all items in
+  a checkboxGroup are unchecked.
+
+* Fix issue #71, where `reactiveTable()` would return blank if the first
+  element of a data frame was NA.
+
+* In `plotOutput`, better validation for CSS units when specifying width and
+  height.
+
+* `reactivePrint()` no longer displays invisible output.
+
+* `reactiveText()` no longer displays printed output, only the return value
+  from a function.
+
+* The `runGitHub()` and `runUrl()` functions have been added, for running
+  Shiny apps from GitHub repositories and zip/tar files at remote URLs.
+
+* Fix issue #64, where pressing Enter in a textbox would cause a form to
+  submit.
+
+shiny 0.2.4
+--------------------------------------------------------------------------------
+
+* `runGist` has been updated to use the new download URLs from
+  https://gist.github.com.
+
+* Shiny now uses `CairoPNG()` for output, when the Cairo package is available.
+  This provides better-looking output on Linux and Windows.
+
+shiny 0.2.3
+--------------------------------------------------------------------------------
+
+* Ignore request variables for routing purposes
+
+shiny 0.2.2
+--------------------------------------------------------------------------------
+
+* Fix CRAN warning (assigning to global environment)
+
+
+shiny 0.2.1
+--------------------------------------------------------------------------------
+
+* [BREAKING] Modify API of `downloadHandler`: The `content` function now takes
+  a file path, not writable connection, as an argument. This makes it much
+  easier to work with APIs that only write to file paths, not connections.
+
+
+shiny 0.2.0
+--------------------------------------------------------------------------------
+
+* Fix subtle name resolution bug--the usual symptom being S4 methods not being
+  invoked correctly when called from inside of ui.R or server.R
+
+
+shiny 0.1.14
+--------------------------------------------------------------------------------
+
+* Fix slider animator, which broke in 0.1.10
+
+
+shiny 0.1.13
+--------------------------------------------------------------------------------
+
+* Fix temp file leak in reactivePlot
+
+
+shiny 0.1.12
+--------------------------------------------------------------------------------
+
+* Fix problems with runGist on Windows
+* Add feature for on-the-fly file downloads (e.g. CSV data, PDFs)
+* Add CSS hooks for app-wide busy indicators
+
+
+shiny 0.1.11
+--------------------------------------------------------------------------------
+
+* Fix input binding with IE8 on Shiny Server
+* Fix issue #41: reactiveTable should allow print options too
+* Allow dynamic sizing of reactivePlot (i.e. using a function instead of a fixed
+  value)
+
+
+shiny 0.1.10
+--------------------------------------------------------------------------------
+
+* Support more MIME types when serving out of www
+* Fix issue #35: Allow modification of untar args
+* headerPanel can take an explicit window title parameter
+* checkboxInput uses correct attribute `checked` instead of `selected`
+* Fix plot rendering with IE8 on Shiny Server
+
+
+shiny 0.1.9
+--------------------------------------------------------------------------------
+
+* Much less flicker when updating plots
+* More customizable error display
+* Add `includeText`, `includeHTML`, and `includeMarkdown` functions for putting
+  text, HTML, and Markdown content from external files in the application's UI.
+
+
+shiny 0.1.8
+--------------------------------------------------------------------------------
+
+* Add `runGist` function for conveniently running a Shiny app that is published
+  on gist.github.com.
+* Fix issue #27: Warnings cause reactive functions to stop executing.
+* The server.R and ui.R filenames are now case insensitive.
+* Add `wellPanel` function for creating inset areas on the page.
+* Add `bootstrapPage` function for creating new Twitter Bootstrap based
+  layouts from scratch.
+
+
+shiny 0.1.7
+--------------------------------------------------------------------------------
+
+* Fix issue #26: Shiny.OutputBindings not correctly exported.
+* Add `repeatable` function for making easily repeatable versions of random
+  number generating functions.
+* Transcode JSON into UTF-8 (prevents non-ASCII reactivePrint values from
+  causing errors on Windows).
+
+
+shiny 0.1.6
+--------------------------------------------------------------------------------
+
+* Import package dependencies, instead of attaching them (with the exception of
+  websockets, which doesn't currently work unless attached).
+* conditionalPanel was animated, now it is not.
+* bindAll was not correctly sending initial values to the server; fixed.
+
+
+shiny 0.1.5
+--------------------------------------------------------------------------------
+
+* BREAKING CHANGE: JS APIs Shiny.bindInput and Shiny.bindOutput removed and
+  replaced with Shiny.bindAll; Shiny.unbindInput and Shiny.unbindOutput removed
+  and replaced with Shiny.unbindAll.
+* Add file upload support (currently only works with Chrome and Firefox). Use
+  a normal HTML file input, or call the `fileInput` UI function.
+* Shiny.unbindOutputs did not work, now it does.
+* Generally improved robustness of dynamic input/output bindings.
+* Add conditionalPanel UI function to allow showing/hiding UI based on a JS
+  expression; for example, whether an input is a particular value. Also works in
+  raw HTML (add the `data-display-if` attribute to the element that should be
+  shown/hidden).
+* htmlOutput (CSS class `shiny-html-output`) can contain inputs and outputs.
+
+
+shiny 0.1.4
+--------------------------------------------------------------------------------
+
+* Allow Bootstrap tabsets to act as reactive inputs; their value indicates which
+  tab is active
+* Upgrade to Bootstrap 2.1
+* Add `checkboxGroupInput` control, which presents a list of checkboxes and
+  returns a vector of the selected values
+* Add `addResourcePath`, intended for reusable component authors to access CSS,
+  JavaScript, image files, etc. from their package directories
+* Add Shiny.bindInputs(scope), .unbindInputs(scope), .bindOutputs(scope), and
+  .unbindOutputs(scope) JS API calls to allow dynamic binding/unbinding of HTML
+  elements
+
+
+shiny 0.1.3
+--------------------------------------------------------------------------------
+
+* Introduce Shiny.inputBindings.register JS API and InputBinding class, for
+  creating custom input controls
+* Add `step` parameter to numericInput
+* Read names of input using `names(input)`
+* Access snapshot of input as a list using `as.list(input)` 
+* Fix issue #10: Plots in tabsets not rendered
+
+
+shiny 0.1.2
+--------------------------------------------------------------------------------
+
+Initial private beta release!

R/app-state.R

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

R/app_template.R

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

R/bookmark-state-local.R

@@ -1,28 +0,0 @@
-# Function wrappers for saving and restoring state to/from disk when running
-# Shiny locally.
-#
-# These functions provide a directory to the callback function.
-#
-# @param id A session ID to save.
-# @param callback A callback function that saves state to or restores state from
-#   a directory. It must take one argument, \code{stateDir}, which is a
-#   directory to which it writes/reads.
-
-saveInterfaceLocal <- function(id, callback) {
-  # Try to save in app directory
-  appDir <- getShinyOption("appDir", default = getwd())
-
-  stateDir <- file.path(appDir, "shiny_bookmarks", id)
-  if (!dirExists(stateDir))
-    dir.create(stateDir, recursive = TRUE)
-
-  callback(stateDir)
-}
-
-loadInterfaceLocal <- function(id, callback) {
-  # Try to load from app directory
-  appDir <- getShinyOption("appDir", default = getwd())
-
-  stateDir <- file.path(appDir, "shiny_bookmarks", id)
-  callback(stateDir)
-}

R/bootstrap-deprecated.R

@@ -1,47 +0,0 @@
-#' Create a page with a sidebar
-#'
-#' **DEPRECATED**: use [fluidPage()] and [sidebarLayout()] instead.
-#'
-#' @param headerPanel The [headerPanel] with the application title
-#' @param sidebarPanel The [sidebarPanel] containing input controls
-#' @param mainPanel The [mainPanel] containing outputs
-#' @keywords internal
-#' @return A UI defintion that can be passed to the [shinyUI] function
-#' @export
-pageWithSidebar <- function(headerPanel,
-                            sidebarPanel,
-                            mainPanel) {
-
-  bootstrapPage(
-    # basic application container divs
-    div(
-      class="container-fluid",
-      div(class="row",
-          headerPanel
-      ),
-      div(class="row",
-          sidebarPanel,
-          mainPanel
-      )
-    )
-  )
-}
-
-#' Create a header panel
-#'
-#' **DEPRECATED**: use [titlePanel()] instead.
-#'
-#' @param title An application title to display
-#' @param windowTitle The title that should be displayed by the browser window.
-#'   Useful if `title` is not a string.
-#' @return A headerPanel that can be passed to [pageWithSidebar]
-#' @keywords internal
-#' @export
-headerPanel <- function(title, windowTitle=title) {
-  tagList(
-    tags$head(tags$title(windowTitle)),
-    div(class="col-sm-12",
-      h1(title)
-    )
-  )
-}

R/bootstrap-layout.R

@@ -1,737 +0,0 @@
-
-#' Create a page with fluid layout
-#'
-#' Functions for creating fluid page layouts. A fluid page layout consists of
-#' rows which in turn include columns. Rows exist for the purpose of making sure
-#' their elements appear on the same line (if the browser has adequate width).
-#' Columns exist for the purpose of defining how much horizontal space within a
-#' 12-unit wide grid it's elements should occupy. Fluid pages scale their
-#' components in realtime to fill all available browser width.
-#'
-#' @param ... Elements to include within the page
-#' @param title The browser window title (defaults to the host URL of the page).
-#'   Can also be set as a side effect of the [titlePanel()] function.
-#' @param responsive This option is deprecated; it is no longer optional with
-#'   Bootstrap 3.
-#' @param theme Alternative Bootstrap stylesheet (normally a css file within the
-#'   www directory). For example, to use the theme located at
-#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
-#' @inheritParams bootstrapPage
-#'
-#' @return A UI defintion that can be passed to the [shinyUI] function.
-#'
-#' @details To create a fluid page use the `fluidPage` function and include
-#'   instances of `fluidRow` and [column()] within it. As an
-#'   alternative to low-level row and column functions you can also use
-#'   higher-level layout functions like [sidebarLayout()].
-#'
-#' @note See the [
-#'   Shiny-Application-Layout-Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fluid
-#'   pages.
-#'
-#' @family layout functions
-#' @seealso [column()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' # Example of UI with fluidPage
-#' ui <- fluidPage(
-#'
-#'   # Application title
-#'   titlePanel("Hello Shiny!"),
-#'
-#'   sidebarLayout(
-#'
-#'     # Sidebar with a slider input
-#'     sidebarPanel(
-#'       sliderInput("obs",
-#'                   "Number of observations:",
-#'                   min = 0,
-#'                   max = 1000,
-#'                   value = 500)
-#'     ),
-#'
-#'     # Show a plot of the generated distribution
-#'     mainPanel(
-#'       plotOutput("distPlot")
-#'     )
-#'   )
-#' )
-#'
-#' # Server logic
-#' server <- function(input, output) {
-#'   output$distPlot <- renderPlot({
-#'     hist(rnorm(input$obs))
-#'   })
-#' }
-#'
-#' # Complete app with UI and server components
-#' shinyApp(ui, server)
-#'
-#'
-#' # UI demonstrating column layouts
-#' ui <- fluidPage(
-#'   title = "Hello Shiny!",
-#'   fluidRow(
-#'     column(width = 4,
-#'       "4"
-#'     ),
-#'     column(width = 3, offset = 2,
-#'       "3 offset 2"
-#'     )
-#'   )
-#' )
-#'
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#' @rdname fluidPage
-#' @export
-fluidPage <- function(..., title = NULL, responsive = NULL, theme = NULL, lang = NULL) {
-  bootstrapPage(div(class = "container-fluid", ...),
-                title = title,
-                responsive = responsive,
-                theme = theme,
-                lang = lang)
-}
-
-
-#' @rdname fluidPage
-#' @export
-fluidRow <- function(...) {
-  div(class = "row", ...)
-}
-
-#' Create a page with a fixed layout
-#'
-#' Functions for creating fixed page layouts. A fixed page layout consists of
-#' rows which in turn include columns. Rows exist for the purpose of making sure
-#' their elements appear on the same line (if the browser has adequate width).
-#' Columns exist for the purpose of defining how much horizontal space within a
-#' 12-unit wide grid it's elements should occupy. Fixed pages limit their width
-#' to 940 pixels on a typical display, and 724px or 1170px on smaller and larger
-#' displays respectively.
-#'
-#' @param ... Elements to include within the container
-#' @param title The browser window title (defaults to the host URL of the page)
-#' @param responsive This option is deprecated; it is no longer optional with
-#'   Bootstrap 3.
-#' @param theme Alternative Bootstrap stylesheet (normally a css file within the
-#'   www directory). For example, to use the theme located at
-#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
-#' @inheritParams bootstrapPage
-#'
-#' @return A UI defintion that can be passed to the [shinyUI] function.
-#'
-#' @details To create a fixed page use the `fixedPage` function and include
-#'   instances of `fixedRow` and [column()] within it. Note that
-#'   unlike [fluidPage()], fixed pages cannot make use of higher-level
-#'   layout functions like `sidebarLayout`, rather, all layout must be done
-#'   with `fixedRow` and `column`.
-#'
-#' @note See the [
-#'   Shiny Application Layout Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fixed
-#'   pages.
-#'
-#' @family layout functions
-#'
-#' @seealso [column()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fixedPage(
-#'   title = "Hello, Shiny!",
-#'   fixedRow(
-#'     column(width = 4,
-#'       "4"
-#'     ),
-#'     column(width = 3, offset = 2,
-#'       "3 offset 2"
-#'     )
-#'   )
-#' )
-#'
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#'
-#' @rdname fixedPage
-#' @export
-fixedPage <- function(..., title = NULL, responsive = NULL, theme = NULL, lang = NULL) {
-  bootstrapPage(div(class = "container", ...),
-                title = title,
-                responsive = responsive,
-                theme = theme,
-                lang = lang)
-}
-
-#' @rdname fixedPage
-#' @export
-fixedRow <- function(...) {
-  div(class = "row", ...)
-}
-
-
-#' Create a column within a UI definition
-#'
-#' Create a column for use within a  [fluidRow()] or
-#' [fixedRow()]
-#'
-#' @param width The grid width of the column (must be between 1 and 12)
-#' @param ... Elements to include within the column
-#' @param offset The number of columns to offset this column from the end of the
-#'   previous column.
-#'
-#' @return A column that can be included within a
-#'   [fluidRow()] or [fixedRow()].
-#'
-#'
-#' @seealso [fluidRow()], [fixedRow()].
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   fluidRow(
-#'     column(4,
-#'       sliderInput("obs", "Number of observations:",
-#'                   min = 1, max = 1000, value = 500)
-#'     ),
-#'     column(8,
-#'       plotOutput("distPlot")
-#'     )
-#'   )
-#' )
-#'
-#' server <- function(input, output) {
-#'   output$distPlot <- renderPlot({
-#'     hist(rnorm(input$obs))
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#'
-#'
-#' ui <- fluidPage(
-#'   fluidRow(
-#'     column(width = 4,
-#'       "4"
-#'     ),
-#'     column(width = 3, offset = 2,
-#'       "3 offset 2"
-#'     )
-#'   )
-#' )
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#' @export
-column <- function(width, ..., offset = 0) {
-
-  if (!is.numeric(width) || (width < 1) || (width > 12))
-    stop("column width must be between 1 and 12")
-
-  colClass <- paste0("col-sm-", width)
-  if (offset > 0) {
-    # offset-md-x is for bootstrap 4 forward compat
-    # (every size tier has been bumped up one level)
-    # https://github.com/twbs/bootstrap/blob/74b8fe7/docs/4.3/migration/index.html#L659
-    colClass <- paste0(colClass, " offset-md-", offset, " col-sm-offset-", offset)
-  }
-  div(class = colClass, ...)
-}
-
-
-#' Create a panel containing an application title.
-#'
-#' @param title An application title to display
-#' @param windowTitle The title that should be displayed by the browser window.
-#'
-#' @details Calling this function has the side effect of including a
-#'   `title` tag within the head. You can also specify a page title
-#'   explicitly using the `title` parameter of the top-level page function.
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   titlePanel("Hello Shiny!")
-#' )
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#' @export
-titlePanel <- function(title, windowTitle=title) {
-  tagList(
-    tags$head(tags$title(windowTitle)),
-    h2(title)
-  )
-}
-
-#' Layout a sidebar and main area
-#'
-#' Create a layout (`sidebarLayout()`) with a sidebar (`sidebarPanel()`) and
-#' main area (`mainPanel()`). The sidebar is displayed with a distinct
-#' background color and typically contains input controls. The main
-#' area occupies 2/3 of the horizontal width and typically contains outputs.
-#'
-#' @param sidebarPanel The `sidebarPanel()` containing input controls.
-#' @param mainPanel The `mainPanel()` containing outputs.
-#' @param position The position of the sidebar relative to the main area ("left"
-#'   or "right").
-#' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
-#'   layout.
-#' @param width The width of the sidebar and main panel. By default, the
-#'   sidebar takes up 1/3 of the width, and the main panel 2/3. The total
-#'   width must be 12 or less.
-#' @param ... Output elements to include in the sidebar/main panel.
-#'
-#' @family layout functions
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' # Define UI
-#' ui <- fluidPage(
-#'
-#'   # Application title
-#'   titlePanel("Hello Shiny!"),
-#'
-#'   sidebarLayout(
-#'
-#'     # Sidebar with a slider input
-#'     sidebarPanel(
-#'       sliderInput("obs",
-#'                   "Number of observations:",
-#'                   min = 0,
-#'                   max = 1000,
-#'                   value = 500)
-#'     ),
-#'
-#'     # Show a plot of the generated distribution
-#'     mainPanel(
-#'       plotOutput("distPlot")
-#'     )
-#'   )
-#' )
-#'
-#' # Server logic
-#' server <- function(input, output) {
-#'   output$distPlot <- renderPlot({
-#'     hist(rnorm(input$obs))
-#'   })
-#' }
-#'
-#' # Complete app with UI and server components
-#' shinyApp(ui, server)
-#' }
-#' @export
-sidebarLayout <- function(sidebarPanel,
-                          mainPanel,
-                          position = c("left", "right"),
-                          fluid = TRUE) {
-
-  # determine the order
-  position <- match.arg(position)
-  if (position == "left") {
-    firstPanel <- sidebarPanel
-    secondPanel <- mainPanel
-  }
-  else if (position == "right") {
-    firstPanel <- mainPanel
-    secondPanel <- sidebarPanel
-  }
-
-  # return as as row
-  if (fluid)
-    fluidRow(firstPanel, secondPanel)
-  else
-    fixedRow(firstPanel, secondPanel)
-}
-
-#' @export
-#' @rdname sidebarLayout
-sidebarPanel <- function(..., width = 4) {
-  div(class=paste0("col-sm-", width),
-    tags$form(class="well",
-      # A11y semantic landmark for sidebar
-      role="complementary",
-      ...
-    )
-  )
-}
-
-#' @export
-#' @rdname sidebarLayout
-mainPanel <- function(..., width = 8) {
-  div(class=paste0("col-sm-", width),
-    # A11y semantic landmark for main region
-    role="main",
-    ...
-  )
-}
-
-#' Lay out UI elements vertically
-#'
-#' Create a container that includes one or more rows of content (each element
-#' passed to the container will appear on it's own line in the UI)
-#'
-#' @param ... Elements to include within the container
-#' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
-#'   layout.
-#'
-#' @family layout functions
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   verticalLayout(
-#'     a(href="http://example.com/link1", "Link One"),
-#'     a(href="http://example.com/link2", "Link Two"),
-#'     a(href="http://example.com/link3", "Link Three")
-#'   )
-#' )
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#' @export
-verticalLayout <- function(..., fluid = TRUE) {
-  lapply(list(...), function(row) {
-    col <- column(12, row)
-    if (fluid)
-      fluidRow(col)
-    else
-      fixedRow(col)
-  })
-}
-
-#' Flow layout
-#'
-#' Lays out elements in a left-to-right, top-to-bottom arrangement. The elements
-#' on a given row will be top-aligned with each other. This layout will not work
-#' well with elements that have a percentage-based width (e.g.
-#' [plotOutput()] at its default setting of `width = "100%"`).
-#'
-#' @param ... Unnamed arguments will become child elements of the layout. Named
-#'   arguments will become HTML attributes on the outermost tag.
-#' @param cellArgs Any additional attributes that should be used for each cell
-#'   of the layout.
-#'
-#' @family layout functions
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- flowLayout(
-#'   numericInput("rows", "How many rows?", 5),
-#'   selectInput("letter", "Which letter?", LETTERS),
-#'   sliderInput("value", "What value?", 0, 100, 50)
-#' )
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#' @export
-flowLayout <- function(..., cellArgs = list()) {
-
-  children <- list(...)
-  childIdx <- !nzchar(names(children) %OR% character(length(children)))
-  attribs <- children[!childIdx]
-  children <- children[childIdx]
-
-  do.call(tags$div, c(list(class = "shiny-flow-layout"),
-    attribs,
-    lapply(children, function(x) {
-      do.call(tags$div, c(cellArgs, list(x)))
-    })
-  ))
-}
-
-#' Input panel
-#'
-#' A [flowLayout()] with a grey border and light grey background,
-#' suitable for wrapping inputs.
-#'
-#' @param ... Input controls or other HTML elements.
-#' @export
-inputPanel <- function(...) {
-  div(class = "shiny-input-panel",
-    flowLayout(...)
-  )
-}
-
-#' Split layout
-#'
-#' Lays out elements horizontally, dividing the available horizontal space into
-#' equal parts (by default).
-#'
-#' @param ... Unnamed arguments will become child elements of the layout. Named
-#'   arguments will become HTML attributes on the outermost tag.
-#' @param cellWidths Character or numeric vector indicating the widths of the
-#'   individual cells. Recycling will be used if needed. Character values will
-#'   be interpreted as CSS lengths (see [validateCssUnit()]), numeric
-#'   values as pixels.
-#' @param cellArgs Any additional attributes that should be used for each cell
-#'   of the layout.
-#'
-#' @family layout functions
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' # Server code used for all examples
-#' server <- function(input, output) {
-#'   output$plot1 <- renderPlot(plot(cars))
-#'   output$plot2 <- renderPlot(plot(pressure))
-#'   output$plot3 <- renderPlot(plot(AirPassengers))
-#' }
-#'
-#' # Equal sizing
-#' ui <- splitLayout(
-#'   plotOutput("plot1"),
-#'   plotOutput("plot2")
-#' )
-#' shinyApp(ui, server)
-#'
-#' # Custom widths
-#' ui <- splitLayout(cellWidths = c("25%", "75%"),
-#'   plotOutput("plot1"),
-#'   plotOutput("plot2")
-#' )
-#' shinyApp(ui, server)
-#'
-#' # All cells at 300 pixels wide, with cell padding
-#' # and a border around everything
-#' ui <- splitLayout(
-#'   style = "border: 1px solid silver;",
-#'   cellWidths = 300,
-#'   cellArgs = list(style = "padding: 6px"),
-#'   plotOutput("plot1"),
-#'   plotOutput("plot2"),
-#'   plotOutput("plot3")
-#' )
-#' shinyApp(ui, server)
-#' }
-#' @export
-splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
-
-  children <- list(...)
-  childIdx <- !nzchar(names(children) %OR% character(length(children)))
-  attribs <- children[!childIdx]
-  children <- children[childIdx]
-  count <- length(children)
-
-  if (length(cellWidths) == 0 || is.na(cellWidths)) {
-    cellWidths <- sprintf("%.3f%%", 100 / count)
-  }
-  cellWidths <- rep(cellWidths, length.out = count)
-  cellWidths <- sapply(cellWidths, validateCssUnit)
-
-  do.call(tags$div, c(list(class = "shiny-split-layout"),
-    attribs,
-    mapply(children, cellWidths, FUN = function(x, w) {
-      do.call(tags$div, c(
-        list(style = sprintf("width: %s;", w)),
-        cellArgs,
-        list(x)
-      ))
-    }, SIMPLIFY = FALSE)
-  ))
-}
-
-#' Flex Box-based row/column layouts
-#'
-#' Creates row and column layouts with proportionally-sized cells, using the
-#' Flex Box layout model of CSS3. These can be nested to create arbitrary
-#' proportional-grid layouts. **Warning:** Flex Box is not well supported
-#' by Internet Explorer, so these functions should only be used where modern
-#' browsers can be assumed.
-#'
-#' @details If you try to use `fillRow` and `fillCol` inside of other
-#'   Shiny containers, such as [sidebarLayout()],
-#'   [navbarPage()], or even `tags$div`, you will probably find
-#'   that they will not appear. This is due to `fillRow` and `fillCol`
-#'   defaulting to `height="100%"`, which will only work inside of
-#'   containers that have determined their own size (rather than shrinking to
-#'   the size of their contents, as is usually the case in HTML).
-#'
-#'   To avoid this problem, you have two options:
-#'   \itemize{
-#'     \item only use `fillRow`/`fillCol` inside of `fillPage`,
-#'       `fillRow`, or `fillCol`
-#'     \item provide an explicit `height` argument to
-#'       `fillRow`/`fillCol`
-#'   }
-#'
-#' @param ... UI objects to put in each row/column cell; each argument will
-#'   occupy a single cell. (To put multiple items in a single cell, you can use
-#'   [tagList()] or [div()] to combine them.) Named
-#'   arguments will be used as attributes on the `div` element that
-#'   encapsulates the row/column.
-#' @param flex Determines how space should be distributed to the cells. Can be a
-#'   single value like `1` or `2` to evenly distribute the available
-#'   space; or use a vector of numbers to specify the proportions. For example,
-#'   `flex = c(2, 3)` would cause the space to be split 40%/60% between
-#'   two cells. NA values will cause the corresponding cell to be sized
-#'   according to its contents (without growing or shrinking).
-#' @param width,height The total amount of width and height to use for the
-#'   entire row/column. For the default height of `"100%"` to be
-#'   effective, the parent must be `fillPage`, another
-#'   `fillRow`/`fillCol`, or some other HTML element whose height is
-#'   not determined by the height of its contents.
-#'
-#' @examples
-#' # Only run this example in interactive R sessions.
-#' if (interactive()) {
-#'
-#' ui <- fillPage(fillRow(
-#'   plotOutput("plotLeft", height = "100%"),
-#'   fillCol(
-#'     plotOutput("plotTopRight", height = "100%"),
-#'     plotOutput("plotBottomRight", height = "100%")
-#'   )
-#' ))
-#'
-#' server <- function(input, output, session) {
-#'   output$plotLeft <- renderPlot(plot(cars))
-#'   output$plotTopRight <- renderPlot(plot(pressure))
-#'   output$plotBottomRight <- renderPlot(plot(AirPassengers))
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#' }
-#' @export
-fillRow <- function(..., flex = 1, width = "100%", height = "100%") {
-  flexfill(..., direction = "row", flex = flex, width = width, height = height)
-}
-
-#' @rdname fillRow
-#' @export
-fillCol <- function(..., flex = 1, width = "100%", height = "100%") {
-  flexfill(..., direction = "column", flex = flex, width = width, height = height)
-}
-
-flexfill <- function(..., direction, flex, width = width, height = height) {
-  children <- list(...)
-  attrs <- list()
-
-  if (!is.null(names(children))) {
-    attrs <- children[names(children) != ""]
-    children <- children[names(children) == ""]
-  }
-
-  if (length(flex) > length(children)) {
-    flex <- flex[seq_along(children)]
-  }
-
-  # The dimension along the main axis
-  main <- switch(direction,
-    row = "width",
-    "row-reverse" = "width",
-    column = "height",
-    "column-reverse" = "height",
-    stop("Unexpected direction")
-  )
-  # The dimension along the cross axis
-  cross <- if (main == "width") "height" else "width"
-
-  divArgs <- list(
-    class = sprintf("flexfill-container flexfill-container-%s", direction),
-    style = css(
-      display = "-webkit-flex",
-      display = "-ms-flexbox",
-      display = "flex",
-      .webkit.flex.direction = direction,
-      .ms.flex.direction = direction,
-      flex.direction = direction,
-      width = validateCssUnit(width),
-      height = validateCssUnit(height)
-    ),
-    mapply(children, flex, FUN = function(el, flexValue) {
-      if (is.na(flexValue)) {
-        # If the flex value is NA, then put the element in a simple flex item
-        # that sizes itself (along the main axis) to its contents
-        tags$div(
-          class = "flexfill-item",
-          style = css(
-            position = "relative",
-            "-webkit-flex" = "none",
-            "-ms-flex" = "none",
-            flex = "none"
-          ),
-          style = paste0(main, ":auto;", cross, ":100%;"),
-          el
-        )
-      } else if (is.numeric(flexValue)) {
-        # If the flex value is numeric, we need *two* wrapper divs. The outer is
-        # the flex item, and the inner is an absolute-fill div that is needed to
-        # make percentage-based sizing for el work correctly. I don't understand
-        # why this is needed but the truth is probably in this SO page:
-        # http://stackoverflow.com/questions/15381172/css-flexbox-child-height-100
-        tags$div(
-          class = "flexfill-item",
-          style = css(
-            position = "relative",
-            "-webkit-flex" = flexValue,
-            "-ms-flex" = flexValue,
-            flex = flexValue,
-            width = "100%", height = "100%"
-          ),
-          tags$div(
-            class = "flexfill-item-inner",
-            style = css(
-              position = "absolute",
-              top = 0, left = 0, right = 0, bottom = 0
-            ),
-            el
-          )
-        )
-      } else {
-        stop("Unexpected flex argument: ", flexValue)
-      }
-    }, SIMPLIFY = FALSE, USE.NAMES = FALSE)
-  )
-  do.call(tags$div, c(attrs, divArgs))
-}
-
-css <- function(..., collapse_ = "") {
-  props <- list(...)
-  if (length(props) == 0) {
-    return("")
-  }
-
-  if (is.null(names(props)) || any(names(props) == "")) {
-    stop("cssList expects all arguments to be named")
-  }
-
-  # Necessary to make factors show up as level names, not numbers
-  props[] <- lapply(props, paste, collapse = " ")
-
-  # Drop null args
-  props <- props[!sapply(props, empty)]
-  if (length(props) == 0) {
-    return("")
-  }
-
-  # Replace all '.' and '_' in property names to '-'
-  names(props) <- gsub("[._]", "-", tolower(gsub("([A-Z])", "-\\1", names(props))))
-
-  # Create "!important" suffix for each property whose name ends with !, then
-  # remove the ! from the property name
-  important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "")
-  names(props) <- sub("!$", "", names(props), perl = TRUE)
-
-  paste0(names(props), ":", props, important, ";", collapse = collapse_)
-}
-
-empty <- function(x) {
-  length(x) == 0 || (is.character(x) && !any(nzchar(x)))
-}

R/cache-disk.R

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

R/cache-memory.R

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

R/cache-utils.R

@@ -1,9 +0,0 @@
-
-validate_key <- function(key) {
-  if (!is.character(key) || length(key) != 1 || nchar(key) == 0) {
-    stop("Invalid key: key must be single non-empty string.")
-  }
-  if (grepl("[^a-z0-9]", key)) {
-    stop("Invalid key: ", key, ". Only lowercase letters and numbers are allowed.")
-  }
-}

R/cache.R

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

R/conditions.R

@@ -1,627 +0,0 @@
-#' Stack trace manipulation functions
-#'
-#' Advanced (borderline internal) functions for capturing, printing, and
-#' manipulating stack traces.
-#'
-#' @return `printError` and `printStackTrace` return
-#'   `invisible()`. The other functions pass through the results of
-#'   `expr`.
-#'
-#' @examples
-#' # Keeps tryCatch and withVisible related calls off the
-#' # pretty-printed stack trace
-#'
-#' visibleFunction1 <- function() {
-#'   stop("Kaboom!")
-#' }
-#'
-#' visibleFunction2 <- function() {
-#'   visibleFunction1()
-#' }
-#'
-#' hiddenFunction <- function(expr) {
-#'   expr
-#' }
-#'
-#' # An example without ..stacktraceon/off.. manipulation.
-#' # The outer "try" is just to prevent example() from stopping.
-#' try({
-#'   # The withLogErrors call ensures that stack traces are captured
-#'   # and that errors that bubble up are logged using warning().
-#'   withLogErrors({
-#'     # tryCatch and withVisible are just here to add some noise to
-#'     # the stack trace.
-#'     tryCatch(
-#'       withVisible({
-#'         hiddenFunction(visibleFunction2())
-#'       })
-#'     )
-#'   })
-#' })
-#'
-#' # Now the same example, but with ..stacktraceon/off.. to hide some
-#' # of the less-interesting bits (tryCatch and withVisible).
-#' ..stacktraceoff..({
-#'   try({
-#'     withLogErrors({
-#'       tryCatch(
-#'         withVisible(
-#'           hiddenFunction(
-#'             ..stacktraceon..(visibleFunction2())
-#'           )
-#'         )
-#'       )
-#'     })
-#'   })
-#' })
-#'
-#'
-#' @name stacktrace
-#' @rdname stacktrace
-#' @keywords internal
-NULL
-
-getCallNames <- function(calls) {
-  sapply(calls, function(call) {
-    if (is.function(call[[1]])) {
-      "<Anonymous>"
-    } else if (inherits(call[[1]], "call")) {
-      paste0(format(call[[1]]), collapse = " ")
-    } else if (typeof(call[[1]]) == "promise") {
-      "<Promise>"
-    } else {
-      paste0(as.character(call[[1]]), collapse = " ")
-    }
-  })
-}
-
-getLocs <- function(calls) {
-  vapply(calls, function(call) {
-    srcref <- attr(call, "srcref", exact = TRUE)
-    if (!is.null(srcref)) {
-      srcfile <- attr(srcref, "srcfile", exact = TRUE)
-      if (!is.null(srcfile) && !is.null(srcfile$filename)) {
-        loc <- paste0(srcfile$filename, "#", srcref[[1]])
-        return(paste0(" [", loc, "]"))
-      }
-    }
-    return("")
-  }, character(1))
-}
-
-getCallCategories <- function(calls) {
-  vapply(calls, function(call) {
-    srcref <- attr(call, "srcref", exact = TRUE)
-    if (!is.null(srcref)) {
-      srcfile <- attr(srcref, "srcfile", exact = TRUE)
-      if (!is.null(srcfile)) {
-        if (!is.null(srcfile$original)) {
-          return("pkg")
-        } else {
-          return("user")
-        }
-      }
-    }
-    return("")
-  }, character(1))
-}
-
-#' @details `captureStackTraces` runs the given `expr` and if any
-#'   *uncaught* errors occur, annotates them with stack trace info for use
-#'   by `printError` and `printStackTrace`. It is not necessary to use
-#'   `captureStackTraces` around the same expression as
-#'   `withLogErrors`, as the latter includes a call to the former. Note
-#'   that if `expr` contains calls (either directly or indirectly) to
-#'   `try`, or `tryCatch` with an error handler, stack traces therein
-#'   cannot be captured unless another `captureStackTraces` call is
-#'   inserted in the interior of the `try` or `tryCatch`. This is
-#'   because these calls catch the error and prevent it from traveling up to the
-#'   condition handler installed by `captureStackTraces`.
-#'
-#' @param expr The expression to wrap.
-#' @rdname stacktrace
-#' @export
-captureStackTraces <- function(expr) {
-  promises::with_promise_domain(createStackTracePromiseDomain(),
-    expr
-  )
-}
-
-#' @include globals.R
-.globals$deepStack <- NULL
-
-createStackTracePromiseDomain <- function() {
-  # These are actually stateless, we wouldn't have to create a new one each time
-  # if we didn't want to. They're pretty cheap though.
-  
-  d <- promises::new_promise_domain(
-    wrapOnFulfilled = function(onFulfilled) {
-      force(onFulfilled)
-      # Subscription time
-      if (deepStacksEnabled()) {
-        currentStack <- sys.calls()
-        currentParents <- sys.parents()
-        attr(currentStack, "parents") <- currentParents
-        currentDeepStack <- .globals$deepStack
-      }
-      function(...) {
-        # Fulfill time
-        if (deepStacksEnabled()) {
-          origDeepStack <- .globals$deepStack
-          .globals$deepStack <- c(currentDeepStack, list(currentStack))
-          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
-        }
-
-        withCallingHandlers(
-          onFulfilled(...),
-          error = doCaptureStack
-        )
-      }
-    },
-    wrapOnRejected = function(onRejected) {
-      force(onRejected)
-      # Subscription time
-      if (deepStacksEnabled()) {
-        currentStack <- sys.calls()
-        currentParents <- sys.parents()
-        attr(currentStack, "parents") <- currentParents
-        currentDeepStack <- .globals$deepStack
-      }
-      function(...) {
-        # Fulfill time
-        if (deepStacksEnabled()) {
-          origDeepStack <- .globals$deepStack
-          .globals$deepStack <- c(currentDeepStack, list(currentStack))
-          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
-        }
-
-        withCallingHandlers(
-          onRejected(...),
-          error = doCaptureStack
-        )
-      }
-    },
-    wrapSync = function(expr) {
-      withCallingHandlers(expr,
-        error = doCaptureStack
-      )
-    },
-    onError = doCaptureStack
-  )
-}
-
-deepStacksEnabled <- function() {
-  getOption("shiny.deepstacktrace", TRUE)
-}
-
-doCaptureStack <- function(e) {
-  if (is.null(attr(e, "stack.trace", exact = TRUE))) {
-    calls <- sys.calls()
-    parents <- sys.parents()
-    attr(calls, "parents") <- parents
-    attr(e, "stack.trace") <- calls
-  }
-  if (deepStacksEnabled()) {
-    if (is.null(attr(e, "deep.stack.trace", exact = TRUE)) && !is.null(.globals$deepStack)) {
-      attr(e, "deep.stack.trace") <- .globals$deepStack
-    }
-  }
-  stop(e)
-}
-
-#' @details `withLogErrors` captures stack traces and logs errors that
-#'   occur in `expr`, but does allow errors to propagate beyond this point
-#'   (i.e. it doesn't catch the error). The same caveats that apply to
-#'   `captureStackTraces` with regard to `try`/`tryCatch` apply
-#'   to `withLogErrors`.
-#' @rdname stacktrace
-#' @export
-withLogErrors <- function(expr,
-  full = getOption("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  withCallingHandlers(
-    {
-      result <- captureStackTraces(expr)
-
-      # Handle expr being an async operation
-      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 (isTRUE(getOption("show.error.messages"))) {
-            printError(cond, full = full, offset = offset)
-          }
-        })
-      }
-
-      result
-    },
-    error = function(cond) {
-      # Don't print shiny.silent.error (i.e. validation errors)
-      if (inherits(cond, "shiny.silent.error")) return()
-      if (isTRUE(getOption("show.error.messages"))) {
-        printError(cond, full = full, offset = offset)
-      }
-    }
-  )
-}
-
-#' @details `printError` prints the error and stack trace (if any) using
-#'   `warning(immediate.=TRUE)`. `printStackTrace` prints the stack
-#'   trace only.
-#'
-#' @param cond An condition object (generally, an error).
-#' @param full If `TRUE`, then every element of `sys.calls()` will be
-#'   included in the stack trace. By default (`FALSE`), calls that Shiny
-#'   deems uninteresting will be hidden.
-#' @param offset If `TRUE` (the default), srcrefs will be reassigned from
-#'   the calls they originated from, to the destinations of those calls. If
-#'   you're used to stack traces from other languages, this feels more
-#'   intuitive, as the definition of the function indicated in the call and the
-#'   location specified by the srcref match up. If `FALSE`, srcrefs will be
-#'   left alone (traditional R treatment where the srcref is of the callsite).
-#' @rdname stacktrace
-#' @export
-printError <- function(cond,
-  full = getOption("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-  
-  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s", 
-    getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
-  
-  printStackTrace(cond, full = full, offset = offset)
-}
-
-#' @rdname stacktrace
-#' @export
-printStackTrace <- function(cond,
-  full = getOption("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  should_drop <- !full
-  should_strip <- !full
-  should_prune <- !full
-  
-  stackTraceCalls <- c(
-    attr(cond, "deep.stack.trace", exact = TRUE),
-    list(attr(cond, "stack.trace", exact = TRUE))
-  )
-  
-  stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
-  stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
-  stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
-  
-  # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
-  if (should_drop) {
-    # toKeep is a list of logical vectors, of which elements (stack frames) to keep
-    toKeep <- lapply(stackTraceCallNames, dropTrivialFrames)
-    # We apply the list of logical vector indices to each data structure
-    stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-  }
-  
-  delayedAssign("all_true", {
-    # List of logical vectors that are all TRUE, the same shape as
-    # stackTraceCallNames. Delay the evaluation so we don't create it unless
-    # we need it, but if we need it twice then we don't pay to create it twice.
-    lapply(stackTraceCallNames, function(st) {
-      rep_len(TRUE, length(st))
-    })
-  })
-  
-  # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
-  # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
-  # logical vectors.
-  toShow <- mapply(
-    if (should_strip) stripStackTraces(stackTraceCallNames) else all_true,
-    if (should_prune) lapply(stackTraceParents, pruneStackTrace) else all_true,
-    FUN = `&`,
-    SIMPLIFY = FALSE
-  )
-  
-  dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
-    st <- data.frame(
-      num = rev(which(index)),
-      call = rev(nms[index]),
-      loc = rev(getLocs(calls[index])),
-      category = rev(getCallCategories(calls[index])),
-      stringsAsFactors = FALSE
-    )
-    
-    if (i != 1) {
-      message("From earlier call:")
-    }
-
-    if (nrow(st) == 0) {
-      message("  [No stack trace available]")
-    } else {
-      width <- floor(log10(max(st$num))) + 1
-      formatted <- paste0(
-        "  ",
-        formatC(st$num, width = width),
-        ": ",
-        mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
-          if (category == "pkg")
-            crayon::silver(name)
-          else if (category == "user")
-            crayon::blue$bold(name)
-          else
-            crayon::white(name)
-        }),
-        "\n"
-      )
-      cat(file = stderr(), formatted, sep = "")
-    }
-
-    st
-  }, SIMPLIFY = FALSE)
-  
-  invisible()
-}
-
-#' @details `extractStackTrace` takes a list of calls (e.g. as returned
-#'   from `conditionStackTrace(cond)`) and returns a data frame with one
-#'   row for each stack frame and the columns `num` (stack frame number),
-#'   `call` (a function name or similar), and `loc` (source file path
-#'   and line number, if available). It was deprecated after shiny 1.0.5 because
-#'   it doesn't support deep stack traces.
-#' @rdname stacktrace
-#' @export
-extractStackTrace <- function(calls,
-  full = getOption("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-  
-  shinyDeprecated(NULL,
-    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
-    version = "1.0.5")
-
-  srcrefs <- getSrcRefs(calls)
-  if (offset) {
-    # Offset calls vs. srcrefs by 1 to make them more intuitive.
-    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
-    # the definition of foo().
-    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
-  }
-  calls <- setSrcRefs(calls, srcrefs)
-
-  callnames <- getCallNames(calls)
-
-  # Hide and show parts of the callstack based on ..stacktrace(on|off)..
-  if (full) {
-    toShow <- rep.int(TRUE, length(calls))
-  } else {
-    # Remove stop(), .handleSimpleError(), and h() calls from the end of
-    # the calls--they don't add any helpful information. But only remove
-    # the last *contiguous* block of them, and then, only if they are the
-    # last thing in the calls list.
-    hideable <- callnames %in% c("stop", ".handleSimpleError", "h")
-    # What's the last that *didn't* match stop/.handleSimpleError/h?
-    lastGoodCall <- max(which(!hideable))
-    toRemove <- length(calls) - lastGoodCall
-    # But don't remove more than 5 levels--that's an indication we might
-    # have gotten it wrong, I guess
-    if (toRemove > 0 && toRemove < 5) {
-      calls <- utils::head(calls, -toRemove)
-      callnames <- utils::head(callnames, -toRemove)
-    }
-
-    # This uses a ref-counting scheme. It might make sense to switch this
-    # to a toggling scheme, so the most recent ..stacktrace(on|off)..
-    # directive wins, regardless of what came before it.
-    # Also explicitly remove ..stacktraceon.. because it can appear with
-    # score > 0 but still should never be shown.
-    score <- rep.int(0, length(callnames))
-    score[callnames == "..stacktraceoff.."] <- -1
-    score[callnames == "..stacktraceon.."] <- 1
-    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
-
-    # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're
-    # just internals for tryCatch
-    toShow <- toShow & !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList"))
-  }
-  calls <- calls[toShow]
-
-  calls <- rev(calls) # Show in traceback() order
-  index <- rev(which(toShow))
-  width <- floor(log10(max(index))) + 1
-
-  data.frame(
-    num = index,
-    call = getCallNames(calls),
-    loc = getLocs(calls),
-    category = getCallCategories(calls),
-    stringsAsFactors = FALSE
-  )
-}
-
-stripStackTraces <- function(stackTraces, values = FALSE) {
-  score <- 1L  # >=1: show, <=0: hide
-  lapply(seq_along(stackTraces), function(i) {
-    res <- stripOneStackTrace(stackTraces[[i]], i != 1, score)
-    score <<- res$score
-    toShow <- as.logical(res$trace)
-    if (values) {
-      as.character(stackTraces[[i]][toShow])
-    } else {
-      as.logical(toShow)
-    }
-  })
-}
-
-stripOneStackTrace <- function(stackTrace, truncateFloor, startingScore) {
-  prefix <- logical(0)
-  if (truncateFloor) {
-    indexOfFloor <- utils::tail(which(stackTrace == "..stacktracefloor.."), 1)
-    if (length(indexOfFloor)) {
-      stackTrace <- stackTrace[(indexOfFloor+1L):length(stackTrace)]
-      prefix <- rep_len(FALSE, indexOfFloor)
-    }
-  }
-  
-  if (length(stackTrace) == 0) {
-    return(list(score = startingScore, character(0)))
-  }
-  
-  score <- rep.int(0L, length(stackTrace))
-  score[stackTrace == "..stacktraceon.."] <- 1L
-  score[stackTrace == "..stacktraceoff.."] <- -1L
-  score <- startingScore + cumsum(score)
-  
-  toShow <- score > 0 & !(stackTrace %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
-  
-  
-  list(score = utils::tail(score, 1), trace = c(prefix, toShow))
-}
-
-# Given sys.parents() (which corresponds to sys.calls()), return a logical index
-# that prunes each subtree so that only the final branch remains. The result,
-# when applied to sys.calls(), is a linear list of calls without any "wrapper"
-# functions like tryCatch, try, with, hybrid_chain, etc. While these are often
-# part of the active call stack, they rarely are helpful when trying to identify
-# a broken bit of code.
-pruneStackTrace <- function(parents) {
-  # Detect nodes that are not the last child. This is necessary, but not
-  # sufficient; we also need to drop nodes that are the last child, but one of
-  # their ancestors is not.
-  is_dupe <- duplicated(parents, fromLast = TRUE)
-  
-  # The index of the most recently seen node that was actually kept instead of
-  # dropped.
-  current_node <- 0
-  
-  # Loop over the parent indices. Anything that is not parented by current_node
-  # (a.k.a. last-known-good node), or is a dupe, can be discarded. Anything that
-  # is kept becomes the new current_node.
-  include <- vapply(seq_along(parents), function(i) {
-    if (!is_dupe[[i]] && parents[[i]] == current_node) {
-      current_node <<- i
-      TRUE
-    } else {
-      FALSE
-    }
-  }, FUN.VALUE = logical(1))
-  
-  include
-}
-
-dropTrivialFrames <- function(callnames) {
-  # Remove stop(), .handleSimpleError(), and h() calls from the end of
-  # the calls--they don't add any helpful information. But only remove
-  # the last *contiguous* block of them, and then, only if they are the
-  # last thing in the calls list.
-  hideable <- callnames %in% c(".handleSimpleError", "h", "base$wrapOnFulfilled")
-  # What's the last that *didn't* match stop/.handleSimpleError/h?
-  lastGoodCall <- max(which(!hideable))
-  toRemove <- length(callnames) - lastGoodCall
-  
-  c(
-    rep_len(TRUE, length(callnames) - toRemove),
-    rep_len(FALSE, toRemove)
-  )
-}
-
-offsetSrcrefs <- function(calls, offset = TRUE) {
-  if (offset) {
-    srcrefs <- getSrcRefs(calls)
-
-    # Offset calls vs. srcrefs by 1 to make them more intuitive.
-    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
-    # the definition of foo().
-    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
-    
-    calls <- setSrcRefs(calls, srcrefs)
-  }
-  
-  calls
-}
-
-#' @details `formatStackTrace` is similar to `extractStackTrace`, but
-#'   it returns a preformatted character vector instead of a data frame. It was
-#'   deprecated after shiny 1.0.5 because it doesn't support deep stack traces.
-#' @param indent A string to prefix every line of the stack trace.
-#' @rdname stacktrace
-#' @export
-formatStackTrace <- function(calls, indent = "    ",
-  full = getOption("shiny.fullstacktrace", FALSE),
-  offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  shinyDeprecated(NULL,
-    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
-    version = "1.0.5")
-  
-  st <- extractStackTrace(calls, full = full, offset = offset)
-  if (nrow(st) == 0) {
-    return(character(0))
-  }
-
-  width <- floor(log10(max(st$num))) + 1
-  paste0(
-    indent,
-    formatC(st$num, width = width),
-    ": ",
-    mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
-      if (category == "pkg")
-        crayon::silver(name)
-      else if (category == "user")
-        crayon::blue$bold(name)
-      else
-        crayon::white(name)
-    })
-  )
-}
-
-getSrcRefs <- function(calls) {
-  lapply(calls, function(call) {
-    attr(call, "srcref", exact = TRUE)
-  })
-}
-
-setSrcRefs <- function(calls, srcrefs) {
-  mapply(function(call, srcref) {
-    structure(call, srcref = srcref)
-  }, calls, srcrefs)
-}
-
-stripStackTrace <- function(cond) {
-  conditionStackTrace(cond) <- NULL
-}
-
-#' @details `conditionStackTrace` and `conditionStackTrace<-` are
-#'   accessor functions for getting/setting stack traces on conditions.
-#'
-#' @param cond A condition that may have previously been annotated by
-#'   `captureStackTraces` (or `withLogErrors`).
-#' @rdname stacktrace
-#' @export
-conditionStackTrace <- function(cond) {
-  attr(cond, "stack.trace", exact = TRUE)
-}
-
-#' @param value The stack trace value to assign to the condition.
-#' @rdname stacktrace
-#' @export
-`conditionStackTrace<-` <- function(cond, value) {
-  attr(cond, "stack.trace") <- value
-  invisible(cond)
-}
-
-#' @details The two functions `..stacktraceon..` and
-#'   `..stacktraceoff..` have no runtime behavior during normal execution;
-#'   they exist only to create artifacts on the stack trace (sys.call()) that
-#'   instruct the stack trace pretty printer what parts of the stack trace are
-#'   interesting or not. The initial state is 1 and we walk from the outermost
-#'   call inwards. Each ..stacktraceoff.. decrements the state by one, and each
-#'   ..stacktraceon.. increments the state by one. Any stack trace frame whose
-#'   value is less than 1 is hidden, and finally, the ..stacktraceon.. and
-#'   ..stacktraceoff.. calls themselves are hidden too.
-#'
-#' @rdname stacktrace
-#' @export
-..stacktraceon.. <- function(expr) expr
-#' @rdname stacktrace
-#' @export
-..stacktraceoff.. <- function(expr) expr
-
-..stacktracefloor.. <- function(expr) expr

R/diagnose.R

@@ -1,157 +0,0 @@
-# Analyze an R file for possible extra or missing commas. Returns FALSE if any
-# problems detected, TRUE otherwise.
-diagnoseCode <- function(path = NULL, text = NULL) {
-  if (!xor(is.null(path), is.null(text))) {
-    stop("Must specify `path` or `text`, but not both.")
-  }
-
-  if (!is.null(path)) {
-    tokens <- sourcetools::tokenize_file(path)
-  } else {
-    tokens <- sourcetools::tokenize_string(text)
-  }
-
-  find_scopes <- function(tokens) {
-    # Strip whitespace and comments
-    tokens <- tokens[!(tokens$type %in% c("whitespace", "comment")),]
-
-    # Replace various types of things with "value"
-    tokens$type[tokens$type %in% c("string", "number", "symbol", "keyword")] <- "value"
-
-    # Record types for close and open brace/bracket/parens, and commas
-    brace_idx <- tokens$value %in% c("(", ")", "{", "}", "[", "]", ",")
-    tokens$type[brace_idx] <- tokens$value[brace_idx]
-
-    # Stack-related function for recording scope. Starting scope is "{"
-    stack <- "{"
-    push <- function(x) {
-      stack <<- c(stack, x)
-    }
-    pop <- function() {
-      if (length(stack) == 1) {
-        # Stack underflow, but we need to keep going
-        return(NA_character_)
-      }
-      res <- stack[length(stack)]
-      stack <<- stack[-length(stack)]
-      res
-    }
-    peek <- function() {
-      stack[length(stack)]
-    }
-
-    # First, establish a scope for each token. For opening and closing
-    # braces/brackets/parens, the scope at that location is the *surrounding*
-    # scope, not the new scope created by the brace/bracket/paren.
-    for (i in seq_len(nrow(tokens))) {
-      value <- tokens$value[i]
-
-      tokens$scope[i] <- peek()
-      if (value %in% c("{", "(", "[")) {
-        push(value)
-
-      } else if (value == "}") {
-        if (!identical(pop(), "{"))
-          tokens$err[i] <- "unmatched_brace"
-        # For closing brace/paren/bracket, get the scope after popping
-        tokens$scope[i] <- peek()
-
-      } else if (value == ")") {
-        if (!identical(pop(), "("))
-          tokens$err[i] <- "unmatched_paren"
-        tokens$scope[i] <- peek()
-
-      } else if (value == "]") {
-        if (!identical(pop(), "["))
-          tokens$err[i] <- "unmatched_bracket"
-        tokens$scope[i] <- peek()
-      }
-    }
-
-    tokens
-  }
-
-  check_commas <- function(tokens) {
-    # Find extra and missing commas
-    tokens$err <- mapply(
-      tokens$type,
-      c("", tokens$type[-length(tokens$type)]),
-      c(tokens$type[-1],  ""),
-      tokens$scope,
-      tokens$err,
-      SIMPLIFY = FALSE,
-      FUN = function(type, prevType, nextType, scope, err) {
-        # If an error was already found, just return it. This could have
-        # happened in the brace/paren/bracket matching phase.
-        if (!is.na(err)) {
-          return(err)
-        }
-        if (scope == "(") {
-          if (type == "," &&
-              (prevType == "(" || prevType == "," || nextType == ")"))
-          {
-            return("extra_comma")
-          }
-
-          if ((prevType == ")" && type == "value") ||
-              (prevType == "value" && type == "value")) {
-            return("missing_comma")
-          }
-        }
-
-        NA_character_
-      }
-    )
-
-    tokens
-  }
-
-
-  tokens$err <- NA_character_
-  tokens <- find_scopes(tokens)
-  tokens <- check_commas(tokens)
-
-  # No errors found
-  if (all(is.na(tokens$err))) {
-    return(TRUE)
-  }
-
-  # If we got here, errors were found; print messages.
-  if (!is.null(path)) {
-    lines <- readLines(path)
-  } else {
-    lines <- strsplit(text, "\n")[[1]]
-  }
-
-  # Print out the line of code with the error, and point to the column with
-  # the error.
-  show_code_error <- function(msg, lines, row, col) {
-    message(paste0(
-      msg, "\n",
-      row, ":", lines[row], "\n",
-      paste0(rep.int(" ", nchar(as.character(row)) + 1), collapse = ""),
-      gsub(perl = TRUE, "[^\\s]", " ", substr(lines[row], 1, col-1)), "^"
-    ))
-  }
-
-  err_idx <- which(!is.na(tokens$err))
-  msg <- ""
-  for (i in err_idx) {
-    row <- tokens$row[i]
-    col <- tokens$column[i]
-    err <- tokens$err[i]
-
-    if (err == "missing_comma") {
-      show_code_error("Possible missing comma at:", lines, row, col)
-    } else if (err == "extra_comma") {
-      show_code_error("Possible extra comma at:", lines, row, col)
-    } else if (err == "unmatched_brace") {
-      show_code_error("Possible unmatched '}' at:", lines, row, col)
-    } else if (err == "unmatched_paren") {
-      show_code_error("Possible unmatched ')' at:", lines, row, col)
-    } else if (err == "unmatched_bracket") {
-      show_code_error("Possible unmatched ']' at:", lines, row, col)
-    }
-  }
-  return(FALSE)
-}

R/fileupload.R

@@ -1,50 +1,37 @@
 # For HTML5-capable browsers, file uploads happen through a series of requests.
-#
+# 
 # 1. Client tells server that one or more files are about to be uploaded; the
 #    server responds with a "job ID" that the client should use for the rest of
 #    the upload.
-#
+#    
 # 2. For each file (sequentially):
 #    a. Client tells server the name, size, and type of the file.
 #    b. Client sends server a small-ish blob of data.
 #    c. Repeat 2b until the entire file has been uploaded.
 #    d. Client tells server that the current file is done.
-#
+#    
 # 3. Repeat 2 until all files have been uploaded.
-#
+# 
 # 4. Client tells server that all files have been uploaded, along with the
 #    input ID that this data should be associated with.
-#
+# 
 # Unfortunately this approach will not work for browsers that don't support
 # HTML5 File API, but the fallback approach we would like to use (multipart
 # form upload, i.e. traditional HTTP POST-based file upload) doesn't work with
 # the websockets package's HTTP server at the moment.
 
-# @description Returns a file's extension, with a leading dot, if one can be
-#   found. A valid extension contains only alphanumeric characters. If there is
-#   no extension, or if it contains non-alphanumeric characters, an empty
-#   string is returned.
-# @param x character vector giving file paths.
-# @return The extension of \code{x}, with a leading dot, if one was found.
-#   Otherwise, an empty character vector.
-maybeGetExtension <- function(x) {
-  ext <- tools::file_ext(x)
-  ifelse(ext == "", ext, paste0(".", ext))
-}
-
-FileUploadOperation <- R6Class(
+FileUploadOperation <- setRefClass(
   'FileUploadOperation',
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    .parent = NULL,
-    .id = character(0),
-    .files = data.frame(),
-    .dir = character(0),
-    .currentFileInfo = list(),
-    .currentFileData = NULL,
-    .pendingFileInfos = list(),
-
+  fields = list(
+    .parent = 'ANY',
+    .id = 'character',
+    .files = 'data.frame',
+    .dir = 'character',
+    .currentFileInfo = 'list',
+    .currentFileData = 'ANY',
+    .pendingFileInfos = 'list'
+  ),
+  methods = list(
     initialize = function(parent, id, dir, fileInfos) {
       .parent <<- parent
       .id <<- id
@@ -64,16 +51,15 @@ FileUploadOperation <- R6Class(
       .currentFileInfo <<- file
       .pendingFileInfos <<- tail(.pendingFileInfos, -1)
 
-      fileBasename <- basename(.currentFileInfo$name)
-      filename <- file.path(.dir, paste0(as.character(length(.files$name)), maybeGetExtension(fileBasename)))
-      row <- data.frame(name=fileBasename, size=file$size, type=file$type,
+      filename <- file.path(.dir, as.character(length(.files$name)))
+      row <- data.frame(name=file$name, size=file$size, type=file$type,
                         datapath=filename, stringsAsFactors=FALSE)
-
+      
       if (length(.files$name) == 0)
         .files <<- row
       else
         .files <<- rbind(.files, row)
-
+      
       .currentFileData <<- file(filename, open='wb')
     },
     fileChunk = function(rawdata) {
@@ -91,50 +77,33 @@ FileUploadOperation <- R6Class(
   )
 )
 
-#' @include map.R
-FileUploadContext <- R6Class(
+FileUploadContext <- setRefClass(
   'FileUploadContext',
-  class = FALSE,
-  private = list(
-    basedir = character(0),
-    operations = 'Map',
-    ids = character(0)  # Keep track of all ids used for file uploads
+  fields = list(
+    .basedir = 'character',
+    .operations = 'Map'
   ),
-  public = list(
+  methods = list(
     initialize = function(dir=tempdir()) {
-      private$basedir <- dir
-      private$operations <- Map$new()
+      .basedir <<- dir
     },
     createUploadOperation = function(fileInfos) {
       while (TRUE) {
-        id <- createUniqueId(12)
-        private$ids <- c(private$ids, id)
-        dir <- file.path(private$basedir, id)
+        id <- paste(as.raw(runif(12, min=0, max=0xFF)), collapse='')
+        dir <- file.path(.basedir, id)
         if (!dir.create(dir))
           next
-
-        op <- FileUploadOperation$new(self, id, dir, fileInfos)
-        private$operations$set(id, op)
+        
+        op <- FileUploadOperation$new(.self, id, dir, fileInfos)
+        .operations$set(id, op)
         return(id)
       }
     },
     getUploadOperation = function(jobId) {
-      private$operations$get(jobId)
+      .operations$get(jobId)
     },
     onJobFinished = function(jobId) {
-      private$operations$remove(jobId)
-    },
-    # Remove the directories containing file uploads; this is to be called when
-    # a session ends.
-    rmUploadDirs = function() {
-      # Make sure all_paths is underneath the tempdir()
-      if (!grepl(normalizePath(tempdir()), normalizePath(private$basedir), fixed = TRUE)) {
-        stop("Won't remove upload path ", private$basedir,
-          "because it is not under tempdir(): ", tempdir())
-      }
-
-      all_paths <- file.path(private$basedir, private$ids)
-      unlink(all_paths, recursive = TRUE)
+      .operations$remove(jobId)
     }
   )
 )

R/font-awesome.R

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

R/globals.R

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

R/graph.R

@@ -1,563 +1,73 @@
-# Check that the version of an suggested package satisfies the requirements
-#
-# @param package The name of the suggested package
-# @param version The version of the package
-check_suggested <- function(package, version = NULL) {
+#' @export
+writeReactLog <- function(file=stdout()) {
+  cat(RJSONIO::toJSON(.graphEnv$log, pretty=TRUE), file=file)
+}
 
-  if (is_available(package, version)) {
-    return()
+#' @export
+showReactLog <- function() {
+  browseURL(renderReactLog())
+}
+
+renderReactLog <- function() {
+  templateFile <- system.file('www/reactive-graph.html', package='shiny')
+  html <- paste(readLines(templateFile, warn=FALSE), collapse='\r\n')
+  tc <- textConnection(NULL, 'w')
+  on.exit(close(tc))
+  writeReactLog(tc)
+  cat('\n', file=tc)
+  flush(tc)
+  html <- sub('__DATA__', paste(textConnectionValue(tc), collapse='\r\n'), html, fixed=TRUE)
+  file <- tempfile(fileext = '.html')
+  writeLines(html, file)
+  return(file)
+}
+
+.graphAppend <- function(logEntry) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphEnv$log <- c(.graphEnv$log, list(logEntry))
+}
+
+.graphDependsOn <- function(id, label) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='dep', id=id, dependsOn=label))
+}
+
+.graphDependsOnId <- function(id, dependee) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='depId', id=id, dependsOn=dependee))
+}
+
+.graphCreateContext <- function(id, label, type, prevId) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(
+      action='ctx', id=id, label=paste(label, collapse='\n'), type=type, prevId=prevId
+    ))
+}
+
+.graphEnterContext <- function(id) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='enter', id=id))
+}
+
+.graphExitContext <- function(id) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='exit', id=id))
+}
+
+.graphValueChange <- function(label, value) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE))) {
+    .graphAppend(list(
+      action = 'valueChange',
+      id = label,
+      value = paste(capture.output(str(value)), collapse='\n')
+    ))
   }
-
-  msg <- paste0(
-    sQuote(package),
-    if (is.na(version %OR% NA)) "" else paste0("(>= ", version, ")"),
-    " must be installed for this functionality."
-  )
-
-  if (interactive()) {
-    message(msg, "\nWould you like to install it?")
-    if (utils::menu(c("Yes", "No")) == 1) {
-      return(utils::install.packages(package))
-    }
-  }
-
-  stop(msg, call. = FALSE)
 }
 
-
-
-
-# domain is like session
-
-
-# used to help define truly global react id's.
-# should work across session and in global namespace
-.globals$reactIdCounter <- 0L
-nextGlobalReactId <- function() {
-  .globals$reactIdCounter <- .globals$reactIdCounter + 1L
-  reactIdStr(.globals$reactIdCounter)
-}
-reactIdStr <- function(num) {
-  paste0("r", num)
+.graphInvalidate <- function(id) {
+  if (isTRUE(getOption('shiny.reactlog', FALSE)))
+    .graphAppend(list(action='invalidate', id=id))
 }
 
-
-#' Reactive Log Visualizer
-#'
-#' Provides an interactive browser-based tool for visualizing reactive
-#' dependencies and execution in your application.
-#'
-#' To use the reactive log visualizer, start with a fresh R session and
-#' run the command `options(shiny.reactlog=TRUE)`; then launch your
-#' application in the usual way (e.g. using [runApp()]). At
-#' any time you can hit Ctrl+F3 (or for Mac users, Command+F3) in your
-#' web browser to launch the reactive log visualization.
-#'
-#' The reactive log visualization only includes reactive activity up
-#' until the time the report was loaded. If you want to see more recent
-#' activity, refresh the browser.
-#'
-#' Note that Shiny does not distinguish between reactive dependencies
-#' that "belong" to one Shiny user session versus another, so the
-#' visualization will include all reactive activity that has taken place
-#' in the process, not just for a particular application or session.
-#'
-#' As an alternative to pressing Ctrl/Command+F3--for example, if you
-#' are using reactives outside of the context of a Shiny
-#' application--you can run the `reactlogShow` function, which will
-#' generate the reactive log visualization as a static HTML file and
-#' launch it in your default browser. In this case, refreshing your
-#' browser will not load new activity into the report; you will need to
-#' call `reactlogShow()` explicitly.
-#'
-#' For security and performance reasons, do not enable
-#' `shiny.reactlog` in production environments. When the option is
-#' enabled, it's possible for any user of your app to see at least some
-#' of the source code of your reactive expressions and observers.
-#'
-#' @name reactlog
-NULL
-
-
-#' @describeIn reactlog Return a list of reactive information.  Can be used in conjunction with
-#'   [reactlog::reactlog_show] to later display the reactlog graph.
-#' @export
-reactlog <- function() {
-  rLog$asList()
-}
-
-#' @describeIn reactlog Display a full reactlog graph for all sessions.
-#' @param time A boolean that specifies whether or not to display the
-#' time that each reactive takes to calculate a result.
-#' @export
-reactlogShow <- function(time = TRUE) {
-  check_reactlog()
-  reactlog::reactlog_show(reactlog(), time = time)
-}
-#' @describeIn reactlog This function is deprecated. You should use [reactlogShow()]
-#' @export
-# legacy purposes
-showReactLog <- function(time = TRUE) {
-  shinyDeprecated(new = "`reactlogShow`", version = "1.2.0")
-  reactlogShow(time = time)
-}
-#' @describeIn reactlog Resets the entire reactlog stack.  Useful for debugging and removing all prior reactive history.
-#' @export
-reactlogReset <- function() {
-  rLog$reset()
-}
-
-# called in "/reactlog" middleware
-renderReactlog <- function(sessionToken = NULL, time = TRUE) {
-  check_reactlog()
-  reactlog::reactlog_render(
-    reactlog(),
-    session_token = sessionToken,
-    time = time
-  )
-}
-check_reactlog <- function() {
-  check_suggested("reactlog", reactlog_version())
-}
-# read reactlog version from description file
-# prevents version mismatch in code and description file
-reactlog_version <- function() {
-  desc <- read.dcf(system.file("DESCRIPTION", package = "shiny", mustWork = TRUE))
-  suggests <- desc[1,"Suggests"][[1]]
-  suggests_pkgs <- strsplit(suggests, "\n")[[1]]
-
-  reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
-  if (length(reactlog_info) == 0) {
-    stop("reactlog can not be found in shiny DESCRIPTION file")
-  }
-
-  reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
-  reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
-  reactlog_info <- sub("^[>= ]*", "", reactlog_info)
-
-  package_version(reactlog_info)
-}
-
-
-RLog <- R6Class(
-  "RLog",
-  portable = FALSE,
-  private = list(
-    option = "shiny.reactlog",
-    msgOption = "shiny.reactlog.console",
-
-    appendEntry = function(domain, logEntry) {
-      if (self$isLogging()) {
-        sessionToken <- if (is.null(domain)) NULL else domain$token
-        logStack$push(c(logEntry, list(
-          session = sessionToken,
-          time = as.numeric(Sys.time())
-        )))
-      }
-      if (!is.null(domain)) domain$reactlog(logEntry)
-    }
-  ),
-  public = list(
-    msg = "<MessageLogger>",
-    logStack = "<Stack>",
-
-    noReactIdLabel = "NoCtxReactId",
-    noReactId = reactIdStr("NoCtxReactId"),
-    dummyReactIdLabel = "DummyReactId",
-    dummyReactId = reactIdStr("DummyReactId"),
-
-    asList = function() {
-      ret <- self$logStack$as_list()
-      attr(ret, "version") <- "1"
-      ret
-    },
-
-    ctxIdStr = function(ctxId) {
-      if (is.null(ctxId) || identical(ctxId, "")) return(NULL)
-      paste0("ctx", ctxId)
-    },
-    namesIdStr = function(reactId) {
-      paste0("names(", reactId, ")")
-    },
-    asListIdStr = function(reactId) {
-      paste0("reactiveValuesToList(", reactId, ")")
-    },
-    asListAllIdStr = function(reactId) {
-      paste0("reactiveValuesToList(", reactId, ", all.names = TRUE)")
-    },
-    keyIdStr = function(reactId, key) {
-      paste0(reactId, "$", key)
-    },
-
-    valueStr = function(value, n = 200) {
-      if (!self$isLogging()) {
-        # return a placeholder string to avoid calling str
-        return("<reactlog is turned off>")
-      }
-      output <- try(silent = TRUE, {
-        # only capture the first level of the object
-        utils::capture.output(utils::str(value, max.level = 1))
-      })
-      outputTxt <- paste0(output, collapse="\n")
-      msg$shortenString(outputTxt, n = n)
-    },
-
-    initialize = function(rlogOption = "shiny.reactlog", msgOption = "shiny.reactlog.console") {
-      private$option <- rlogOption
-      private$msgOption <- msgOption
-
-      self$reset()
-    },
-    reset = function() {
-      .globals$reactIdCounter <- 0L
-
-      self$logStack <- Stack$new()
-      self$msg <- MessageLogger$new(option = private$msgOption)
-
-      # setup dummy and missing react information
-      self$msg$setReact(force = TRUE, list(reactId = self$noReactId, label = self$noReactIdLabel))
-      self$msg$setReact(force = TRUE, list(reactId = self$dummyReactId, label = self$dummyReactIdLabel))
-    },
-    isLogging = function() {
-      isTRUE(getOption(private$option, FALSE))
-    },
-
-    define = function(reactId, value, label, type, domain) {
-      valueStr <- self$valueStr(value)
-      if (msg$hasReact(reactId)) {
-        stop("react definition for id: ", reactId, " already found!!", "Label: ", label, "Type: ", type)
-      }
-      msg$setReact(list(reactId = reactId, label = label))
-      msg$log("define:", msg$reactStr(reactId), msg$typeStr(type = type), msg$valueStr(valueStr))
-      private$appendEntry(domain, list(
-        action = "define",
-        reactId = reactId,
-        label = msg$shortenString(label),
-        type = type,
-        value = valueStr
-      ))
-    },
-    defineNames = function(reactId, value, label, domain) {
-      self$define(self$namesIdStr(reactId), value, self$namesIdStr(label), "reactiveValuesNames", domain)
-    },
-    defineAsList = function(reactId, value, label, domain) {
-      self$define(self$asListIdStr(reactId), value, self$asListIdStr(label), "reactiveValuesAsList", domain)
-    },
-    defineAsListAll = function(reactId, value, label, domain) {
-      self$define(self$asListAllIdStr(reactId), value, self$asListAllIdStr(label), "reactiveValuesAsListAll", domain)
-    },
-    defineKey = function(reactId, value, key, label, domain) {
-      self$define(self$keyIdStr(reactId, key), value, self$keyIdStr(label, key), "reactiveValuesKey", domain)
-    },
-    defineObserver = function(reactId, label, domain) {
-      self$define(reactId, value = NULL, label, "observer", domain)
-    },
-
-    dependsOn = function(reactId, depOnReactId, ctxId, domain) {
-      if (is.null(reactId)) return()
-      ctxId <- ctxIdStr(ctxId)
-      msg$log("dependsOn:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
-      private$appendEntry(domain, list(
-        action = "dependsOn",
-        reactId = reactId,
-        depOnReactId = depOnReactId,
-        ctxId = ctxId
-      ))
-    },
-    dependsOnKey = function(reactId, depOnReactId, key, ctxId, domain) {
-      self$dependsOn(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
-    },
-
-    dependsOnRemove = function(reactId, depOnReactId, ctxId, domain) {
-      ctxId <- self$ctxIdStr(ctxId)
-      msg$log("dependsOnRemove:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
-      private$appendEntry(domain, list(
-        action = "dependsOnRemove",
-        reactId = reactId,
-        depOnReactId = depOnReactId,
-        ctxId = ctxId
-      ))
-    },
-    dependsOnKeyRemove = function(reactId, depOnReactId, key, ctxId, domain) {
-      self$dependsOnRemove(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
-    },
-
-    createContext = function(ctxId, label, type, prevCtxId, domain) {
-      ctxId <- self$ctxIdStr(ctxId)
-      prevCtxId <- self$ctxIdStr(prevCtxId)
-      msg$log("createContext:", msg$ctxPrevCtxStr(preCtxIdTxt = " ", ctxId, prevCtxId, type))
-      private$appendEntry(domain, list(
-        action = "createContext",
-        ctxId = ctxId,
-        label = msg$shortenString(label),
-        type = type,
-        prevCtxId = prevCtxId,
-        srcref = as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile")
-      ))
-    },
-
-    enter = function(reactId, ctxId, type, domain) {
-      ctxId <- self$ctxIdStr(ctxId)
-      if (identical(type, "isolate")) {
-        msg$log("isolateEnter:", msg$reactStr(reactId), msg$ctxStr(ctxId))
-        msg$depthIncrement()
-        private$appendEntry(domain, list(
-          action = "isolateEnter",
-          reactId = reactId,
-          ctxId = ctxId
-        ))
-      } else {
-        msg$log("enter:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
-        msg$depthIncrement()
-        private$appendEntry(domain, list(
-          action = "enter",
-          reactId = reactId,
-          ctxId = ctxId,
-          type = type
-        ))
-      }
-    },
-    exit = function(reactId, ctxId, type, domain) {
-      ctxId <- self$ctxIdStr(ctxId)
-      if (identical(type, "isolate")) {
-        msg$depthDecrement()
-        msg$log("isolateExit:", msg$reactStr(reactId), msg$ctxStr(ctxId))
-        private$appendEntry(domain, list(
-          action = "isolateExit",
-          reactId = reactId,
-          ctxId = ctxId
-        ))
-      } else {
-        msg$depthDecrement()
-        msg$log("exit:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
-        private$appendEntry(domain, list(
-          action = "exit",
-          reactId = reactId,
-          ctxId = ctxId,
-          type = type
-        ))
-      }
-    },
-
-    valueChange = function(reactId, value, domain) {
-      valueStr <- self$valueStr(value)
-      msg$log("valueChange:", msg$reactStr(reactId), msg$valueStr(valueStr))
-      private$appendEntry(domain, list(
-        action = "valueChange",
-        reactId = reactId,
-        value = valueStr
-      ))
-    },
-    valueChangeNames = function(reactId, nameValues, domain) {
-      self$valueChange(self$namesIdStr(reactId), nameValues, domain)
-    },
-    valueChangeAsList = function(reactId, listValue, domain) {
-      self$valueChange(self$asListIdStr(reactId), listValue, domain)
-    },
-    valueChangeAsListAll = function(reactId, listValue, domain) {
-      self$valueChange(self$asListAllIdStr(reactId), listValue, domain)
-    },
-    valueChangeKey = function(reactId, key, value, domain) {
-      self$valueChange(self$keyIdStr(reactId, key), value, domain)
-    },
-
-
-    invalidateStart = function(reactId, ctxId, type, domain) {
-      ctxId <- self$ctxIdStr(ctxId)
-      if (identical(type, "isolate")) {
-        msg$log("isolateInvalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId))
-        msg$depthIncrement()
-        private$appendEntry(domain, list(
-          action = "isolateInvalidateStart",
-          reactId = reactId,
-          ctxId = ctxId
-        ))
-      } else {
-        msg$log("invalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
-        msg$depthIncrement()
-        private$appendEntry(domain, list(
-          action = "invalidateStart",
-          reactId = reactId,
-          ctxId = ctxId,
-          type = type
-        ))
-      }
-    },
-    invalidateEnd = function(reactId, ctxId, type, domain) {
-      ctxId <- self$ctxIdStr(ctxId)
-      if (identical(type, "isolate")) {
-        msg$depthDecrement()
-        msg$log("isolateInvalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId))
-        private$appendEntry(domain, list(
-          action = "isolateInvalidateEnd",
-          reactId = reactId,
-          ctxId = ctxId
-        ))
-      } else {
-        msg$depthDecrement()
-        msg$log("invalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
-        private$appendEntry(domain, list(
-          action = "invalidateEnd",
-          reactId = reactId,
-          ctxId = ctxId,
-          type = type
-        ))
-      }
-    },
-
-    invalidateLater = function(reactId, runningCtx, millis, domain) {
-      msg$log("invalidateLater: ", millis, "ms", msg$reactStr(reactId), msg$ctxStr(runningCtx))
-      private$appendEntry(domain, list(
-        action = "invalidateLater",
-        reactId = reactId,
-        ctxId = runningCtx,
-        millis = millis
-      ))
-    },
-
-    idle = function(domain = NULL) {
-      msg$log("idle")
-      private$appendEntry(domain, list(
-        action = "idle"
-      ))
-    },
-
-    asyncStart = function(domain = NULL) {
-      msg$log("asyncStart")
-      private$appendEntry(domain, list(
-        action = "asyncStart"
-      ))
-    },
-    asyncStop = function(domain = NULL) {
-      msg$log("asyncStop")
-      private$appendEntry(domain, list(
-        action = "asyncStop"
-      ))
-    },
-
-    freezeReactiveVal = function(reactId, domain) {
-      msg$log("freeze:", msg$reactStr(reactId))
-      private$appendEntry(domain, list(
-        action = "freeze",
-        reactId = reactId
-      ))
-    },
-    freezeReactiveKey = function(reactId, key, domain) {
-      self$freezeReactiveVal(self$keyIdStr(reactId, key), domain)
-    },
-
-    thawReactiveVal = function(reactId, domain) {
-      msg$log("thaw:", msg$reactStr(reactId))
-      private$appendEntry(domain, list(
-        action = "thaw",
-        reactId = reactId
-      ))
-    },
-    thawReactiveKey = function(reactId, key, domain) {
-      self$thawReactiveVal(self$keyIdStr(reactId, key), domain)
-    },
-
-    userMark = function(domain = NULL) {
-      msg$log("userMark")
-      private$appendEntry(domain, list(
-        action = "userMark"
-      ))
-    }
-
-  )
-)
-
-MessageLogger = R6Class(
-  "MessageLogger",
-  portable = FALSE,
-  public = list(
-    depth = 0L,
-    reactCache = list(),
-    option = "shiny.reactlog.console",
-
-    initialize = function(option = "shiny.reactlog.console", depth = 0L) {
-      if (!missing(depth)) self$depth <- depth
-      if (!missing(option)) self$option <- option
-    },
-
-    isLogging = function() {
-      isTRUE(getOption(self$option))
-    },
-    isNotLogging = function() {
-      ! isTRUE(getOption(self$option))
-    },
-    depthIncrement = function() {
-      if (self$isNotLogging()) return(NULL)
-      self$depth <- self$depth + 1L
-    },
-    depthDecrement = function() {
-      if (self$isNotLogging()) return(NULL)
-      self$depth <- self$depth - 1L
-    },
-    hasReact = function(reactId) {
-      if (self$isNotLogging()) return(FALSE)
-      !is.null(self$getReact(reactId))
-    },
-    getReact = function(reactId, force = FALSE) {
-      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
-      self$reactCache[[reactId]]
-    },
-    setReact = function(reactObj, force = FALSE) {
-      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
-      self$reactCache[[reactObj$reactId]] <- reactObj
-    },
-    shortenString = function(txt, n = 250) {
-      if (is.null(txt) || isTRUE(is.na(txt))) {
-        return("")
-      }
-      if (nchar(txt) > n) {
-        return(
-          paste0(substr(txt, 1, n - 3), "...")
-        )
-      }
-      return(txt)
-    },
-    singleLine = function(txt) {
-      gsub("[^\\]\\n", "\\\\n", txt)
-    },
-    valueStr = function(valueStr) {
-      paste0(
-        " '",  self$shortenString(self$singleLine(valueStr)), "'"
-      )
-    },
-    reactStr = function(reactId) {
-      if (self$isNotLogging()) return(NULL)
-      reactInfo <- self$getReact(reactId)
-      if (is.null(reactInfo)) return(" <UNKNOWN_REACTID>")
-      paste0(
-        " ", reactInfo$reactId, ":'", self$shortenString(self$singleLine(reactInfo$label)), "'"
-      )
-    },
-    typeStr = function(type = NULL) {
-      self$ctxStr(ctxId = NULL, type = type)
-    },
-    ctxStr = function(ctxId = NULL, type = NULL) {
-      if (self$isNotLogging()) return(NULL)
-      self$ctxPrevCtxStr(ctxId = ctxId, prevCtxId = NULL, type = type)
-    },
-    ctxPrevCtxStr = function(ctxId = NULL, prevCtxId = NULL, type = NULL, preCtxIdTxt = " in ") {
-      if (self$isNotLogging()) return(NULL)
-      paste0(
-        if (!is.null(ctxId)) paste0(preCtxIdTxt, ctxId),
-        if (!is.null(prevCtxId)) paste0(" from ", prevCtxId),
-        if (!is.null(type) && !identical(type, "other")) paste0(" - ", type)
-      )
-    },
-    log = function(...) {
-      if (self$isNotLogging()) return(NULL)
-      msg <- paste0(
-        paste0(rep("= ", depth), collapse = ""), "- ", paste0(..., collapse = ""),
-        collapse = ""
-      )
-      message(msg)
-    }
-  )
-)
-
-#' @include stack.R
-rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")
+.graphEnv <- new.env()
+.graphEnv$log <- list()

R/history.R

@@ -1,95 +0,0 @@
-
-#' @include reactive-domains.R
-NULL
-
-#' @include reactives.R
-NULL
-
-#' Get the query string / hash component from the URL
-#'
-#' Two user friendly wrappers for getting the query string and the hash
-#' component from the app's URL.
-#'
-#' These can be particularly useful if you want to display different content
-#' depending on the values in the query string / hash (e.g. instead of basing
-#' the conditional on an input or a calculated reactive, you can base it on the
-#' query string). However, note that, if you're changing the query string / hash
-#' programatically from within the server code, you must use
-#' `updateQueryString(_yourNewQueryString_, mode = "push")`. The default
-#' `mode` for `updateQueryString` is `"replace"`, which doesn't
-#' raise any events, so any observers or reactives that depend on it will
-#' *not* get triggered. However, if you're changing the query string / hash
-#' directly by typing directly in the browser and hitting enter, you don't have
-#' to worry about this.
-#'
-#' @param session	A Shiny session object.
-#'
-#' @return For `getQueryString`, a named list. For example, the query
-#'   string `?param1=value1&param2=value2` becomes `list(param1 =
-#'   value1, param2 = value2)`. For `getUrlHash`, a character vector with
-#'   the hash (including the leading `#` symbol).
-#'
-#' @seealso [updateQueryString()]
-#'
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'
-#'   ## App 1: getQueryString
-#'   ## Printing the value of the query string
-#'   ## (Use the back and forward buttons to see how the browser
-#'   ## keeps a record of each state)
-#'   shinyApp(
-#'     ui = fluidPage(
-#'       textInput("txt", "Enter new query string"),
-#'       helpText("Format: ?param1=val1&param2=val2"),
-#'       actionButton("go", "Update"),
-#'       hr(),
-#'       verbatimTextOutput("query")
-#'     ),
-#'     server = function(input, output, session) {
-#'       observeEvent(input$go, {
-#'         updateQueryString(input$txt, mode = "push")
-#'       })
-#'       output$query <- renderText({
-#'         query <- getQueryString()
-#'         queryText <- paste(names(query), query,
-#'                        sep = "=", collapse=", ")
-#'         paste("Your query string is:\n", queryText)
-#'       })
-#'     }
-#'   )
-#'
-#'   ## App 2: getUrlHash
-#'   ## Printing the value of the URL hash
-#'   ## (Use the back and forward buttons to see how the browser
-#'   ## keeps a record of each state)
-#'   shinyApp(
-#'     ui = fluidPage(
-#'       textInput("txt", "Enter new hash"),
-#'       helpText("Format: #hash"),
-#'       actionButton("go", "Update"),
-#'       hr(),
-#'       verbatimTextOutput("hash")
-#'     ),
-#'     server = function(input, output, session) {
-#'       observeEvent(input$go, {
-#'         updateQueryString(input$txt, mode = "push")
-#'       })
-#'       output$hash <- renderText({
-#'         hash <- getUrlHash()
-#'         paste("Your hash is:\n", hash)
-#'       })
-#'     }
-#'   )
-#' }
-#' @export
-getQueryString <- function(session = getDefaultReactiveDomain()) {
-  parseQueryString(session$clientData$url_search)
-}
-
-#' @rdname getQueryString
-#' @export
-getUrlHash <- function(session = getDefaultReactiveDomain()) {
-  session$clientData$url_hash
-}

R/hooks.R

@@ -1,24 +0,0 @@
-
-
-# Call an application hook. Application hooks are provided so that front ends
-# can know when a Shiny application is running:
-#
-# shiny.onAppStart -- called when an application begins running
-# shiny.onAppStop -- called when an appliation stops
-#
-# Both hooks are passed the url where the application is accessible (appUrl).
-# Note that the appUrl can be NULL if the application was run on a UNIX domain
-# socket rather than a TCP/IP port/
-callAppHook <- function(name, appUrl) {
-  for (hook in getHooksList(paste0("shiny.", name)))
-    hook(appUrl)
-}
-
-# The value for getHook can be a single function or a list of functions,
-# This function ensures that the result can always be processed as a list
-getHooksList <- function(name) {
-  hooks <- getHook(name)
-  if (!is.list(hooks))
-    hooks <- list(hooks)
-  hooks
-}

R/html-deps.R

@@ -1,56 +0,0 @@
-#' Create a web dependency
-#'
-#' Ensure that a file-based HTML dependency (from the htmltools package) can be
-#' served over Shiny's HTTP server. This function works by using
-#' [addResourcePath()] to map the HTML dependency's directory to a
-#' URL.
-#'
-#' @param dependency A single HTML dependency object, created using
-#'   [htmltools::htmlDependency()]. If the `src` value is named,
-#'   then `href` and/or `file` names must be present.
-#' @param scrubFile If TRUE (the default), remove `src$file` for the
-#'   dependency. This prevents the local file path from being sent to the client
-#'   when dynamic web dependencies are used. If FALSE, don't remove
-#'   `src$file`. Setting it to FALSE should be needed only in very unusual
-#'   cases.
-#'
-#' @return A single HTML dependency object that has an `href`-named element
-#'   in its `src`.
-#' @export
-createWebDependency <- function(dependency, scrubFile = TRUE) {
-  if (is.null(dependency))
-    return(NULL)
-
-  if (!inherits(dependency, "html_dependency"))
-    stop("Unexpected non-html_dependency type")
-
-  if (is.null(dependency$src$href)) {
-    prefix <- paste(dependency$name, "-", dependency$version, sep = "")
-    addResourcePath(prefix, dependency$src$file)
-    dependency$src$href <- prefix
-  }
-
-  # Don't leak local file path to client
-  if (scrubFile)
-    dependency$src$file <- NULL
-
-  return(dependency)
-}
-
-
-# Given a Shiny tag object, process singletons and dependencies. Returns a list
-# with rendered HTML and dependency objects.
-processDeps <- function(tags, session) {
-  ui <- takeSingletons(tags, session$singletons, desingleton=FALSE)$ui
-  ui <- surroundSingletons(ui)
-  dependencies <- lapply(
-    resolveDependencies(findDependencies(ui)),
-    createWebDependency
-  )
-  names(dependencies) <- NULL
-
-  list(
-    html = doRenderTags(ui),
-    deps = dependencies
-  )
-}

R/htmltools.R

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

R/image-interact-opts.R

@@ -1,121 +0,0 @@
-#' Control interactive plot point events
-#'
-#' These functions give control over the `click`, `dblClick` and
-#' `hover` events generated by [imageOutput()] and [plotOutput()].
-#'
-#' @param id Input value name. For example, if the value is `"plot_click"`,
-#'   then the event data will be available as `input$plot_click`.
-#' @param clip Should the click area be clipped to the plotting area? If
-#'   `FALSE`, then the server will receive click events even when the mouse is
-#'   outside the plotting area, as long as it is still inside the image.
-#' @param delay For `dblClickOpts()`: the maximum delay (in ms) between a
-#'   pair clicks for them to be counted as a double-click.
-#'
-#'   For `hoverOpts()`: how long to delay (in ms) when debouncing or throttling
-#'   before sending the mouse location to the server.
-#' @param delayType The type of algorithm for limiting the number of hover
-#'   events. Use `"throttle"` to limit the number of hover events to one
-#'   every `delay` milliseconds. Use `"debounce"` to suspend events
-#'   while the cursor is moving, and wait until the cursor has been at rest for
-#'   `delay` milliseconds before sending an event.
-#' @seealso [brushOpts()] for brushing events.
-#' @export
-#' @keywords internal
-clickOpts <- function(id, clip = TRUE) {
-  if (is.null(id))
-    stop("id must not be NULL")
-
-  list(
-    id = id,
-    clip = clip
-  )
-}
-
-
-#' @export
-#' @rdname clickOpts
-dblclickOpts <- function(id, clip = TRUE, delay = 400) {
-  if (is.null(id))
-    stop("id must not be NULL")
-
-  list(
-    id = id,
-    clip = clip,
-    delay = delay
-  )
-}
-
-#' @param nullOutside If `TRUE` (the default), the value will be set to
-#'   `NULL` when the mouse exits the plotting area. If `FALSE`, the
-#'   value will stop changing when the cursor exits the plotting area.
-#' @export
-#' @rdname clickOpts
-hoverOpts <- function(id, delay = 300,
-                      delayType = c("debounce", "throttle"), clip = TRUE,
-                      nullOutside = TRUE) {
-  if (is.null(id))
-    stop("id must not be NULL")
-
-  list(
-    id = id,
-    delay = delay,
-    delayType = match.arg(delayType),
-    clip = clip,
-    nullOutside = nullOutside
-  )
-}
-
-#' Create an object representing brushing options
-#'
-#' This generates an object representing brushing options, to be passed as the
-#' `brush` argument of [imageOutput()] or
-#' [plotOutput()].
-#'
-#' @param id Input value name. For example, if the value is `"plot_brush"`,
-#'   then the coordinates will be available as `input$plot_brush`. Multiple
-#'   `imageOutput`/`plotOutput` calls may share the same `id`
-#'   value; brushing one image or plot will cause any other brushes with the
-#'   same `id` to disappear.
-#' @param fill Fill color of the brush.
-#' @param stroke Outline color of the brush.
-#' @param opacity Opacity of the brush
-#' @param delay How long to delay (in milliseconds) when debouncing or
-#'   throttling, before sending the brush data to the server.
-#' @param delayType The type of algorithm for limiting the number of brush
-#'   events. Use `"throttle"` to limit the number of brush events to one
-#'   every `delay` milliseconds. Use `"debounce"` to suspend events
-#'   while the cursor is moving, and wait until the cursor has been at rest for
-#'   `delay` milliseconds before sending an event.
-#' @param clip Should the brush area be clipped to the plotting area? If FALSE,
-#'   then the user will be able to brush outside the plotting area, as long as
-#'   it is still inside the image.
-#' @param direction The direction for brushing. If `"xy"`, the brush can be
-#'   drawn and moved in both x and y directions. If `"x"`, or `"y"`,
-#'   the brush wil work horizontally or vertically.
-#' @param resetOnNew When a new image is sent to the browser (via
-#'   [renderImage()]), should the brush be reset? The default,
-#'   `FALSE`, is useful if you want to update the plot while keeping the
-#'   brush. Using `TRUE` is useful if you want to clear the brush whenever
-#'   the plot is updated.
-#' @seealso [clickOpts()] for clicking events.
-#' @export
-brushOpts <- function(id, fill = "#9cf", stroke = "#036",
-                      opacity = 0.25, delay = 300,
-                      delayType = c("debounce", "throttle"), clip = TRUE,
-                      direction = c("xy", "x", "y"),
-                      resetOnNew = FALSE) {
-  if (is.null(id))
-    stop("id must not be NULL")
-
-  list(
-    id = id,
-    fill = fill,
-    stroke = stroke,
-    opacity = opacity,
-    delay = delay,
-    delayType = match.arg(delayType),
-    clip = clip,
-    direction = match.arg(direction),
-    resetOnNew = resetOnNew
-  )
-}

R/image-interact.R

@@ -1,478 +0,0 @@
-#' Find rows of data selected on an interactive plot.
-#'
-#' @description
-#' `brushedPoints()` returns rows from a data frame which are under a brush.
-#' `nearPoints()` returns rows from a data frame which are near a click, hover,
-#' or double-click. Alternatively, set `allRows = TRUE` to return all rows from
-#' the input data with an additional column `selected_` that indicates which
-#' rows of the would be selected.
-#'
-#' @section ggplot2:
-#' For plots created with ggplot2, it is not necessary to specify the
-#' column names to `xvar`, `yvar`, `panelvar1`, and `panelvar2` as that
-#' information can be automatically derived from the plot specification.
-#'
-#' Note, however, that this will not work if you use a computed column, like
-#' `aes(speed/2, dist))`. Instead, we recommend that you modify the data
-#' first, and then make the plot with "raw" columns in the modified data.
-#'
-#' @section Brushing:
-#' If x or y column is a factor, then it will be coerced to an integer vector.
-#' If it is a character vector, then it will be coerced to a factor and then
-#' integer vector. This means that the brush will be considered to cover a
-#' given character/factor value when it covers the center value.
-#'
-#' If the brush is operating in just the x or y directions (e.g., with
-#' `brushOpts(direction = "x")`, then this function will filter out points
-#' using just the x or y variable, whichever is appropriate.
-#'
-#' @returns
-#' A data frame based on `df`, containing the observations selected by the
-#' brush or near the click event. For `nearPoints()`, the rows will be sorted
-#' by distance to the event.
-#'
-#' If `allRows = TRUE`, then all rows will returned, along with a new
-#' `selected_` column that indicates whether or not the point was selected.
-#' The output from `nearPoints()` will no longer be sorted, but you can
-#' set `addDist = TRUE` to get an additional column that gives the pixel
-#' distance to the pointer.
-#'
-#' @param df A data frame from which to select rows.
-#' @param brush,coordinfo The data from a brush or click/dblclick/hover event
-#'   e.g. `input$plot_brush`, `input$plot_click`.
-#' @param xvar,yvar A string giving the name of the variable on the x or y axis.
-#'   These are only required for base graphics, and must be the name of
-#'   a column in `df`.
-#' @param panelvar1,panelvar2 A string giving the name of a panel variable.
-#'   For expert use only; in most cases these will be automatically
-#'   derived from the ggplot2 spec.
-#' @param allRows If `FALSE` (the default) return a data frame containing
-#'   the selected rows. If `TRUE`, the input data frame will have a new
-#'   column, `selected_`, which indicates whether the row was selected or not.
-#' @param threshold A maximum distance (in pixels) to the pointer location.
-#'   Rows in the data frame will be selected if the distance to the pointer is
-#'   less than `threshold`.
-#' @param maxpoints Maximum number of rows to return. If `NULL` (the default),
-#'   will return all rows within the threshold distance.
-#' @param addDist If TRUE, add a column named `dist_` that contains the
-#'   distance from the coordinate to the point, in pixels. When no pointer
-#'   event has yet occurred, the value of `dist_` will be `NA`.
-#' @seealso [plotOutput()] for example usage.
-#' @export
-#' @examples
-#' \dontrun{
-#' # Note that in practice, these examples would need to go in reactives
-#' # or observers.
-#'
-#' # This would select all points within 5 pixels of the click
-#' nearPoints(mtcars, input$plot_click)
-#'
-#' # Select just the nearest point within 10 pixels of the click
-#' nearPoints(mtcars, input$plot_click, threshold = 10, maxpoints = 1)
-#'
-#' }
-brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
-                          panelvar1 = NULL, panelvar2 = NULL,
-                          allRows = FALSE) {
-  if (is.null(brush)) {
-    if (allRows)
-      df$selected_ <- FALSE
-    else
-      df <- df[0, , drop = FALSE]
-
-    return(df)
-  }
-
-  if (is.null(brush$xmin)) {
-    stop("brushedPoints requires a brush object with xmin, xmax, ymin, and ymax.")
-  }
-
-  # Which direction(s) the brush is selecting over. Direction can be 'x', 'y',
-  # or 'xy'.
-  use_x <- grepl("x", brush$direction)
-  use_y <- grepl("y", brush$direction)
-
-  # Try to extract vars from brush object
-  xvar      <- xvar      %OR% brush$mapping$x
-  yvar      <- yvar      %OR% brush$mapping$y
-  panelvar1 <- panelvar1 %OR% brush$mapping$panelvar1
-  panelvar2 <- panelvar2 %OR% brush$mapping$panelvar2
-
-  # Filter out x and y values
-  keep_rows <- rep(TRUE, nrow(df))
-  if (use_x) {
-    if (is.null(xvar))
-      stop("brushedPoints: not able to automatically infer `xvar` from brush")
-    if (!(xvar %in% names(df)))
-      stop("brushedPoints: `xvar` ('", xvar ,"')  not in names of input")
-    keep_rows <- keep_rows & within_brush(df[[xvar]], brush, "x")
-  }
-  if (use_y) {
-    if (is.null(yvar))
-      stop("brushedPoints: not able to automatically infer `yvar` from brush")
-    if (!(yvar %in% names(df)))
-      stop("brushedPoints: `yvar` ('", yvar ,"') not in names of input")
-    keep_rows <- keep_rows & within_brush(df[[yvar]], brush, "y")
-  }
-
-  # Find which rows are matches for the panel vars (if present)
-  if (!is.null(panelvar1))
-    keep_rows <- keep_rows & panelMatch(brush$panelvar1, df[[panelvar1]])
-  if (!is.null(panelvar2))
-    keep_rows <- keep_rows & panelMatch(brush$panelvar2, df[[panelvar2]])
-
-  if (allRows) {
-    df$selected_ <- keep_rows
-    df
-  } else {
-    df[keep_rows, , drop = FALSE]
-  }
-}
-
-# The `brush` data structure will look something like the examples below.
-# For base graphics, `mapping` is empty, and there are no panelvars:
-# List of 8
-#  $ xmin   : num 3.73
-#  $ xmax   : num 4.22
-#  $ ymin   : num 13.9
-#  $ ymax   : num 19.8
-#  $ coords_css:List of 4
-#   ..$ xmin: int 260
-#   ..$ xmax: int 298
-#   ..$ ymin: num 112
-#   ..$ ymax: num 205
-#  $ coords_img:List of 4
-#   ..$ xmin: int 325
-#   ..$ xmax: num 372
-#   ..$ ymin: num 140
-#   ..$ ymax: num 257
-#  $ img_css_ratio:List of 2
-#   ..$ x: num 1.25
-#   ..$ y: num 1.25
-#  $ mapping: Named list()
-#  $ domain :List of 4
-#   ..$ left  : num 1.36
-#   ..$ right : num 5.58
-#   ..$ bottom: num 9.46
-#   ..$ top   : num 34.8
-#  $ range  :List of 4
-#   ..$ left  : num 58
-#   ..$ right : num 429
-#   ..$ bottom: num 226
-#   ..$ top   : num 58
-#  $ log    :List of 2
-#   ..$ x: NULL
-#   ..$ y: NULL
-#  $ direction: chr "y"
-#
-# For ggplot2, the mapping vars usually will be included, and if faceting is
-# used, they will be listed as panelvars:
-# List of 10
-#  $ xmin     : num 3.18
-#  $ xmax     : num 3.78
-#  $ ymin     : num 17.1
-#  $ ymax     : num 20.4
-#  $ panelvar1: int 6
-#  $ panelvar2: int 0
-#  $ coords_css:List of 4
-#   ..$ xmin: int 260
-#   ..$ xmax: int 298
-#   ..$ ymin: num 112
-#   ..$ ymax: num 205
-#  $ coords_img:List of 4
-#   ..$ xmin: int 325
-#   ..$ xmax: num 372
-#   ..$ ymin: num 140
-#   ..$ ymax: num 257
-#  $ img_css_ratio:List of 2
-#   ..$ x: num 1.25
-#   ..$ y: num 1.25
-#  $ mapping  :List of 4
-#   ..$ x        : chr "wt"
-#   ..$ y        : chr "mpg"
-#   ..$ panelvar1: chr "cyl"
-#   ..$ panelvar2: chr "am"
-#  $ domain   :List of 4
-#   ..$ left  : num 1.32
-#   ..$ right : num 5.62
-#   ..$ bottom: num 9.22
-#   ..$ top   : num 35.1
-#  $ range    :List of 4
-#   ..$ left  : num 172
-#   ..$ right : num 300
-#   ..$ bottom: num 144
-#   ..$ top   : num 28.5
-#  $ log      :List of 2
-#   ..$ x: NULL
-#   ..$ y: NULL
-#  $ direction: chr "y"
-
-
-#' @export
-#' @rdname brushedPoints
-nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
-                       panelvar1 = NULL, panelvar2 = NULL,
-                       threshold = 5, maxpoints = NULL, addDist = FALSE,
-                       allRows = FALSE) {
-  if (is.null(coordinfo)) {
-    if (addDist)
-      df$dist_ <- NA_real_
-
-    if (allRows)
-      df$selected_ <- FALSE
-    else
-      df <- df[0, , drop = FALSE]
-
-    return(df)
-  }
-
-  if (is.null(coordinfo$x)) {
-    stop("nearPoints requires a click/hover/double-click object with x and y values.")
-  }
-
-  # Try to extract vars from coordinfo object
-  xvar      <- xvar      %OR% coordinfo$mapping$x
-  yvar      <- yvar      %OR% coordinfo$mapping$y
-  panelvar1 <- panelvar1 %OR% coordinfo$mapping$panelvar1
-  panelvar2 <- panelvar2 %OR% coordinfo$mapping$panelvar2
-
-  if (is.null(xvar))
-    stop("nearPoints: not able to automatically infer `xvar` from coordinfo")
-  if (is.null(yvar))
-    stop("nearPoints: not able to automatically infer `yvar` from coordinfo")
-
-  if (!(xvar %in% names(df)))
-    stop("nearPoints: `xvar` ('", xvar ,"')  not in names of input")
-  if (!(yvar %in% names(df)))
-    stop("nearPoints: `yvar` ('", yvar ,"')  not in names of input")
-
-  # Extract data values from the data frame
-  x <- asNumber(df[[xvar]], coordinfo$domain$discrete_limits$x)
-  y <- asNumber(df[[yvar]], coordinfo$domain$discrete_limits$y)
-
-  # Get the coordinates of the point (in img pixel coordinates)
-  point_img <- coordinfo$coords_img
-
-  # Get coordinates of data points (in img pixel coordinates)
-  data_img <- scaleCoords(x, y, coordinfo)
-
-  # Get x/y distances (in css coordinates)
-  dist_css <- list(
-    x = (data_img$x - point_img$x) / coordinfo$img_css_ratio$x,
-    y = (data_img$y - point_img$y) / coordinfo$img_css_ratio$y
-  )
-
-  # Distances of data points to the target point, in css pixels.
-  dists <- sqrt(dist_css$x^2 + dist_css$y^2)
-
-  if (addDist)
-    df$dist_ <- dists
-
-  keep_rows <- (dists <= threshold)
-
-  # Find which rows are matches for the panel vars (if present)
-  if (!is.null(panelvar1))
-    keep_rows <- keep_rows & panelMatch(coordinfo$panelvar1, df[[panelvar1]])
-  if (!is.null(panelvar2))
-    keep_rows <- keep_rows & panelMatch(coordinfo$panelvar2, df[[panelvar2]])
-
-  # Track the indices to keep
-  keep_idx <- which(keep_rows)
-
-  # Order by distance
-  dists <- dists[keep_idx]
-  keep_idx <- keep_idx[order(dists)]
-
-  # Keep max number of rows
-  if (!is.null(maxpoints) && length(keep_idx) > maxpoints) {
-    keep_idx <- keep_idx[seq_len(maxpoints)]
-  }
-
-  if (allRows) {
-    # Add selected_ column if needed
-    df$selected_ <- FALSE
-    df$selected_[keep_idx] <- TRUE
-
-  } else {
-    # If we don't keep all rows, return just the selected rows, sorted by
-    # distance.
-    df <- df[keep_idx, , drop = FALSE]
-  }
-
-  df
-}
-
-# The coordinfo data structure will look something like the examples below.
-# For base graphics, `mapping` is empty, and there are no panelvars:
-# List of 7
-#  $ x         : num 4.37
-#  $ y         : num 12
-#  $ coords_css:List of 2
-#   ..$ x: int 286
-#   ..$ y: int 192
-#  $ coords_img:List of 2
-#   ..$ x: num 358
-#   ..$ y: int 240
-#  $ img_css_ratio:List of 2
-#   ..$ x: num 1.25
-#   ..$ y: num 1.25
-#  $ mapping   : Named list()
-#  $ domain    :List of 4
-#   ..$ left  : num 1.36
-#   ..$ right : num 5.58
-#   ..$ bottom: num 9.46
-#   ..$ top   : num 34.8
-#  $ range     :List of 4
-#   ..$ left  : num 58
-#   ..$ right : num 429
-#   ..$ bottom: num 226
-#   ..$ top   : num 58
-#  $ log       :List of 2
-#   ..$ x: NULL
-#   ..$ y: NULL
-#  $ .nonce    : num 0.343
-#
-# For ggplot2, the mapping vars usually will be included, and if faceting is
-# used, they will be listed as panelvars:
-# List of 9
-#  $ x         : num 3.78
-#  $ y         : num 17.1
-#  $ coords_css:List of 2
-#   ..$ x: int 286
-#   ..$ y: int 192
-#  $ coords_img:List of 2
-#   ..$ x: num 358
-#   ..$ y: int 240
-#  $ img_css_ratio:List of 2
-#   ..$ x: num 1.25
-#   ..$ y: num 1.25
-#  $ panelvar1 : int 6
-#  $ panelvar2 : int 0
-#  $ mapping   :List of 4
-#   ..$ x        : chr "wt"
-#   ..$ y        : chr "mpg"
-#   ..$ panelvar1: chr "cyl"
-#   ..$ panelvar2: chr "am"
-#  $ domain    :List of 4
-#   ..$ left  : num 1.32
-#   ..$ right : num 5.62
-#   ..$ bottom: num 9.22
-#   ..$ top   : num 35.1
-#  $ range     :List of 4
-#   ..$ left  : num 172
-#   ..$ right : num 300
-#   ..$ bottom: num 144
-#   ..$ top   : num 28.5
-#  $ log       :List of 2
-#   ..$ x: NULL
-#   ..$ y: NULL
-#  $ .nonce    : num 0.603
-
-# Helper to determine if data values are within the limits of
-# an input brush
-within_brush <- function(vals, brush, var = "x") {
-  var <- match.arg(var, c("x", "y"))
-  vals <- asNumber(vals, brush$domain$discrete_limits[[var]])
-  # It's possible for a non-missing data values to not
-  # map to the axis limits, for example:
-  # https://github.com/rstudio/shiny/pull/2410#issuecomment-488100881
-  !is.na(vals) &
-    vals >= brush[[paste0(var, "min")]] &
-    vals <= brush[[paste0(var, "max")]]
-}
-
-# Coerce various types of variables to numbers. This works for Date, POSIXt,
-# characters, and factors. Used because the mouse coords are numeric.
-# The `levels` argument should be used when mapping this variable to
-# a known set of discrete levels, which is needed for ggplot2 since
-# it allows you to control ordering and possible values of a discrete
-# positional scale (#2410)
-asNumber <- function(x, levels = NULL) {
-  if (length(levels)) return(match(x, levels))
-  if (is.character(x)) x <- as.factor(x)
-  if (is.factor(x)) x <- as.integer(x)
-  as.numeric(x)
-}
-
-# 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.numeric(x)) search_value <- as.numeric(search_value)
-  x == search_value
-}
-
-#  ----------------------------------------------------------------------------
-# Scaling functions
-# These functions have direct analogs in Javascript code, except these are
-# vectorized for x and y.
-
-# Map a value x from a domain to a range. If clip is true, clip it to the
-# range.
-mapLinear <- function(x, domainMin, domainMax, rangeMin, rangeMax, clip = TRUE) {
-  factor <- (rangeMax - rangeMin) / (domainMax - domainMin)
-  val <- x - domainMin
-  newval <- (val * factor) + rangeMin
-
-  if (clip) {
-    maxval <- max(rangeMax, rangeMin)
-    minval <- min(rangeMax, rangeMin)
-    newval[newval > maxval] <- maxval
-    newval[newval < minval] <- minval
-  }
-  newval
-}
-
-# Scale val from domain to range. If logbase is present, use log scaling.
-scale1D <- function(val, domainMin, domainMax, rangeMin, rangeMax,
-                    logbase = NULL, clip = TRUE) {
-  if (!is.null(logbase))
-    val <- log(val, logbase)
-  mapLinear(val, domainMin, domainMax, rangeMin, rangeMax, clip)
-}
-
-# Inverse scale val, from range to domain. If logbase is present, use inverse
-# log (power) transformation.
-scaleInv1D <- function(val, domainMin, domainMax, rangeMin, rangeMax,
-                       logbase = NULL, clip = TRUE) {
-    res <- mapLinear(val, rangeMin, rangeMax, domainMin, domainMax, clip)
-    if (!is.null(logbase))
-      res <- logbase ^ res
-    res
-}
-
-# Scale x and y coordinates from domain to range, using information in
-# scaleinfo. scaleinfo must contain items $domain, $range, and $log. The
-# scaleinfo object corresponds to one element from the coordmap object generated
-# by getPrevPlotCoordmap or getGgplotCoordmap; it is the scaling information for
-# one panel in a plot.
-scaleCoords <- function(x, y, scaleinfo) {
-  if (is.null(scaleinfo))
-    return(NULL)
-
-  domain <- scaleinfo$domain
-  range <- scaleinfo$range
-  log <- scaleinfo$log
-
-  list(
-    x = scale1D(x, domain$left, domain$right, range$left, range$right, log$x),
-    y = scale1D(y, domain$bottom, domain$top, range$bottom, range$top, log$y)
-  )
-}
-
-# Inverse scale x and y coordinates from range to domain, using information in
-# scaleinfo.
-scaleInvCoords <- function(x, y, scaleinfo) {
-  if (is.null(scaleinfo))
-    return(NULL)
-
-  domain <- scaleinfo$domain
-  range <- scaleinfo$range
-  log <- scaleinfo$log
-
-  list(
-    x = scaleInv1D(x, domain$left, domain$right, range$left, range$right, log$x),
-    y = scaleInv1D(y, domain$bottom, domain$top, range$bottom, range$top, log$y)
-  )
-}

R/imageutils.R

@@ -1,131 +1,56 @@
-startPNG <- function(filename, width, height, res, ...) {
-  # shiny.useragg is an experimental option that isn't officially supported or
-  # documented. It's here in the off chance that someone really wants
-  # to use ragg (say, instead of showtext, for custom font rendering).
-  # In the next shiny release, this option will likely be superseded in
-  # favor of a fully customizable graphics device option
-  if ((getOption('shiny.useragg') %OR% FALSE) && is_available("ragg")) {
-    pngfun <- ragg::agg_png
-  } else if (capabilities("aqua")) {
-    # i.e., png(type = 'quartz')
-    pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) && is_available("Cairo")) {
-    pngfun <- Cairo::CairoPNG
-  } else {
-    # i.e., png(type = 'cairo')
-    pngfun <- grDevices::png
-  }
-
-  args <- rlang::list2(filename=filename, width=width, height=height, res=res, ...)
-
-  # Set a smarter default for the device's bg argument (based on thematic's global state).
-  # Note that, technically, this is really only needed for CairoPNG, since the other
-  # devices allow their bg arg to be overridden by par(bg=...), which thematic does prior
-  # to plot-time, but it shouldn't hurt to inform other the device directly as well
-  if (is.null(args$bg) && isNamespaceLoaded("thematic")) {
-    # TODO: use :: once thematic is on CRAN
-    args$bg <- utils::getFromNamespace("thematic_get_option", "thematic")("bg", "white")
-    # auto vals aren't resolved until plot time, so if we see one, resolve it
-    if (isTRUE("auto" == args$bg)) {
-      args$bg <- getCurrentOutputInfo()[["bg"]]()
-    }
-  }
-
-  # Handle both bg and background device arg
-  # https://github.com/r-lib/ragg/issues/35
-  fmls <- names(formals(pngfun))
-  if (("background" %in% fmls) && (!"bg" %in% fmls)) {
-    if (is.null(args$background)) {
-      args$background <- args$bg
-    }
-    args$bg <- NULL
-  }
-
-  do.call(pngfun, args)
-  # Call plot.new() so that even if no plotting operations are performed at
-  # least we have a blank background. N.B. we need to set the margin to 0
-  # temporarily before plot.new() because when the plot size is small (e.g.
-  # 200x50), we will get an error "figure margin too large", which is triggered
-  # by plot.new() with the default (large) margin. However, this does not
-  # guarantee user's code in func() will not trigger the error -- they may have
-  # to set par(mar = smaller_value) before they draw base graphics.
-  op <- graphics::par(mar = rep(0, 4))
-  tryCatch(
-    graphics::plot.new(),
-    finally = graphics::par(op)
-  )
-
-  grDevices::dev.cur()
-}
-
 #' Run a plotting function and save the output as a PNG
 #'
 #' This function returns the name of the PNG file that it generates. In
-#' essence, it calls `png()`, then `func()`, then `dev.off()`.
-#' So `func` must be a function that will generate a plot when used this
+#' essence, it calls \code{png()}, then \code{func()}, then \code{dev.off()}.
+#' So \code{func} must be a function that will generate a plot when used this
 #' way.
 #'
 #' For output, it will try to use the following devices, in this order:
-#' quartz (via [grDevices::png()]), then [Cairo::CairoPNG()],
-#' and finally [grDevices::png()]. This is in order of quality of
-#' output. Notably, plain `png` output on Linux and Windows may not
+#' quartz (via \code{\link[grDevices]{png}}), then \code{\link[Cairo]{CairoPNG}},
+#' and finally \code{\link[grDevices]{png}}. This is in order of quality of
+#' output. Notably, plain \code{png} output on Linux and Windows may not
 #' antialias some point shapes, resulting in poor quality output.
 #'
-#' In some cases, `Cairo()` provides output that looks worse than
-#' `png()`. To disable Cairo output for an app, use
-#' `options(shiny.usecairo=FALSE)`.
+#' In some cases, \code{Cairo()} provides output that looks worse than
+#' \code{png()}. To disable Cairo output for an app, use
+#' \code{options(shiny.usecairo=FALSE)}.
 #'
 #' @param func A function that generates a plot.
 #' @param filename The name of the output file. Defaults to a temp file with
-#'   extension `.png`.
+#'   extension \code{.png}.
 #' @param width Width in pixels.
 #' @param height Height in pixels.
 #' @param res Resolution in pixels per inch. This value is passed to
-#'   [grDevices::png()]. Note that this affects the resolution of PNG rendering in
+#'   \code{\link{png}}. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
-#' @param ... Arguments to be passed through to [grDevices::png()].
+#' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
 #'   These can be used to set the width, height, background color, etc.
+#'
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
-  dv <- startPNG(filename, width, height, res, ...)
-  on.exit(grDevices::dev.off(dv), add = TRUE)
-  func()
+  # If quartz is available, use png() (which will default to quartz).
+  # Otherwise, if the Cairo package is installed, use CairoPNG().
+  # Finally, if neither quartz nor Cairo, use png().
+  if (capabilities("aqua")) {
+    pngfun <- png
+  } else if (getOption('shiny.usecairo', TRUE) &&
+             nchar(system.file(package = "Cairo"))) {
+    # Workaround for issue #140: Cairo ignores res and dpi settings. Need to
+    # use regular png function.
+    if (res == 72) {
+      pngfun <- Cairo::CairoPNG
+    } else {
+      pngfun <- png
+    }
+  } else {
+    pngfun <- png
+  }
+
+  do.call(pngfun, c(filename=filename, width=width, height=height, res=res, list(...)))
+  tryCatch(
+    func(),
+    finally=dev.off())
 
   filename
 }
-
-#' @importFrom grDevices dev.set dev.cur
-createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
-  force(which)
-
-  promises::new_promise_domain(
-    wrapOnFulfilled = function(onFulfilled) {
-      force(onFulfilled)
-      function(...) {
-        old <- dev.cur()
-        dev.set(which)
-        on.exit(dev.set(old))
-
-        onFulfilled(...)
-      }
-    },
-    wrapOnRejected = function(onRejected) {
-      force(onRejected)
-      function(...) {
-        old <- dev.cur()
-        dev.set(which)
-        on.exit(dev.set(old))
-
-        onRejected(...)
-      }
-    },
-    wrapSync = function(expr) {
-      old <- dev.cur()
-      dev.set(which)
-      on.exit(dev.set(old))
-
-      force(expr)
-    }
-  )
-}

R/input-action.R

@@ -1,97 +0,0 @@
-#' Action button/link
-#'
-#' Creates an action button or link whose value is initially zero, and increments by one
-#' each time it is pressed.
-#'
-#' @inheritParams textInput
-#' @param label The contents of the button or link--usually a text label, but
-#'   you could also use any other HTML, like an image.
-#' @param icon An optional [icon()] to appear on the button.
-#' @param ... Named attributes to be applied to the button or link.
-#'
-#' @family input elements
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   sliderInput("obs", "Number of observations", 0, 1000, 500),
-#'   actionButton("goButton", "Go!", class = "btn-success"),
-#'   plotOutput("distPlot")
-#' )
-#'
-#' server <- function(input, output) {
-#'   output$distPlot <- renderPlot({
-#'     # Take a dependency on input$goButton. This will run once initially,
-#'     # because the value changes from NULL to 0.
-#'     input$goButton
-#'
-#'     # Use isolate() to avoid dependency on input$obs
-#'     dist <- isolate(rnorm(input$obs))
-#'     hist(dist)
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#' }
-#'
-#' ## Example of adding extra class values
-#' actionButton("largeButton", "Large Primary Button", class = "btn-primary btn-lg")
-#' actionLink("infoLink", "Information Link", class = "btn-info")
-#'
-#' @seealso [observeEvent()] and [eventReactive()]
-#'
-#' @section Server value:
-#' An integer of class `"shinyActionButtonValue"`. This class differs from
-#' ordinary integers in that a value of 0 is considered "falsy".
-#' This implies two things:
-#'   * Event handlers (e.g., [observeEvent()], [eventReactive()]) won't execute on initial load.
-#'   * Input validation (e.g., [req()], [need()]) will fail on initial load.
-#' @export
-actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
-
-  value <- restoreInput(id = inputId, default = NULL)
-
-  tags$button(id=inputId,
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    type="button",
-    class="btn btn-default action-button",
-    `data-val` = value,
-    list(validateIcon(icon), label),
-    ...
-  )
-}
-
-#' @rdname actionButton
-#' @export
-actionLink <- function(inputId, label, icon = NULL, ...) {
-  value <- restoreInput(id = inputId, default = NULL)
-
-  tags$a(id=inputId,
-    href="#",
-    class="action-button",
-    `data-val` = value,
-    list(validateIcon(icon), label),
-    ...
-  )
-}
-
-
-# Check that the icon parameter is valid:
-# 1) Check  if the user wants to actually add an icon:
-#    -- if icon=NULL, it means leave the icon unchanged
-#    -- if icon=character(0), it means don't add an icon or, more usefully,
-#       remove the previous icon
-# 2) If so, check that the icon has the right format (this does not check whether
-# it is a *real* icon - currently that would require a massive cross reference
-# with the "font-awesome" and the "glyphicon" libraries)
-validateIcon <- function(icon) {
-  if (is.null(icon) || identical(icon, character(0))) {
-    return(icon)
-  } else if (inherits(icon, "shiny.tag") && icon$name == "i") {
-    return(icon)
-  } else {
-    stop("Invalid icon. Use Shiny's 'icon()' function to generate a valid icon")
-  }
-}

R/input-checkbox.R

@@ -1,44 +0,0 @@
-#' Checkbox Input Control
-#'
-#' Create a checkbox that can be used to specify logical values.
-#'
-#' @inheritParams textInput
-#' @param value Initial value (`TRUE` or `FALSE`).
-#' @return A checkbox control that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [checkboxGroupInput()], [updateCheckboxInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   checkboxInput("somevalue", "Some value", FALSE),
-#'   verbatimTextOutput("value")
-#' )
-#' server <- function(input, output) {
-#'   output$value <- renderText({ input$somevalue })
-#' }
-#' shinyApp(ui, server)
-#' }
-#'
-#' @section Server value:
-#' `TRUE` if checked, `FALSE` otherwise.
-#'
-#' @export
-checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
-
-  value <- restoreInput(id = inputId, default = value)
-
-  inputTag <- tags$input(id = inputId, type="checkbox")
-  if (!is.null(value) && value)
-    inputTag$attribs$checked <- "checked"
-
-  div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    div(class = "checkbox",
-      tags$label(inputTag, tags$span(label))
-    )
-  )
-}

R/input-checkboxgroup.R

@@ -1,103 +0,0 @@
-#' Checkbox Group Input Control
-#'
-#' Create a group of checkboxes that can be used to toggle multiple choices
-#' independently. The server will receive the input as a character vector of the
-#' selected values.
-#'
-#' @inheritParams textInput
-#' @param choices List of values to show checkboxes for. If elements of the list
-#'   are named then that name rather than the value is displayed to the user. If
-#'   this argument is provided, then `choiceNames` and `choiceValues`
-#'   must not be provided, and vice-versa. The values should be strings; other
-#'   types (such as logicals and numbers) will be coerced to strings.
-#' @param selected The values that should be initially selected, if any.
-#' @param inline If `TRUE`, render the choices inline (i.e. horizontally)
-#' @param choiceNames,choiceValues List of names and values, respectively,
-#'   that are displayed to the user in the app and correspond to the each
-#'   choice (for this reason, `choiceNames` and `choiceValues`
-#'   must have the same length). If either of these arguments is
-#'   provided, then the other *must* be provided and `choices`
-#'   *must not* be provided. The advantage of using both of these over
-#'   a named list for `choices` is that `choiceNames` allows any
-#'   type of UI object to be passed through (tag objects, icons, HTML code,
-#'   ...), instead of just simple text. See Examples.
-#'
-#' @return A list of HTML elements that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [checkboxInput()], [updateCheckboxGroupInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   checkboxGroupInput("variable", "Variables to show:",
-#'                      c("Cylinders" = "cyl",
-#'                        "Transmission" = "am",
-#'                        "Gears" = "gear")),
-#'   tableOutput("data")
-#' )
-#'
-#' server <- function(input, output, session) {
-#'   output$data <- renderTable({
-#'     mtcars[, c("mpg", input$variable), drop = FALSE]
-#'   }, rownames = TRUE)
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#' ui <- fluidPage(
-#'   checkboxGroupInput("icons", "Choose icons:",
-#'     choiceNames =
-#'       list(icon("calendar"), icon("bed"),
-#'            icon("cog"), icon("bug")),
-#'     choiceValues =
-#'       list("calendar", "bed", "cog", "bug")
-#'   ),
-#'   textOutput("txt")
-#' )
-#'
-#' server <- function(input, output, session) {
-#'   output$txt <- renderText({
-#'     icons <- paste(input$icons, collapse = ", ")
-#'     paste("You chose", icons)
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#' }
-#' @section Server value:
-#' Character vector of values corresponding to the boxes that are checked.
-#'
-#' @export
-checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
-  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
-
-  # keep backward compatibility with Shiny < 1.0.1 (see #1649)
-  if (is.null(choices) && is.null(choiceNames) && is.null(choiceValues)) {
-    choices <- character(0)
-  }
-
-  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
-
-  selected <- restoreInput(id = inputId, default = selected)
-
-  # default value if it's not specified
-  if (!is.null(selected)) selected <- as.character(selected)
-
-  options <- generateOptions(inputId, selected, inline,
-    'checkbox', args$choiceNames, args$choiceValues)
-
-  divClass <- "form-group shiny-input-checkboxgroup shiny-input-container"
-  if (inline)
-    divClass <- paste(divClass, "shiny-input-container-inline")
-
-  # return label and select tag
-  tags$div(id = inputId,
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    class = divClass,
-    shinyInputLabel(inputId, label),
-    options
-  )
-}

R/input-date.R

@@ -1,175 +0,0 @@
-#' Create date input
-#'
-#' Creates a text input which, when clicked on, brings up a calendar that
-#' the user can click on to select dates.
-#'
-#' The date `format` string specifies how the date will be displayed in
-#' the browser. It allows the following values:
-#'
-#' \itemize{
-#'   \item `yy` Year without century (12)
-#'   \item `yyyy` Year with century (2012)
-#'   \item `mm` Month number, with leading zero (01-12)
-#'   \item `m` Month number, without leading zero (1-12)
-#'   \item `M` Abbreviated month name
-#'   \item `MM` Full month name
-#'   \item `dd` Day of month with leading zero
-#'   \item `d` Day of month without leading zero
-#'   \item `D` Abbreviated weekday name
-#'   \item `DD` Full weekday name
-#' }
-#'
-#' @inheritParams textInput
-#' @param value The starting date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format. If NULL (the default), will use the current date
-#'   in the client's time zone.
-#' @param min The minimum allowed date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format.
-#' @param max The maximum allowed date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format.
-#' @param format The format of the date to display in the browser. Defaults to
-#'   `"yyyy-mm-dd"`.
-#' @param startview The date range shown when the input object is first clicked.
-#'   Can be "month" (the default), "year", or "decade".
-#' @param weekstart Which day is the start of the week. Should be an integer
-#'   from 0 (Sunday) to 6 (Saturday).
-#' @param language The language used for month and day names. Default is "en".
-#'   Other valid values include "ar", "az", "bg", "bs", "ca", "cs", "cy", "da",
-#'   "de", "el", "en-AU", "en-GB", "eo", "es", "et", "eu", "fa", "fi", "fo",
-#'   "fr-CH", "fr", "gl", "he", "hr", "hu", "hy", "id", "is", "it-CH", "it",
-#'   "ja", "ka", "kh", "kk", "ko", "kr", "lt", "lv", "me", "mk", "mn", "ms",
-#'   "nb", "nl-BE", "nl", "no", "pl", "pt-BR", "pt", "ro", "rs-latin", "rs",
-#'   "ru", "sk", "sl", "sq", "sr-latin", "sr", "sv", "sw", "th", "tr", "uk",
-#'   "vi", "zh-CN", and "zh-TW".
-#' @param autoclose Whether or not to close the datepicker immediately when a
-#'   date is selected.
-#' @param datesdisabled Which dates should be disabled. Either a Date object,
-#' or a string in `yyyy-mm-dd` format.
-#' @param daysofweekdisabled Days of the week that should be disabled. Should be
-#'   a integer vector with values from 0 (Sunday) to 6 (Saturday).
-#'
-#' @family input elements
-#' @seealso [dateRangeInput()], [updateDateInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   dateInput("date1", "Date:", value = "2012-02-29"),
-#'
-#'   # Default value is the date in client's time zone
-#'   dateInput("date2", "Date:"),
-#'
-#'   # value is always yyyy-mm-dd, even if the display format is different
-#'   dateInput("date3", "Date:", value = "2012-02-29", format = "mm/dd/yy"),
-#'
-#'   # Pass in a Date object
-#'   dateInput("date4", "Date:", value = Sys.Date()-10),
-#'
-#'   # Use different language and different first day of week
-#'   dateInput("date5", "Date:",
-#'           language = "ru",
-#'           weekstart = 1),
-#'
-#'   # Start with decade view instead of default month view
-#'   dateInput("date6", "Date:",
-#'             startview = "decade"),
-#'
-#'   # Disable Mondays and Tuesdays.
-#'   dateInput("date7", "Date:", daysofweekdisabled = c(1,2)),
-#'
-#'   # Disable specific dates.
-#'   dateInput("date8", "Date:", value = "2012-02-29",
-#'             datesdisabled = c("2012-03-01", "2012-03-02"))
-#' )
-#'
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#'
-#' @section Server value:
-#' A [Date] vector of length 1.
-#'
-#' @export
-dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
-  format = "yyyy-mm-dd", startview = "month", weekstart = 0,
-  language = "en", width = NULL, autoclose = TRUE,
-  datesdisabled = NULL, daysofweekdisabled = NULL) {
-
-  value <- dateYMD(value, "value")
-  min <- dateYMD(min, "min")
-  max <- dateYMD(max, "max")
-  datesdisabled <- dateYMD(datesdisabled, "datesdisabled")
-
-  value <- restoreInput(id = inputId, default = value)
-
-  tags$div(id = inputId,
-    class = "shiny-date-input form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-
-    shinyInputLabel(inputId, label),
-    tags$input(type = "text",
-               class = "form-control",
-               # `aria-labelledby` attribute is required for accessibility to avoid doubled labels (#2951).
-               `aria-labelledby` = paste0(inputId, "-label"),
-               # title attribute is announced for screen readers for date format.
-               title = paste("Date format:", format),
-               `data-date-language` = language,
-               `data-date-week-start` = weekstart,
-               `data-date-format` = format,
-               `data-date-start-view` = startview,
-               `data-min-date` = min,
-               `data-max-date` = max,
-               `data-initial-date` = value,
-               `data-date-autoclose` = if (autoclose) "true" else "false",
-               `data-date-dates-disabled` =
-                   # Ensure NULL is not sent as `{}` but as 'null'
-                   jsonlite::toJSON(datesdisabled, null = 'null'),
-               `data-date-days-of-week-disabled` =
-                   jsonlite::toJSON(daysofweekdisabled, null = 'null')
-    ),
-    datePickerDependency()
-  )
-}
-
-
-datePickerVersion <- "1.9.0"
-
-datePickerDependency <- function(theme) {
-  list(
-    htmlDependency(
-      name = "bootstrap-datepicker-js",
-      version = datePickerVersion,
-      src = c(href = "shared/datepicker"),
-      script = "js/bootstrap-datepicker.min.js",
-      # Need to enable noConflict mode. See #1346.
-      head = "<script>(function() {
-        var datepicker = $.fn.datepicker.noConflict();
-        $.fn.bsDatepicker = datepicker;
-      })();
-     </script>"
-    ),
-    bootstraplib::bs_dependency_defer(datePickerCSS)
-  )
-}
-
-datePickerCSS <- function(theme) {
-  if (!is_bs_theme(theme)) {
-    return(htmlDependency(
-      name = "bootstrap-datepicker-css",
-      version = datePickerVersion,
-      src = c(href = "shared/datepicker"),
-      stylesheet = "css/bootstrap-datepicker3.min.css"
-    ))
-  }
-
-  scss_file <- system.file(package = "shiny", "www/shared/datepicker/scss/build3.scss")
-
-  bootstraplib::bs_dependency(
-    input = sass::sass_file(scss_file),
-    theme = theme,
-    name = "bootstrap-datepicker",
-    version = datePickerVersion,
-    cache_key_extra = utils::packageVersion("shiny")
-  )
-}

R/input-daterange.R

@@ -1,142 +0,0 @@
-#' Create date range input
-#'
-#' Creates a pair of text inputs which, when clicked on, bring up calendars that
-#' the user can click on to select dates.
-#'
-#' The date `format` string specifies how the date will be displayed in
-#' the browser. It allows the following values:
-#'
-#' \itemize{
-#'   \item `yy` Year without century (12)
-#'   \item `yyyy` Year with century (2012)
-#'   \item `mm` Month number, with leading zero (01-12)
-#'   \item `m` Month number, without leading zero (1-12)
-#'   \item `M` Abbreviated month name
-#'   \item `MM` Full month name
-#'   \item `dd` Day of month with leading zero
-#'   \item `d` Day of month without leading zero
-#'   \item `D` Abbreviated weekday name
-#'   \item `DD` Full weekday name
-#' }
-#'
-#' @inheritParams dateInput
-#' @param start The initial start date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format. If NULL (the default), will use the current
-#'   date in the client's time zone.
-#' @param end The initial end date. Either a Date object, or a string in
-#'   `yyyy-mm-dd` format. If NULL (the default), will use the current
-#'   date in the client's time zone.
-#' @param separator String to display between the start and end input boxes.
-#'
-#' @family input elements
-#' @seealso [dateInput()], [updateDateRangeInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   dateRangeInput("daterange1", "Date range:",
-#'                  start = "2001-01-01",
-#'                  end   = "2010-12-31"),
-#'
-#'   # Default start and end is the current date in the client's time zone
-#'   dateRangeInput("daterange2", "Date range:"),
-#'
-#'   # start and end are always specified in yyyy-mm-dd, even if the display
-#'   # format is different
-#'   dateRangeInput("daterange3", "Date range:",
-#'                  start  = "2001-01-01",
-#'                  end    = "2010-12-31",
-#'                  min    = "2001-01-01",
-#'                  max    = "2012-12-21",
-#'                  format = "mm/dd/yy",
-#'                  separator = " - "),
-#'
-#'   # Pass in Date objects
-#'   dateRangeInput("daterange4", "Date range:",
-#'                  start = Sys.Date()-10,
-#'                  end = Sys.Date()+10),
-#'
-#'   # Use different language and different first day of week
-#'   dateRangeInput("daterange5", "Date range:",
-#'                  language = "de",
-#'                  weekstart = 1),
-#'
-#'   # Start with decade view instead of default month view
-#'   dateRangeInput("daterange6", "Date range:",
-#'                  startview = "decade")
-#' )
-#'
-#' shinyApp(ui, server = function(input, output) { })
-#' }
-#'
-#' @section Server value:
-#' A [Date] vector of length 2.
-#'
-#' @export
-dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
-    min = NULL, max = NULL, format = "yyyy-mm-dd", startview = "month",
-    weekstart = 0, language = "en", separator = " to ", width = NULL,
-    autoclose = TRUE) {
-
-  start <- dateYMD(start, "start")
-  end   <- dateYMD(end, "end")
-  min   <- dateYMD(min, "min")
-  max   <- dateYMD(max, "max")
-
-  restored <- restoreInput(id = inputId, default = list(start, end))
-  start <- restored[[1]]
-  end <- restored[[2]]
-
-  attachDependencies(
-    div(id = inputId,
-      class = "shiny-date-range-input form-group shiny-input-container",
-      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-
-      shinyInputLabel(inputId, label),
-      # input-daterange class is needed for dropdown behavior
-      div(class = "input-daterange input-group input-group-sm",
-        tags$input(
-          class = "form-control",
-          type = "text",
-          # `aria-labelledby` attribute is required for accessibility to avoid doubled labels (#2951).
-          `aria-labelledby` = paste0(inputId, "-label"),
-          # title attribute is announced for screen readers for date format.
-          title = paste("Date format:", format),
-          `data-date-language` = language,
-          `data-date-week-start` = weekstart,
-          `data-date-format` = format,
-          `data-date-start-view` = startview,
-          `data-min-date` = min,
-          `data-max-date` = max,
-          `data-initial-date` = start,
-          `data-date-autoclose` = if (autoclose) "true" else "false"
-        ),
-        # input-group-prepend and input-group-append are for bootstrap 4 forward compat
-        span(class = "input-group-addon input-group-prepend input-group-append",
-          span(class = "input-group-text",
-            separator
-          )
-        ),
-        tags$input(
-          class = "form-control",
-          type = "text",
-          # `aria-labelledby` attribute is required for accessibility to avoid doubled labels (#2951).
-          `aria-labelledby` = paste0(inputId, "-label"),
-          # title attribute is announced for screen readers for date format.
-          title = paste("Date format:", format),
-          `data-date-language` = language,
-          `data-date-week-start` = weekstart,
-          `data-date-format` = format,
-          `data-date-start-view` = startview,
-          `data-min-date` = min,
-          `data-max-date` = max,
-          `data-initial-date` = end,
-          `data-date-autoclose` = if (autoclose) "true" else "false"
-        )
-      )
-    ),
-    datePickerDependency()
-  )
-}

R/input-file.R

@@ -1,128 +0,0 @@
-#' File Upload Control
-#'
-#' Create a file upload control that can be used to upload one or more files.
-#'
-#' Whenever a file upload completes, the corresponding input variable is set
-#' to a dataframe. See the `Server value` section.
-#'
-#' @family input elements
-#'
-#' @inheritParams textInput
-#' @param multiple Whether the user should be allowed to select and upload
-#'   multiple files at once. **Does not work on older browsers, including
-#'   Internet Explorer 9 and earlier.**
-#' @param accept A character vector of "unique file type specifiers" which
-#'   gives the browser a hint as to the type of file the server expects.
-#'   Many browsers use this prevent the user from selecting an invalid file.
-#'
-#'   A unique file type specifier can be:
-#'   * A case insensitive extension like `.csv` or `.rds`.
-#'   * A valid MIME type, like `text/plain` or `application/pdf`
-#'   * One of `audio/*`, `video/*`, or `image/*` meaning any audio, video,
-#'     or image type, respectively.
-#' @param buttonLabel The label used on the button. Can be text or an HTML tag
-#'   object.
-#' @param placeholder The text to show before a file has been uploaded.
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   sidebarLayout(
-#'     sidebarPanel(
-#'       fileInput("file1", "Choose CSV File", accept = ".csv"),
-#'       checkboxInput("header", "Header", TRUE)
-#'     ),
-#'     mainPanel(
-#'       tableOutput("contents")
-#'     )
-#'   )
-#' )
-#'
-#' server <- function(input, output) {
-#'   output$contents <- renderTable({
-#'     file <- input$file1
-#'     ext <- tools::file_ext(file$datapath)
-#'
-#'     req(file)
-#'     validate(need(ext == "csv", "Please upload a csv file"))
-#'
-#'     read.csv(file$datapath, header = input$header)
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#' }
-#'
-#' @section Server value:
-#' A `data.frame` that contains one row for each selected file, and following columns:
-#' \describe{
-#'   \item{`name`}{The filename provided by the web browser. This is
-#'   **not** the path to read to get at the actual data that was uploaded
-#'   (see
-#'   `datapath` column).}
-#'   \item{`size`}{The size of the uploaded data, in
-#'   bytes.}
-#'   \item{`type`}{The MIME type reported by the browser (for example,
-#'   `text/plain`), or empty string if the browser didn't know.}
-#'   \item{`datapath`}{The path to a temp file that contains the data that was
-#'   uploaded. This file may be deleted if the user performs another upload
-#'   operation.}
-#' }
-#'
-#' @export
-fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
-  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
-
-  restoredValue <- restoreInput(id = inputId, default = NULL)
-
-  # Catch potential edge case - ensure that it's either NULL or a data frame.
-  if (!is.null(restoredValue) && !is.data.frame(restoredValue)) {
-    warning("Restored value for ", inputId, " has incorrect format.")
-    restoredValue <- NULL
-  }
-
-  if (!is.null(restoredValue)) {
-    restoredValue <- toJSON(restoredValue, strict_atomic = FALSE)
-  }
-
-  inputTag <- tags$input(
-    id = inputId,
-    name = inputId,
-    type = "file",
-    # Don't use "display: none;" style, which causes keyboard accessibility issue; instead use the following workaround: https://css-tricks.com/places-its-tempting-to-use-display-none-but-dont/
-    style = "position: absolute !important; top: -99999px !important; left: -99999px !important;",
-    `data-restore` = restoredValue
-  )
-
-  if (multiple)
-    inputTag$attribs$multiple <- "multiple"
-  if (length(accept) > 0)
-    inputTag$attribs$accept <- paste(accept, collapse=',')
-
-
-  div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    shinyInputLabel(inputId, label),
-
-    div(class = "input-group",
-      # input-group-prepend is for bootstrap 4 compat
-      tags$label(class = "input-group-btn input-group-prepend",
-        span(class = "btn btn-default btn-file",
-          buttonLabel,
-          inputTag
-        )
-      ),
-      tags$input(type = "text", class = "form-control",
-        placeholder = placeholder, readonly = "readonly"
-      )
-    ),
-
-    tags$div(
-      id=paste(inputId, "_progress", sep=""),
-      class="progress active shiny-file-input-progress",
-      tags$div(class="progress-bar")
-    )
-  )
-}

R/input-numeric.R

@@ -1,52 +0,0 @@
-#' Create a numeric input control
-#'
-#' Create an input control for entry of numeric values
-#'
-#' @inheritParams textInput
-#' @param min Minimum allowed value
-#' @param max Maximum allowed value
-#' @param step Interval to use when stepping between min and max
-#' @return A numeric input control that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [updateNumericInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   numericInput("obs", "Observations:", 10, min = 1, max = 100),
-#'   verbatimTextOutput("value")
-#' )
-#' server <- function(input, output) {
-#'   output$value <- renderText({ input$obs })
-#' }
-#' shinyApp(ui, server)
-#' }
-#'
-#' @section Server value:
-#' A numeric vector of length 1.
-#'
-#' @export
-numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
-  width = NULL) {
-
-  value <- restoreInput(id = inputId, default = value)
-
-  # build input tag
-  inputTag <- tags$input(id = inputId, type = "number", class="form-control",
-                         value = formatNoSci(value))
-  if (!is.na(min))
-    inputTag$attribs$min = min
-  if (!is.na(max))
-    inputTag$attribs$max = max
-  if (!is.na(step))
-    inputTag$attribs$step = step
-
-  div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    shinyInputLabel(inputId, label),
-    inputTag
-  )
-}

R/input-password.R

@@ -1,41 +0,0 @@
-#' Create a password input control
-#'
-#' Create an password control for entry of passwords.
-#'
-#' @inheritParams textInput
-#' @return A text input control that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [updateTextInput()]
-#'
-#' @section Server value:
-#' A character string of the password input. The default value is `""`
-#' unless `value` is provided.
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   passwordInput("password", "Password:"),
-#'   actionButton("go", "Go"),
-#'   verbatimTextOutput("value")
-#' )
-#' server <- function(input, output) {
-#'   output$value <- renderText({
-#'     req(input$go)
-#'     isolate(input$password)
-#'   })
-#' }
-#' shinyApp(ui, server)
-#' }
-#' @export
-passwordInput <- function(inputId, label, value = "", width = NULL,
-                          placeholder = NULL) {
-  div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    shinyInputLabel(inputId, label),
-    tags$input(id = inputId, type="password", class="form-control", value=value,
-               placeholder = placeholder)
-  )
-}

R/input-radiobuttons.R

@@ -1,113 +0,0 @@
-#' Create radio buttons
-#'
-#' Create a set of radio buttons used to select an item from a list.
-#'
-#' If you need to represent a "None selected" state, it's possible to default
-#' the radio buttons to have no options selected by using `selected =
-#' character(0)`. However, this is not recommended, as it gives the user no way
-#' to return to that state once they've made a selection. Instead, consider
-#' having the first of your choices be `c("None selected" = "")`.
-#'
-#' @inheritParams textInput
-#' @param choices List of values to select from (if elements of the list are
-#'   named then that name rather than the value is displayed to the user). If
-#'   this argument is provided, then `choiceNames` and `choiceValues` must not
-#'   be provided, and vice-versa. The values should be strings; other types
-#'   (such as logicals and numbers) will be coerced to strings.
-#' @param selected The initially selected value. If not specified, then it
-#'   defaults to the first item in `choices`. To start with no items selected,
-#'   use `character(0)`.
-#' @param inline If `TRUE`, render the choices inline (i.e. horizontally)
-#' @return A set of radio buttons that can be added to a UI definition.
-#' @param choiceNames,choiceValues List of names and values, respectively, that
-#'   are displayed to the user in the app and correspond to the each choice (for
-#'   this reason, `choiceNames` and `choiceValues` must have the same length).
-#'   If either of these arguments is provided, then the other *must* be provided
-#'   and `choices` *must not* be provided. The advantage of using both of these
-#'   over a named list for `choices` is that `choiceNames` allows any type of UI
-#'   object to be passed through (tag objects, icons, HTML code, ...), instead
-#'   of just simple text. See Examples.
-#'
-#' @family input elements
-#' @seealso [updateRadioButtons()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   radioButtons("dist", "Distribution type:",
-#'                c("Normal" = "norm",
-#'                  "Uniform" = "unif",
-#'                  "Log-normal" = "lnorm",
-#'                  "Exponential" = "exp")),
-#'   plotOutput("distPlot")
-#' )
-#'
-#' server <- function(input, output) {
-#'   output$distPlot <- renderPlot({
-#'     dist <- switch(input$dist,
-#'                    norm = rnorm,
-#'                    unif = runif,
-#'                    lnorm = rlnorm,
-#'                    exp = rexp,
-#'                    rnorm)
-#'
-#'     hist(dist(500))
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#' ui <- fluidPage(
-#'   radioButtons("rb", "Choose one:",
-#'                choiceNames = list(
-#'                  icon("calendar"),
-#'                  HTML("<p style='color:red;'>Red Text</p>"),
-#'                  "Normal text"
-#'                ),
-#'                choiceValues = list(
-#'                  "icon", "html", "text"
-#'                )),
-#'   textOutput("txt")
-#' )
-#'
-#' server <- function(input, output) {
-#'   output$txt <- renderText({
-#'     paste("You chose", input$rb)
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#' }
-#'
-#' @section Server value:
-#'
-#'   A character string containing the value of the selected button.
-#'
-#' @export
-radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
-  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
-
-  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
-
-  selected <- restoreInput(id = inputId, default = selected)
-
-  # default value if it's not specified
-  selected <- if (is.null(selected)) args$choiceValues[[1]] else as.character(selected)
-
-  if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
-
-  options <- generateOptions(inputId, selected, inline,
-    'radio', args$choiceNames, args$choiceValues)
-
-  divClass <- "form-group shiny-input-radiogroup shiny-input-container"
-  if (inline) divClass <- paste(divClass, "shiny-input-container-inline")
-
-  tags$div(id = inputId,
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    class = divClass,
-    shinyInputLabel(inputId, label),
-    options
-  )
-}

R/input-select.R

@@ -1,406 +0,0 @@
-#' Create a select list input control
-#'
-#' Create a select list that can be used to choose a single or multiple items
-#' from a list of values.
-#'
-#' By default, `selectInput()` and `selectizeInput()` use the JavaScript library
-#' \pkg{selectize.js} (<https://github.com/selectize/selectize.js>) instead of
-#' the basic select input element. To use the standard HTML select input
-#' element, use `selectInput()` with `selectize=FALSE`.
-#'
-#' In selectize mode, if the first element in `choices` has a value of `""`, its
-#' name will be treated as a placeholder prompt. For example:
-#' `selectInput("letter", "Letter", c("Choose one" = "", LETTERS))`
-#'
-#' **Performance note:** `selectInput()` and `selectizeInput()` can slow down
-#' significantly when thousands of choices are used; with legacy browsers like
-#' Internet Explorer, the user interface may hang for many seconds. For large
-#' numbers of choices, Shiny offers a "server-side selectize" option that
-#' massively improves performance and efficiency; see
-#' [this selectize article](https://shiny.rstudio.com/articles/selectize.html)
-#' on the Shiny Dev Center for details.
-#'
-#' @inheritParams textInput
-#' @param choices List of values to select from. If elements of the list are
-#'   named, then that name --- rather than the value --- is displayed to the
-#'   user. It's also possible to group related inputs by providing a named list
-#'   whose elements are (either named or unnamed) lists, vectors, or factors. In
-#'   this case, the outermost names will be used as the group labels (leveraging
-#'   the `<optgroup>` HTML tag) for the elements in the respective sublist. See
-#'   the example section for a small demo of this feature.
-#' @param selected The initially selected value (or multiple values if `multiple
-#'   = TRUE`). If not specified then defaults to the first value for
-#'   single-select lists and no values for multiple select lists.
-#' @param multiple Is selection of multiple items allowed?
-#' @param selectize Whether to use \pkg{selectize.js} or not.
-#' @param size Number of items to show in the selection box; a larger number
-#'   will result in a taller box. Not compatible with `selectize=TRUE`.
-#'   Normally, when `multiple=FALSE`, a select input will be a drop-down list,
-#'   but when `size` is set, it will be a box instead.
-#' @return A select list control that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [updateSelectInput()] [varSelectInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' # basic example
-#' shinyApp(
-#'   ui = fluidPage(
-#'     selectInput("variable", "Variable:",
-#'                 c("Cylinders" = "cyl",
-#'                   "Transmission" = "am",
-#'                   "Gears" = "gear")),
-#'     tableOutput("data")
-#'   ),
-#'   server = function(input, output) {
-#'     output$data <- renderTable({
-#'       mtcars[, c("mpg", input$variable), drop = FALSE]
-#'     }, rownames = TRUE)
-#'   }
-#' )
-#'
-#' # demoing group support in the `choices` arg
-#' shinyApp(
-#'   ui = fluidPage(
-#'     selectInput("state", "Choose a state:",
-#'       list(`East Coast` = list("NY", "NJ", "CT"),
-#'            `West Coast` = list("WA", "OR", "CA"),
-#'            `Midwest` = list("MN", "WI", "IA"))
-#'     ),
-#'     textOutput("result")
-#'   ),
-#'   server = function(input, output) {
-#'     output$result <- renderText({
-#'       paste("You chose", input$state)
-#'     })
-#'   }
-#' )
-#' }
-#'
-#' @section Server value: A vector of character strings, usually of length
-#'   1, with the value of the selected items. When `multiple=TRUE` and
-#'   nothing is selected, this value will be `NULL`.
-#'
-#' @export
-selectInput <- function(inputId, label, choices, selected = NULL,
-  multiple = FALSE, selectize = TRUE, width = NULL,
-  size = NULL) {
-
-  selected <- restoreInput(id = inputId, default = selected)
-
-  # resolve names
-  choices <- choicesWithNames(choices)
-
-  # default value if it's not specified
-  if (is.null(selected)) {
-    if (!multiple) selected <- firstChoice(choices)
-  } else selected <- as.character(selected)
-
-  if (!is.null(size) && selectize) {
-    stop("'size' argument is incompatible with 'selectize=TRUE'.")
-  }
-
-  # create select tag and add options
-  selectTag <- tags$select(
-    id = inputId,
-    class = if (!selectize) "form-control",
-    size = size,
-    selectOptions(choices, selected, inputId, selectize)
-  )
-  if (multiple)
-    selectTag$attribs$multiple <- "multiple"
-
-  # return label and select tag
-  res <- div(
-    class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    shinyInputLabel(inputId, label),
-    div(selectTag)
-  )
-
-  if (!selectize) return(res)
-
-  selectizeIt(inputId, res, NULL, nonempty = !multiple && !("" %in% choices))
-}
-
-firstChoice <- function(choices) {
-  if (length(choices) == 0L) return()
-  choice <- choices[[1]]
-  if (is.list(choice)) firstChoice(choice) else choice
-}
-
-# Create tags for each of the options; use <optgroup> if necessary.
-# This returns a HTML string instead of tags for performance reasons.
-selectOptions <- function(choices, selected = NULL, inputId, perfWarning = FALSE) {
-  if (length(choices) >= 1000) {
-    warning("The select input \"", inputId, "\" contains a large number of ",
-      "options; consider using server-side selectize for massively improved ",
-      "performance. See the Details section of the ?selectizeInput help topic.",
-      call. = FALSE)
-  }
-
-  html <- mapply(choices, names(choices), FUN = function(choice, label) {
-    if (is.list(choice)) {
-      # If sub-list, create an optgroup and recurse into the sublist
-      sprintf(
-        '<optgroup label="%s">\n%s\n</optgroup>',
-        htmlEscape(label, TRUE),
-        selectOptions(choice, selected, inputId, perfWarning)
-      )
-
-    } else {
-      # If single item, just return option string
-      sprintf(
-        '<option value="%s"%s>%s</option>',
-        htmlEscape(choice, TRUE),
-        if (choice %in% selected) ' selected' else '',
-        htmlEscape(label)
-      )
-    }
-  })
-
-  HTML(paste(html, collapse = '\n'))
-}
-
-# need <optgroup> when choices contains sub-lists
-needOptgroup <- function(choices) {
-  any(vapply(choices, is.list, logical(1)))
-}
-
-#' @rdname selectInput
-#' @param ... Arguments passed to `selectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}
-#'   for possible options (character option values inside [base::I()] will
-#'   be treated as literal JavaScript code; see [renderDataTable()]
-#'   for details).
-#' @param width The width of the input, e.g. `'400px'`, or `'100%'`;
-#'   see [validateCssUnit()].
-#' @note The selectize input created from `selectizeInput()` allows
-#'   deletion of the selected option even in a single select input, which will
-#'   return an empty string as its value. This is the default behavior of
-#'   \pkg{selectize.js}. However, the selectize input created from
-#'   `selectInput(..., selectize = TRUE)` will ignore the empty string
-#'   value when it is a single choice input and the empty string is not in the
-#'   `choices` argument. This is to keep compatibility with
-#'   `selectInput(..., selectize = FALSE)`.
-#' @export
-selectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
-  selectizeIt(
-    inputId,
-    selectInput(inputId, ..., selectize = FALSE, width = width),
-    options
-  )
-}
-
-# given a select input and its id, selectize it
-selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
-  # Make sure accessibility plugin is included
-  if (!('selectize-plugin-a11y' %in% options$plugins)) {
-    options$plugins <- c(options$plugins, list('selectize-plugin-a11y'))
-  }
-
-  res <- checkAsIs(options)
-
-  selectizeDep <- selectizeDependency()
-
-  if ('drag_drop' %in% options$plugins) {
-    selectizeDep <- c(
-      selectizeDep,
-      htmlDependency(
-        'jqueryui',
-        '1.12.1',
-        c(href = 'shared/jqueryui'),
-        script = 'jquery-ui.min.js'
-      )
-    )
-  }
-
-  # Insert script on same level as <select> tag
-  select$children[[2]] <- tagAppendChild(
-    select$children[[2]],
-    tags$script(
-      type = 'application/json',
-      `data-for` = inputId, `data-nonempty` = if (nonempty) '',
-      `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
-      if (length(res$options)) HTML(toJSON(res$options)) else '{}'
-    )
-  )
-
-  attachDependencies(select, selectizeDep)
-}
-
-
-selectizeVersion <- "0.12.4"
-
-selectizeDependency <- function(theme) {
-  list(
-    htmlDependency(
-      "selectize-js",
-      selectizeVersion,
-      src = c(href = "shared/selectize"),
-      script = c(
-        "js/selectize.min.js",
-        # Accessibility plugin for screen readers (https://github.com/SLMNBJ/selectize-plugin-a11y):
-        "accessibility/js/selectize-plugin-a11y.min.js"
-      )
-    ),
-    bootstraplib::bs_dependency_defer(selectizeCSS)
-  )
-}
-
-selectizeCSS <- function(theme) {
-  if (!is_bs_theme(theme)) {
-    return(htmlDependency(
-      name = "selectize-css",
-      version = selectizeVersion,
-      src = c(href = "shared/selectize"),
-      stylesheet = "css/selectize.bootstrap3.css"
-    ))
-  }
-
-  scss_file <- system.file(
-    package = "shiny", "www/shared/selectize/scss",
-    if ("3" %in% bootstraplib::theme_version(theme)) {
-      "selectize.bootstrap3.scss"
-    } else {
-      "selectize.bootstrap4.scss"
-    }
-  )
-  bootstraplib::bs_dependency(
-    input = sass::sass_file(scss_file),
-    theme = theme,
-    name = "selectize",
-    version = selectizeVersion,
-    cache_key_extra = utils::packageVersion("shiny")
-  )
-}
-
-
-#' Select variables from a data frame
-#'
-#' Create a select list that can be used to choose a single or multiple items
-#' from the column names of a data frame.
-#'
-#' By default, `varSelectInput()` and `selectizeInput()` use the
-#' JavaScript library \pkg{selectize.js}
-#' (<https://github.com/selectize/selectize.js>) to instead of the basic
-#' select input element. To use the standard HTML select input element, use
-#' `selectInput()` with `selectize=FALSE`.
-#'
-#' @inheritParams selectInput
-#' @param data A data frame. Used to retrieve the column names as choices for a [selectInput()]
-#' @return A variable select list control that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [updateSelectInput()]
-#'
-#' @section Server value:
-#' The resulting server `input` value will be returned as:
-#'
-#'  * A symbol if `multiple = FALSE`. The `input` value should be
-#'  used with rlang's [rlang::!!()]. For example,
-#'  `ggplot2::aes(!!input$variable)`.
-#'  * A list of symbols if `multiple = TRUE`. The `input` value
-#'  should be used with rlang's [rlang::!!!()] to expand
-#'  the symbol list as individual arguments. For example,
-#'  `dplyr::select(mtcars, !!!input$variabls)` which is
-#'  equivalent to `dplyr::select(mtcars, !!input$variabls[[1]], !!input$variabls[[2]], ..., !!input$variabls[[length(input$variabls)]])`.
-#'
-#' @examples
-#'
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' library(ggplot2)
-#'
-#' # single selection
-#' shinyApp(
-#'   ui = fluidPage(
-#'     varSelectInput("variable", "Variable:", mtcars),
-#'     plotOutput("data")
-#'   ),
-#'   server = function(input, output) {
-#'     output$data <- renderPlot({
-#'       ggplot(mtcars, aes(!!input$variable)) + geom_histogram()
-#'     })
-#'   }
-#' )
-#'
-#'
-#' # multiple selections
-#' \dontrun{
-#' shinyApp(
-#'  ui = fluidPage(
-#'    varSelectInput("variables", "Variable:", mtcars, multiple = TRUE),
-#'    tableOutput("data")
-#'  ),
-#'  server = function(input, output) {
-#'    output$data <- renderTable({
-#'       if (length(input$variables) == 0) return(mtcars)
-#'       mtcars %>% dplyr::select(!!!input$variables)
-#'    }, rownames = TRUE)
-#'  }
-#' )}
-#'
-#' }
-#' @export
-varSelectInput <- function(
-  inputId, label, data, selected = NULL,
-  multiple = FALSE, selectize = TRUE, width = NULL,
-  size = NULL
-) {
-  # no place holders
-  choices <- colnames(data)
-
-  selectInputVal <- selectInput(
-    inputId = inputId,
-    label = label,
-    choices = choices,
-    selected = selected,
-    multiple = multiple,
-    selectize = selectize,
-    width = width,
-    size = size
-  )
-
-  # set the select tag class to be "symbol"
-  selectClass <- selectInputVal$children[[2]]$children[[1]]$attribs$class
-  if (is.null(selectClass)) {
-    newClass <- "symbol"
-  } else {
-    newClass <- paste(selectClass, "symbol", sep = " ")
-  }
-  selectInputVal$children[[2]]$children[[1]]$attribs$class <- newClass
-
-  selectInputVal
-}
-
-
-
-#' @rdname varSelectInput
-#' @param ... Arguments passed to `varSelectInput()`.
-#' @param options A list of options. See the documentation of \pkg{selectize.js}
-#'   for possible options (character option values inside [base::I()] will
-#'   be treated as literal JavaScript code; see [renderDataTable()]
-#'   for details).
-#' @param width The width of the input, e.g. `'400px'`, or `'100%'`;
-#'   see [validateCssUnit()].
-#' @note The variable selectize input created from `varSelectizeInput()` allows
-#'   deletion of the selected option even in a single select input, which will
-#'   return an empty string as its value. This is the default behavior of
-#'   \pkg{selectize.js}. However, the selectize input created from
-#'   `selectInput(..., selectize = TRUE)` will ignore the empty string
-#'   value when it is a single choice input and the empty string is not in the
-#'   `choices` argument. This is to keep compatibility with
-#'   `selectInput(..., selectize = FALSE)`.
-#' @export
-varSelectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
-  selectizeIt(
-    inputId,
-    varSelectInput(inputId, ..., selectize = FALSE, width = width),
-    options
-  )
-}

R/input-slider.R

@@ -1,314 +0,0 @@
-#' Slider Input Widget
-#'
-#' Constructs a slider widget to select a numeric value from a range.
-#'
-#' @inheritParams textInput
-#' @param min The minimum value (inclusive) that can be selected.
-#' @param max The maximum value (inclusive) that can be selected.
-#' @param value The initial value of the slider. A numeric vector of length one
-#'   will create a regular slider; a numeric vector of length two will create a
-#'   double-ended range slider. A warning will be issued if the value doesn't
-#'   fit between `min` and `max`.
-#' @param step Specifies the interval between each selectable value on the
-#'   slider (if `NULL`, a heuristic is used to determine the step size). If
-#'   the values are dates, `step` is in days; if the values are times
-#'   (POSIXt), `step` is in seconds.
-#' @param round `TRUE` to round all values to the nearest integer;
-#'   `FALSE` if no rounding is desired; or an integer to round to that
-#'   number of digits (for example, 1 will round to the nearest 10, and -2 will
-#'   round to the nearest .01). Any rounding will be applied after snapping to
-#'   the nearest step.
-#' @param format Deprecated.
-#' @param locale Deprecated.
-#' @param ticks `FALSE` to hide tick marks, `TRUE` to show them
-#'   according to some simple heuristics.
-#' @param animate `TRUE` to show simple animation controls with default
-#'   settings; `FALSE` not to; or a custom settings list, such as those
-#'   created using [animationOptions()].
-#' @param sep Separator between thousands places in numbers.
-#' @param pre A prefix string to put in front of the value.
-#' @param post A suffix string to put after the value.
-#' @param dragRange This option is used only if it is a range slider (with two
-#'   values). If `TRUE` (the default), the range can be dragged. In other
-#'   words, the min and max can be dragged together. If `FALSE`, the range
-#'   cannot be dragged.
-#' @param timeFormat Only used if the values are Date or POSIXt objects. A time
-#'   format string, to be passed to the Javascript strftime library. See
-#'   <https://github.com/samsonjs/strftime> for more details. The allowed
-#'   format specifications are very similar, but not identical, to those for R's
-#'   [base::strftime()] function. For Dates, the default is `"%F"`
-#'   (like `"2015-07-01"`), and for POSIXt, the default is `"%F %T"`
-#'   (like `"2015-07-01 15:32:10"`).
-#' @param timezone Only used if the values are POSIXt objects. A string
-#'   specifying the time zone offset for the displayed times, in the format
-#'   `"+HHMM"` or `"-HHMM"`. If `NULL` (the default), times will
-#'   be displayed in the browser's time zone. The value `"+0000"` will
-#'   result in UTC time.
-#' @inheritParams selectizeInput
-#' @family input elements
-#' @seealso [updateSliderInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' ui <- fluidPage(
-#'   sliderInput("obs", "Number of observations:",
-#'     min = 0, max = 1000, value = 500
-#'   ),
-#'   plotOutput("distPlot")
-#' )
-#'
-#' # Server logic
-#' server <- function(input, output) {
-#'   output$distPlot <- renderPlot({
-#'     hist(rnorm(input$obs))
-#'   })
-#' }
-#'
-#' # Complete app with UI and server components
-#' shinyApp(ui, server)
-#' }
-#'
-#' @section Server value:
-#' A number, or in the case of slider range, a vector of two numbers.
-#'
-#' @export
-sliderInput <- function(inputId, label, min, max, value, step = NULL,
-                        round = FALSE, format = NULL, locale = NULL,
-                        ticks = TRUE, animate = FALSE, width = NULL, sep = ",",
-                        pre = NULL, post = NULL, timeFormat = NULL,
-                        timezone = NULL, dragRange = TRUE) {
-  if (!missing(format)) {
-    shinyDeprecated(msg = "The `format` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
-                    version = "0.10.2.2")
-  }
-  if (!missing(locale)) {
-    shinyDeprecated(msg = "The `locale` argument to sliderInput is deprecated. Use `sep`, `pre`, and `post` instead.",
-                    version = "0.10.2.2")
-  }
-
-  dataType <- getSliderType(min, max, value)
-
-  if (is.null(timeFormat)) {
-    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
-  }
-
-  # Restore bookmarked values here, after doing the type checking, because the
-  # restored value will be a character vector instead of Date or POSIXct, and we can do
-  # the conversion to correct type next.
-  value <- restoreInput(id = inputId, default = value)
-
-  if (is.character(value)) {
-    # If we got here, the value was restored from a URL-encoded bookmark.
-    if (dataType == "date") {
-      value <- as.Date(value, format = "%Y-%m-%d")
-    } else if (dataType == "datetime") {
-      # Date-times will have a format like "2018-02-28T03:46:26Z"
-      value <- as.POSIXct(value, format = "%Y-%m-%dT%H:%M:%SZ", tz = "UTC")
-    }
-  }
-
-  step <- findStepSize(min, max, step)
-
-  if (dataType %in% c("date", "datetime")) {
-    # For Dates, this conversion uses midnight on that date in UTC
-    to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
-
-    # Convert values to milliseconds since epoch (this is the value JS uses)
-    # Find step size in ms
-    step  <- to_ms(max) - to_ms(max - step)
-    min   <- to_ms(min)
-    max   <- to_ms(max)
-    value <- to_ms(value)
-  }
-
-  range <- max - min
-
-  # Try to get a sane number of tick marks
-  if (ticks) {
-    n_steps <- range / step
-
-    # Make sure there are <= 10 steps.
-    # n_ticks can be a noninteger, which is good when the range is not an
-    # integer multiple of the step size, e.g., min=1, max=10, step=4
-    scale_factor <- ceiling(n_steps / 10)
-    n_ticks <- n_steps / scale_factor
-
-  } else {
-    n_ticks <- NULL
-  }
-
-  sliderProps <- dropNulls(list(
-    class = "js-range-slider",
-    id = inputId,
-    `data-skin` = "shiny",
-    `data-type` = if (length(value) > 1) "double",
-    `data-min` = formatNoSci(min),
-    `data-max` = formatNoSci(max),
-    `data-from` = formatNoSci(value[1]),
-    `data-to` = if (length(value) > 1) formatNoSci(value[2]),
-    `data-step` = formatNoSci(step),
-    `data-grid` = ticks,
-    `data-grid-num` = n_ticks,
-    `data-grid-snap` = FALSE,
-    `data-prettify-separator` = sep,
-    `data-prettify-enabled` = (sep != ""),
-    `data-prefix` = pre,
-    `data-postfix` = post,
-    `data-keyboard` = TRUE,
-    # This value is only relevant for range sliders; for non-range sliders it
-    # causes problems since ion.RangeSlider 2.1.2 (issue #1605).
-    `data-drag-interval` = if (length(value) > 1) dragRange,
-    # The following are ignored by the ion.rangeSlider, but are used by Shiny.
-    `data-data-type` = dataType,
-    `data-time-format` = timeFormat,
-    `data-timezone` = timezone
-  ))
-
-  # Replace any TRUE and FALSE with "true" and "false"
-  sliderProps <- lapply(sliderProps, function(x) {
-    if (identical(x, TRUE)) "true"
-    else if (identical(x, FALSE)) "false"
-    else x
-  })
-
-  sliderTag <- div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    shinyInputLabel(inputId, label),
-    do.call(tags$input, sliderProps)
-  )
-
-  # Add animation buttons
-  if (identical(animate, TRUE))
-    animate <- animationOptions()
-
-  if (!is.null(animate) && !identical(animate, FALSE)) {
-    if (is.null(animate$playButton))
-      animate$playButton <- icon('play', lib = 'glyphicon')
-    if (is.null(animate$pauseButton))
-      animate$pauseButton <- icon('pause', lib = 'glyphicon')
-
-    sliderTag <- tagAppendChild(
-      sliderTag,
-      tags$div(class='slider-animate-container',
-        tags$a(href='#',
-          class='slider-animate-button',
-          'data-target-id'=inputId,
-          'data-interval'=animate$interval,
-          'data-loop'=animate$loop,
-          span(class = 'play', animate$playButton),
-          span(class = 'pause', animate$pauseButton)
-        )
-      )
-    )
-  }
-
-  attachDependencies(sliderTag, ionRangeSliderDependency())
-}
-
-
-ionRangeSliderVersion <- "2.3.1"
-
-ionRangeSliderDependency <- function() {
-  list(
-    # ion.rangeSlider also needs normalize.css, which is already included in Bootstrap.
-    htmlDependency(
-      "ionrangeslider-javascript", ionRangeSliderVersion,
-      src = c(href = "shared/ionrangeslider"),
-      script = "js/ion.rangeSlider.min.js"
-    ),
-    htmlDependency(
-      "strftime", "0.9.2",
-      src = c(href = "shared/strftime"),
-      script = "strftime-min.js"
-    ),
-    bootstraplib::bs_dependency_defer(ionRangeSliderDependencyCSS)
-  )
-}
-
-ionRangeSliderDependencyCSS <- function(theme) {
-  if (!is_bs_theme(theme)) {
-    return(htmlDependency(
-      "ionrangeslider-css",
-      ionRangeSliderVersion,
-      src = c(href = "shared/ionrangeslider"),
-      stylesheet = "css/ion.rangeSlider.css"
-    ))
-  }
-
-  # Remap some variable names for ionRangeSlider's scss
-  sass_input <- list(
-    list(
-      bg = "$input-bg",
-      fg = "$input-color",
-      accent = "$component-active-bg",
-      `font-family` = "$font-family-base"
-    ),
-    sass::sass_file(
-      system.file(package = "shiny", "www/shared/ionrangeslider/scss/shiny.scss")
-    )
-  )
-
-  bootstraplib::bs_dependency(
-    input = sass_input,
-    theme = theme,
-    name = "ionRangeSlider",
-    version = ionRangeSliderVersion,
-    cache_key_extra = utils::packageVersion("shiny")
-  )
-}
-
-hasDecimals <- function(value) {
-  truncatedValue <- round(value)
-  return (!identical(value, truncatedValue))
-}
-
-# If step is NULL, use heuristic to set the step size.
-findStepSize <- function(min, max, step) {
-  if (!is.null(step)) return(step)
-
-  range <- max - min
-  # If short range or decimals, use continuous decimal with ~100 points
-  if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
-    # Workaround for rounding errors (#1006): the intervals between the items
-    # returned by pretty() can have rounding errors. To avoid this, we'll use
-    # pretty() to find the min, max, and number of steps, and then use those
-    # values to calculate the step size.
-    pretty_steps <- pretty(c(min, max), n = 100)
-    n_steps <- length(pretty_steps) - 1
-
-    # Fix for #2061: Windows has low-significance digits (like 17 digits out)
-    # even at the boundaries of pretty()'s output. Use signif(digits = 10),
-    # which should be way way less significant than any data we'd want to keep.
-    # It might make sense to use signif(steps[2] - steps[1], 10) instead, but
-    # for now trying to make the minimal change.
-    signif(digits = 10, (max(pretty_steps) - min(pretty_steps)) / n_steps)
-
-  } else {
-    1
-  }
-}
-
-
-#' @rdname sliderInput
-#'
-#' @param interval The interval, in milliseconds, between each animation step.
-#' @param loop `TRUE` to automatically restart the animation when it
-#'   reaches the end.
-#' @param playButton Specifies the appearance of the play button. Valid values
-#'   are a one-element character vector (for a simple text label), an HTML tag
-#'   or list of tags (using [tag()] and friends), or raw HTML (using
-#'   [HTML()]).
-#' @param pauseButton Similar to `playButton`, but for the pause button.
-#' @export
-animationOptions <- function(interval=1000,
-                             loop=FALSE,
-                             playButton=NULL,
-                             pauseButton=NULL) {
-  list(interval=interval,
-       loop=loop,
-       playButton=playButton,
-       pauseButton=pauseButton)
-}

R/input-submit.R

@@ -1,65 +0,0 @@
-#' Create a submit button
-#'
-#' Create a submit button for an app. Apps that include a submit
-#' button do not automatically update their outputs when inputs change,
-#' rather they wait until the user explicitly clicks the submit button.
-#' The use of `submitButton` is generally discouraged in favor of
-#' the more versatile [actionButton()] (see details below).
-#'
-#' Submit buttons are unusual Shiny inputs, and we recommend using
-#' [actionButton()] instead of `submitButton` when you
-#' want to delay a reaction.
-#' See [this
-#' article](http://shiny.rstudio.com/articles/action-buttons.html) for more information (including a demo of how to "translate"
-#' code using a `submitButton` to code using an `actionButton`).
-#'
-#' In essence, the presence of a submit button stops all inputs from
-#' sending their values automatically to the server. This means, for
-#' instance, that if there are *two* submit buttons in the same app,
-#' clicking either one will cause all inputs in the app to send their
-#' values to the server. This is probably not what you'd want, which is
-#' why submit button are unwieldy for all but the simplest apps. There
-#' are other problems with submit buttons: for example, dynamically
-#' created submit buttons (for example, with [renderUI()]
-#' or [insertUI()]) will not work.
-#'
-#' @param text Button caption
-#' @param icon Optional [icon()] to appear on the button
-#' @param width The width of the button, e.g. `'400px'`, or `'100%'`;
-#'   see [validateCssUnit()].
-#' @return A submit button that can be added to a UI definition.
-#'
-#' @family input elements
-#'
-#' @examples
-#' if (interactive()) {
-#'
-#' shinyApp(
-#'   ui = basicPage(
-#'     numericInput("num", label = "Make changes", value = 1),
-#'     submitButton("Update View", icon("refresh")),
-#'     helpText("When you click the button above, you should see",
-#'              "the output below update to reflect the value you",
-#'              "entered at the top:"),
-#'     verbatimTextOutput("value")
-#'   ),
-#'   server = function(input, output) {
-#'
-#'     # submit buttons do not have a value of their own,
-#'     # they control when the app accesses values of other widgets.
-#'     # input$num is the value of the number widget.
-#'     output$value <- renderPrint({ input$num })
-#'   }
-#' )
-#' }
-#' @export
-submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
-  div(
-    tags$button(
-      type="submit",
-      class="btn btn-primary",
-      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-      list(icon, text)
-    )
-  )
-}

R/input-text.R

@@ -1,48 +0,0 @@
-#' Create a text input control
-#'
-#' Create an input control for entry of unstructured text values
-#'
-#' @param inputId The `input` slot that will be used to access the value.
-#' @param label Display label for the control, or `NULL` for no label.
-#' @param value Initial value.
-#' @param width The width of the input, e.g. `'400px'`, or `'100%'`;
-#'   see [validateCssUnit()].
-#' @param placeholder A character string giving the user a hint as to what can
-#'   be entered into the control. Internet Explorer 8 and 9 do not support this
-#'   option.
-#' @return A text input control that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [updateTextInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   textInput("caption", "Caption", "Data Summary"),
-#'   verbatimTextOutput("value")
-#' )
-#' server <- function(input, output) {
-#'   output$value <- renderText({ input$caption })
-#' }
-#' shinyApp(ui, server)
-#' }
-#'
-#' @section Server value:
-#' A character string of the text input. The default value is `""`
-#' unless `value` is provided.
-#'
-#' @export
-textInput <- function(inputId, label, value = "", width = NULL,
-  placeholder = NULL) {
-
-  value <- restoreInput(id = inputId, default = value)
-
-  div(class = "form-group shiny-input-container",
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    shinyInputLabel(inputId, label),
-    tags$input(id = inputId, type="text", class="form-control", value=value,
-      placeholder = placeholder)
-  )
-}

R/input-textarea.R

@@ -1,77 +0,0 @@
-#' Create a textarea input control
-#'
-#' Create a textarea input control for entry of unstructured text values.
-#'
-#' @inheritParams textInput
-#' @param height The height of the input, e.g. `'400px'`, or `'100%'`; see
-#'   [validateCssUnit()].
-#' @param cols Value of the visible character columns of the input, e.g. `80`.
-#'   This argument will only take effect if there is not a CSS `width` rule
-#'   defined for this element; such a rule could come from the `width` argument
-#'   of this function or from a containing page layout such as
-#'   [fluidPage()].
-#' @param rows The value of the visible character rows of the input, e.g. `6`.
-#'   If the `height` argument is specified, `height` will take precedence in the
-#'   browser's rendering.
-#' @param resize Which directions the textarea box can be resized. Can be one of
-#'   `"both"`, `"none"`, `"vertical"`, and `"horizontal"`. The default, `NULL`,
-#'   will use the client browser's default setting for resizing textareas.
-#' @return A textarea input control that can be added to a UI definition.
-#'
-#' @family input elements
-#' @seealso [updateTextAreaInput()]
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   textAreaInput("caption", "Caption", "Data Summary", width = "1000px"),
-#'   verbatimTextOutput("value")
-#' )
-#' server <- function(input, output) {
-#'   output$value <- renderText({ input$caption })
-#' }
-#' shinyApp(ui, server)
-#'
-#' }
-#'
-#' @section Server value:
-#' A character string of the text input. The default value is `""`
-#' unless `value` is provided.
-#'
-#' @export
-textAreaInput <- function(inputId, label, value = "", width = NULL, height = NULL,
-  cols = NULL, rows = NULL, placeholder = NULL, resize = NULL) {
-
-  value <- restoreInput(id = inputId, default = value)
-
-  if (!is.null(resize)) {
-    resize <- match.arg(resize, c("both", "none", "vertical", "horizontal"))
-  }
-
-  style <- paste(
-    # The width is specified on the parent div.
-    if (!is.null(width)) paste0("width: ",  "100%",  ";"),
-    if (!is.null(height)) paste0("height: ", validateCssUnit(height), ";"),
-    if (!is.null(resize)) paste0("resize: ", resize, ";")
-  )
-
-  # Workaround for tag attribute=character(0) bug:
-  #   https://github.com/rstudio/htmltools/issues/65
-  if (length(style) == 0) style <- NULL
-
-  div(class = "form-group shiny-input-container",
-    shinyInputLabel(inputId, label),
-    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    tags$textarea(
-      id = inputId,
-      class = "form-control",
-      placeholder = placeholder,
-      style = style,
-      rows = rows,
-      cols = cols,
-      value
-    )
-  )
-}

R/input-utils.R

@@ -1,174 +0,0 @@
-shinyInputLabel <- function(inputId, label = NULL) {
-  tags$label(
-    label,
-    class = "control-label",
-    class = if (is.null(label)) "shiny-label-null",
-    # `id` attribute is required for `aria-labelledby` used by screen readers:
-    id = paste0(inputId, "-label"),
-    `for` = inputId
-  )
-}
-
-# This function takes in either a list or vector for `choices` (and
-# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
-# in a list or vector for both `choiceNames` and `choiceValues` (and
-# `choices` is passed as NULL) and returns a list of two elements:
-#    - `choiceNames` is a vector or list that holds the options names
-#      (each element can be arbitrary UI, or simple text)
-#    - `choiceValues` is a vector or list that holds the options values
-#       (each element must be simple text)
-normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
-  mustExist = TRUE) {
-  # if-else to check that either choices OR (choiceNames + choiceValues)
-  # were correctly provided
-  if (is.null(choices)) {
-    if (is.null(choiceNames) || is.null(choiceValues)) {
-      if (mustExist) {
-        stop("Please specify a non-empty vector for `choices` (or, ",
-             "alternatively, for both `choiceNames` AND `choiceValues`).")
-      } else {
-        if (is.null(choiceNames) && is.null(choiceValues)) {
-          # this is useful when we call this function from `updateInputOptions()`
-          # in which case, all three `choices`, `choiceNames` and `choiceValues`
-          # may legitimately be NULL
-          return(list(choiceNames = NULL, choiceValues = NULL))
-        } else {
-          stop("One of `choiceNames` or `choiceValues` was set to ",
-               "NULL, but either both or none should be NULL.")
-        }
-      }
-    }
-    if (length(choiceNames) != length(choiceValues)) {
-      stop("`choiceNames` and `choiceValues` must have the same length.")
-    }
-    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
-      stop("`choiceNames` and `choiceValues` must not be named.")
-    }
-  } else {
-    if (!is.null(choiceNames) || !is.null(choiceValues)) {
-      warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
-    }
-    choices <- choicesWithNames(choices) # resolve names if not specified
-    choiceNames <- names(choices)
-    choiceValues <- unname(choices)
-  }
-
-  return(list(choiceNames = as.list(choiceNames),
-              choiceValues = as.list(as.character(choiceValues))))
-}
-
-# generate options for radio buttons and checkbox groups (type = 'checkbox' or
-# 'radio')
-generateOptions <- function(inputId, selected, inline, type = 'checkbox',
-                            choiceNames, choiceValues,
-                            session = getDefaultReactiveDomain()) {
-  # generate a list of <input type=? [checked] />
-  options <- mapply(
-    choiceValues, choiceNames,
-    FUN = function(value, name) {
-      inputTag <- tags$input(
-        type = type, name = inputId, value = value
-      )
-      if (value %in% selected)
-        inputTag$attribs$checked <- "checked"
-
-      # in case, the options include UI code other than text
-      # (arbitrary HTML using the tags() function or equivalent)
-      pd <- processDeps(name, session)
-
-      # If inline, there's no wrapper div, and the label needs a class like
-      # checkbox-inline.
-      if (inline) {
-        tags$label(class = paste0(type, "-inline"), inputTag,
-                   tags$span(pd$html, pd$deps))
-      } else {
-        tags$div(class = type, tags$label(inputTag,
-                 tags$span(pd$html, pd$deps)))
-      }
-    },
-    SIMPLIFY = FALSE, USE.NAMES = FALSE
-  )
-
-  div(class = "shiny-options-group", options)
-}
-
-# True when a choice list item represents a group of related inputs.
-isGroup <- function(choice) {
-  is.list(choice) ||
-    !is.null(names(choice)) ||
-    length(choice) > 1 ||
-    length(choice) == 0
-}
-
-# True when choices is a list and contains at least one group of related inputs.
-hasGroups <- function(choices) {
-  is.list(choices) && any(vapply(choices, isGroup, logical(1)))
-}
-
-# Assigns empty names to x if it's unnamed, and then fills any empty names with
-# the corresponding value coerced to a character(1).
-setDefaultNames <- function(x) {
-  x <- asNamed(x)
-  emptyNames <- names(x) == ""
-  names(x)[emptyNames] <- as.character(x)[emptyNames]
-  x
-}
-
-# Makes a character vector out of x in a way that preserves names.
-asCharacter <- function(x) {
-  stats::setNames(as.character(x), names(x))
-}
-
-# Processes a "flat" set of choices, or a collection of choices not containing
-# any named groups. choices should be a list without any list children, or an
-# atomic vector. choices may be named or unnamed. Any empty names are replaced
-# with the corresponding value coerced to a character.
-processFlatChoices <- function(choices) {
-  choices <- setDefaultNames(asCharacter(choices))
-  as.list(choices)
-}
-
-# Processes a "nested" set of choices, or a collection of choices that contains
-# one or more named groups of related choices and zero or more "flat" choices.
-# choices should be a named list, and any choice group must have a non-empty
-# name. Empty names of remaining "flat" choices are replaced with that choice's
-# value coerced to a character.
-processGroupedChoices <- function(choices) {
-  # We assert choices is a list, since only a list may contain a group.
-  stopifnot(is.list(choices))
-  # The list might be unnamed by this point. We add default names of "" so that
-  # names(choices) is not zero-length and mapply can work. Within mapply, we
-  # error if any group's name is ""
-  choices <- asNamed(choices)
-  choices <- mapply(function(name, choice) {
-    choiceIsGroup <- isGroup(choice)
-    if (choiceIsGroup && name == "") {
-      # If the choice is a group, and if its name is empty, produce an error. We
-      # error here because the composite nature of the choice prevents us from
-      # meaningfully automatically naming it. Note that while not documented,
-      # groups are not necessarily lists (aka generic vectors) but can also be
-      # any named atomic vector, or any atomic vector of length > 1.
-      stop('All sub-lists in "choices" must be named.')
-    } else if (choiceIsGroup) {
-      # The choice is a group, but it is named. Process it using the same
-      # function we use for "top level" choices.
-      processFlatChoices(choice)
-    } else {
-      # The choice was not named and is not a group; it is a "leaf".
-      as.character(choice)
-    }
-  }, names(choices), choices, SIMPLIFY = FALSE)
-  # By this point, any leaves in the choices list might still have empty names,
-  # so we're sure to automatically name them.
-  setDefaultNames(choices)
-}
-
-# Takes a vector/list/factor, and adds names (same as the value) to any entries
-# without names. Coerces all leaf nodes to `character`.
-choicesWithNames <- function(choices) {
-  if (hasGroups(choices)) {
-    processGroupedChoices(choices)
-  } else {
-    processFlatChoices(choices)
-  }
-}

R/insert-tab.R

@@ -1,325 +0,0 @@
-#' Dynamically insert/remove a tabPanel
-#'
-#' Dynamically insert or remove a [tabPanel()] (or a
-#' [navbarMenu()]) from an existing [tabsetPanel()],
-#' [navlistPanel()] or [navbarPage()].
-#'
-#' When you want to insert a new tab before or after an existing tab, you
-#' should use `insertTab`. When you want to prepend a tab (i.e. add a
-#' tab to the beginning of the `tabsetPanel`), use `prependTab`.
-#' When you want to append a tab (i.e. add a tab to the end of the
-#' `tabsetPanel`), use `appendTab`.
-#'
-#' For `navbarPage`, you can insert/remove conventional
-#' `tabPanel`s (whether at the top level or nested inside a
-#' `navbarMenu`), as well as an entire [navbarMenu()].
-#' For the latter case, `target` should be the `menuName` that
-#' you gave your `navbarMenu` when you first created it (by default,
-#' this is equal to the value of the `title` argument).
-#'
-#' @param inputId The `id` of the `tabsetPanel` (or
-#'   `navlistPanel` or `navbarPage`) into which `tab` will
-#'   be inserted/removed.
-#'
-#' @param tab The item to be added (must be created with `tabPanel`,
-#'   or with `navbarMenu`).
-#'
-#' @param target If inserting: the `value` of an existing
-#'   `tabPanel`, next to which `tab` will be added.
-#'   If removing: the `value` of the `tabPanel` that
-#'   you want to remove. See Details if you want to insert next to/remove
-#'   an entire `navbarMenu` instead.
-#'
-#' @param position Should `tab` be added before or after the
-#'   `target` tab?
-#'
-#' @param select Should `tab` be selected upon being inserted?
-#'
-#' @param session The shiny session within which to call this function.
-#'
-#' @seealso [showTab()]
-#'
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'
-#' # example app for inserting/removing a tab
-#' ui <- fluidPage(
-#'   sidebarLayout(
-#'     sidebarPanel(
-#'       actionButton("add", "Add 'Dynamic' tab"),
-#'       actionButton("remove", "Remove 'Foo' tab")
-#'     ),
-#'     mainPanel(
-#'       tabsetPanel(id = "tabs",
-#'         tabPanel("Hello", "This is the hello tab"),
-#'         tabPanel("Foo", "This is the foo tab"),
-#'         tabPanel("Bar", "This is the bar tab")
-#'       )
-#'     )
-#'   )
-#' )
-#' server <- function(input, output, session) {
-#'   observeEvent(input$add, {
-#'     insertTab(inputId = "tabs",
-#'       tabPanel("Dynamic", "This a dynamically-added tab"),
-#'       target = "Bar"
-#'     )
-#'   })
-#'   observeEvent(input$remove, {
-#'     removeTab(inputId = "tabs", target = "Foo")
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#'
-#' # example app for prepending/appending a navbarMenu
-#' ui <- navbarPage("Navbar page", id = "tabs",
-#'   tabPanel("Home",
-#'     actionButton("prepend", "Prepend a navbarMenu"),
-#'     actionButton("append", "Append a navbarMenu")
-#'   )
-#' )
-#' server <- function(input, output, session) {
-#'   observeEvent(input$prepend, {
-#'     id <- paste0("Dropdown", input$prepend, "p")
-#'     prependTab(inputId = "tabs",
-#'       navbarMenu(id,
-#'         tabPanel("Drop1", paste("Drop1 page from", id)),
-#'         tabPanel("Drop2", paste("Drop2 page from", id)),
-#'         "------",
-#'         "Header",
-#'         tabPanel("Drop3", paste("Drop3 page from", id))
-#'       )
-#'     )
-#'   })
-#'   observeEvent(input$append, {
-#'     id <- paste0("Dropdown", input$append, "a")
-#'     appendTab(inputId = "tabs",
-#'       navbarMenu(id,
-#'         tabPanel("Drop1", paste("Drop1 page from", id)),
-#'         tabPanel("Drop2", paste("Drop2 page from", id)),
-#'         "------",
-#'         "Header",
-#'         tabPanel("Drop3", paste("Drop3 page from", id))
-#'       )
-#'     )
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#' }
-#' @export
-insertTab <- function(inputId, tab, target,
-                      position = c("before", "after"), 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)
-}
-
-#' @param menuName This argument should only be used when you want to
-#'   prepend (or append) `tab` to the beginning (or end) of an
-#'   existing [navbarMenu()] (which must itself be part of
-#'   an existing [navbarPage()]). In this case, this argument
-#'   should be the `menuName` that you gave your `navbarMenu`
-#'   when you first created it (by default, this is equal to the value
-#'   of the `title` argument). Note that you still need to set the
-#'   `inputId` argument to whatever the `id` of the parent
-#'   `navbarPage` is. If `menuName` is left as `NULL`,
-#'   `tab` will be prepended (or appended) to whatever
-#'   `inputId` is.
-#'
-#' @rdname insertTab
-#' @export
-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)
-}
-
-#' @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)
-}
-
-#' @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)
-}
-
-
-#' Dynamically hide/show a tabPanel
-#'
-#' Dynamically hide or show a [tabPanel()] (or a
-#' [navbarMenu()])from an existing [tabsetPanel()],
-#' [navlistPanel()] or [navbarPage()].
-#'
-#' For `navbarPage`, you can hide/show conventional
-#' `tabPanel`s (whether at the top level or nested inside a
-#' `navbarMenu`), as well as an entire [navbarMenu()].
-#' For the latter case, `target` should be the `menuName` that
-#' you gave your `navbarMenu` when you first created it (by default,
-#' this is equal to the value of the `title` argument).
-#'
-#' @param inputId The `id` of the `tabsetPanel` (or
-#'   `navlistPanel` or `navbarPage`) in which to find
-#'   `target`.
-#'
-#' @param target The `value` of the `tabPanel` to be
-#'   hidden/shown. See Details if you want to hide/show an entire
-#'   `navbarMenu` instead.
-#'
-#' @param select Should `target` be selected upon being shown?
-#'
-#' @param session The shiny session within which to call this function.
-#'
-#' @seealso [insertTab()]
-#'
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- navbarPage("Navbar page", id = "tabs",
-#'   tabPanel("Home",
-#'     actionButton("hideTab", "Hide 'Foo' tab"),
-#'     actionButton("showTab", "Show 'Foo' tab"),
-#'     actionButton("hideMenu", "Hide 'More' navbarMenu"),
-#'     actionButton("showMenu", "Show 'More' navbarMenu")
-#'   ),
-#'   tabPanel("Foo", "This is the foo tab"),
-#'   tabPanel("Bar", "This is the bar tab"),
-#'   navbarMenu("More",
-#'     tabPanel("Table", "Table page"),
-#'     tabPanel("About", "About page"),
-#'     "------",
-#'     "Even more!",
-#'     tabPanel("Email", "Email page")
-#'   )
-#' )
-#'
-#' server <- function(input, output, session) {
-#'   observeEvent(input$hideTab, {
-#'     hideTab(inputId = "tabs", target = "Foo")
-#'   })
-#'
-#'   observeEvent(input$showTab, {
-#'     showTab(inputId = "tabs", target = "Foo")
-#'   })
-#'
-#'   observeEvent(input$hideMenu, {
-#'     hideTab(inputId = "tabs", target = "More")
-#'   })
-#'
-#'   observeEvent(input$showMenu, {
-#'     showTab(inputId = "tabs", target = "More")
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#' }
-#'
-#' @export
-showTab <- function(inputId, target, select = FALSE,
-                    session = getDefaultReactiveDomain()) {
-  force(target)
-
-  if (select) updateTabsetPanel(session, inputId, selected = target)
-  inputId <- session$ns(inputId)
-
-  callback <- function() {
-    session$sendChangeTabVisibility(
-      inputId = inputId,
-      target = target,
-      type = "show"
-    )
-  }
-  session$onFlush(callback, once = TRUE)
-}
-
-#' @rdname showTab
-#' @export
-hideTab <- function(inputId, target,
-                    session = getDefaultReactiveDomain()) {
-  force(target)
-  inputId <- session$ns(inputId)
-
-  callback <- function() {
-    session$sendChangeTabVisibility(
-      inputId = inputId,
-      target = target,
-      type = "hide"
-    )
-  }
-  session$onFlush(callback, once = TRUE)
-}

R/insert-ui.R

@@ -1,140 +0,0 @@
-#' Insert and remove UI objects
-#'
-#' These functions allow you to dynamically add and remove arbirary UI
-#' into your app, whenever you want, as many times as you want.
-#' Unlike [renderUI()], the UI generated with `insertUI()` is persistent:
-#' once it's created, it stays there until removed by `removeUI()`. Each
-#' new call to `insertUI()` creates more UI objects, in addition to
-#' the ones already there (all independent from one another). To
-#' update a part of the UI (ex: an input object), you must use the
-#' appropriate `render` function or a customized `reactive`
-#' function.
-#'
-#' It's particularly useful to pair `removeUI` with `insertUI()`, but there is
-#' no restriction on what you can use on. Any element that can be selected
-#' through a jQuery selector can be removed through this function.
-#'
-#' @param selector A string that is accepted by jQuery's selector
-#'   (i.e. the string `s` to be placed in a `$(s)` jQuery call).
-#'
-#'   For `insertUI()` this determines the element(s) relative to which you
-#'   want to insert your UI object. For `removeUI()` this determine the
-#'   element(s) to be removed. If you want to remove a Shiny input or output,
-#'   note that many of these are wrapped in `<div>`s, so you may need to use a
-#'   somewhat complex selector --- see the Examples below. (Alternatively, you
-#'   could also wrap the inputs/outputs that you want to be able to remove
-#'   easily in a `<div>` with an id.)
-#' @param where Where your UI object should go relative to the selector:
-#'   \describe{
-#'     \item{`beforeBegin`}{Before the selector element itself}
-#'     \item{`afterBegin`}{Just inside the selector element, before its
-#'     first child}
-#'     \item{`beforeEnd`}{Just inside the selector element, after its
-#'     last child (default)}
-#'     \item{`afterEnd`}{After the selector element itself}
-#'   }
-#'   Adapted from <https://developer.mozilla.org/en-US/docs/Web/API/Element/insertAdjacentHTML>.
-#' @param ui The UI object you want to insert. This can be anything that
-#'   you usually put inside your apps's `ui` function. If you're inserting
-#'   multiple elements in one call, make sure to wrap them in either a
-#'   `tagList()` or a `tags$div()` (the latter option has the
-#'   advantage that you can give it an `id` to make it easier to
-#'   reference or remove it later on). If you want to insert raw html, use
-#'   `ui = HTML()`.
-#' @param multiple In case your selector matches more than one element,
-#'   `multiple` determines whether Shiny should insert the UI object
-#'   relative to all matched elements or just relative to the first
-#'   matched element (default).
-#' @param immediate Whether the UI object should be immediately inserted
-#'   or removed, or whether Shiny should wait until all outputs have been
-#'   updated and all observers have been run (default).
-#' @param session The shiny session. Advanced use only.
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#' # Define UI
-#' ui <- fluidPage(
-#'   actionButton("add", "Add UI")
-#' )
-#'
-#' # Server logic
-#' server <- function(input, output, session) {
-#'   observeEvent(input$add, {
-#'     insertUI(
-#'       selector = "#add",
-#'       where = "afterEnd",
-#'       ui = textInput(paste0("txt", input$add),
-#'                      "Insert some text")
-#'     )
-#'   })
-#' }
-#'
-#' # Complete app with UI and server components
-#' shinyApp(ui, server)
-#' }
-#'
-#' if (interactive()) {
-#' # Define UI
-#' ui <- fluidPage(
-#'   actionButton("rmv", "Remove UI"),
-#'   textInput("txt", "This is no longer useful")
-#' )
-#'
-#' # Server logic
-#' server <- function(input, output, session) {
-#'   observeEvent(input$rmv, {
-#'     removeUI(
-#'       selector = "div:has(> #txt)"
-#'     )
-#'   })
-#' }
-#'
-#' # Complete app with UI and server components
-#' shinyApp(ui, server)
-#' }
-#' @export
-insertUI <- function(selector,
-  where = c("beforeBegin", "afterBegin", "beforeEnd", "afterEnd"),
-  ui,
-  multiple = FALSE,
-  immediate = FALSE,
-  session = getDefaultReactiveDomain()) {
-
-  force(selector)
-  force(ui)
-  force(session)
-  force(multiple)
-  if (missing(where)) where <- "beforeEnd"
-  where <- match.arg(where)
-
-  callback <- function() {
-    session$sendInsertUI(selector = selector,
-                         multiple = multiple,
-                         where = where,
-                         content = processDeps(ui, session))
-  }
-
-  if (!immediate) session$onFlushed(callback, once = TRUE)
-  else callback()
-}
-
-
-#' @rdname insertUI
-#' @export
-removeUI <- function(selector,
-  multiple = FALSE,
-  immediate = FALSE,
-  session = getDefaultReactiveDomain()) {
-
-  force(selector)
-  force(multiple)
-  force(session)
-
-  callback <- function() {
-    session$sendRemoveUI(selector = selector,
-                         multiple = multiple)
-  }
-
-  if (!immediate) session$onFlushed(callback, once = TRUE)
-  else callback()
-}

R/jqueryui.R

@@ -1,101 +0,0 @@
-#' Panel with absolute positioning
-#'
-#' Creates a panel whose contents are absolutely positioned.
-#'
-#' The `absolutePanel` function creates a `<div>` tag whose CSS
-#' position is set to `absolute` (or fixed if `fixed = TRUE`). The way
-#' absolute positioning works in HTML is that absolute coordinates are specified
-#' relative to its nearest parent element whose position is not set to
-#' `static` (which is the default), and if no such parent is found, then
-#' relative to the page borders. If you're not sure what that means, just keep
-#' in mind that you may get strange results if you use `absolutePanel` from
-#' inside of certain types of panels.
-#'
-#' The `fixedPanel` function is the same as `absolutePanel` with
-#' `fixed = TRUE`.
-#'
-#' The position (`top`, `left`, `right`, `bottom`) and size
-#' (`width`, `height`) parameters are all optional, but you should
-#' specify exactly two of `top`, `bottom`, and `height` and
-#' exactly two of `left`, `right`, and `width` for predictable
-#' results.
-#'
-#' Like most other distance parameters in Shiny, the position and size
-#' parameters take a number (interpreted as pixels) or a valid CSS size string,
-#' such as `"100px"` (100 pixels) or `"25%"`.
-#'
-#' For arcane HTML reasons, to have the panel fill the page or parent you should
-#' specify `0` for `top`, `left`, `right`, and `bottom`
-#' rather than the more obvious `width = "100%"` and `height =
-#' "100%"`.
-#'
-#' @param ... Attributes (named arguments) or children (unnamed arguments) that
-#'   should be included in the panel.
-#'
-#' @param top Distance between the top of the panel, and the top of the page or
-#'   parent container.
-#' @param left Distance between the left side of the panel, and the left of the
-#'   page or parent container.
-#' @param right Distance between the right side of the panel, and the right of
-#'   the page or parent container.
-#' @param bottom Distance between the bottom of the panel, and the bottom of the
-#'   page or parent container.
-#' @param width Width of the panel.
-#' @param height Height of the panel.
-#' @param draggable If `TRUE`, allows the user to move the panel by
-#'   clicking and dragging.
-#' @param fixed Positions the panel relative to the browser window and prevents
-#'   it from being scrolled with the rest of the page.
-#' @param cursor The type of cursor that should appear when the user mouses over
-#'   the panel. Use `"move"` for a north-east-south-west icon,
-#'   `"default"` for the usual cursor arrow, or `"inherit"` for the
-#'   usual cursor behavior (including changing to an I-beam when the cursor is
-#'   over text). The default is `"auto"`, which is equivalent to
-#'   `ifelse(draggable, "move", "inherit")`.
-#' @return An HTML element or list of elements.
-#' @export
-absolutePanel <- function(...,
-                          top = NULL, left = NULL, right = NULL, bottom = NULL,
-                          width = NULL, height = NULL,
-                          draggable = FALSE, fixed = FALSE,
-                          cursor = c('auto', 'move', 'default', 'inherit')) {
-  cssProps <- list(
-    top = top,
-    left = left,
-    right = right,
-    bottom = bottom,
-    width = width,
-    height = height
-  )
-  cssProps <- cssProps[!sapply(cssProps, is.null)]
-  cssProps <- sapply(cssProps, validateCssUnit)
-  cssProps[['position']] <- ifelse(fixed, 'fixed', 'absolute')
-  cssProps[['cursor']] <- match.arg(cursor)
-  if (identical(cssProps[['cursor']], 'auto'))
-    cssProps[['cursor']] <- ifelse(draggable, 'move', 'inherit')
-
-  style <- paste(paste(names(cssProps), cssProps, sep = ':', collapse = ';'), ';', sep='')
-  divTag <- tags$div(style=style, ...)
-  if (isTRUE(draggable)) {
-    divTag <- tagAppendAttributes(divTag, class='draggable')
-    return(tagList(
-      singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
-      divTag,
-      tags$script('$(".draggable").draggable();')
-    ))
-  } else {
-    return(divTag)
-  }
-}
-
-#' @rdname absolutePanel
-#' @export
-fixedPanel <- function(...,
-                       top = NULL, left = NULL, right = NULL, bottom = NULL,
-                       width = NULL, height = NULL,
-                       draggable = FALSE,
-                       cursor = c('auto', 'move', 'default', 'inherit')) {
-  absolutePanel(..., top=top, left=left, right=right, bottom=bottom,
-                width=width, height=height, draggable=draggable, cursor=match.arg(cursor),
-                fixed=TRUE)
-}

R/knitr.R

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

R/map.R

@@ -9,63 +9,62 @@
 # Remove of unknown key does nothing
 # Setting a key twice always results in last-one-wins
 # /TESTS
-
-# Note that Map objects can't be saved in one R session and restored in
-# another, because they are based on fastmap, which uses an external pointer,
-# and external pointers can't be saved and restored in another session.
-#' @importFrom fastmap fastmap
-Map <- R6Class(
+Map <- setRefClass(
   'Map',
-  portable = FALSE,
-  public = list(
+  fields = list(
+    .env = 'environment'
+  ),
+  methods = list(
     initialize = function() {
-      private$map <<- fastmap()
+      .env <<- new.env(parent=emptyenv())
     },
     get = function(key) {
-      map$get(key)
+      if (.self$containsKey(key))
+        return(base::get(key, pos=.env, inherits=FALSE))
+      else
+        return(NULL)
     },
     set = function(key, value) {
-      map$set(key, value)
-      value
-    },
-    mget = function(keys) {
-      map$mget(keys)
+      assign(key, value, pos=.env, inherits=FALSE)
+      return(value)
     },
     mset = function(...) {
-      map$mset(...)
+      args <- list(...)
+      for (key in names(args))
+        set(key, args[[key]])
+      return()
     },
     remove = function(key) {
-      if (!map$has(key))
-        return(NULL)
-
-      result <- map$get(key)
-      map$remove(key)
-      result
+      if (.self$containsKey(key)) {
+        result <- .self$get(key)
+        rm(list = key, pos=.env, inherits=FALSE)
+        return(result)
+      }
+      return(NULL)
     },
     containsKey = function(key) {
-      map$has(key)
+      exists(key, where=.env, inherits=FALSE)
     },
-    keys = function(sort = FALSE) {
-      map$keys(sort = sort)
+    keys = function() {
+      ls(envir=.env, all.names=TRUE)
     },
-    values = function(sort = FALSE) {
-      map$as_list(sort = sort)
+    values = function() {
+      mget(.self$keys(), envir=.env, inherits=FALSE)
     },
     clear = function() {
-      map$reset()
+      .env <<- new.env(parent=emptyenv())
+      invisible(NULL)
     },
     size = function() {
-      map$size()
+      length(.env)
     }
-  ),
-
-  private = list(
-    map = NULL
   )
 )
 
 as.list.Map <- function(map) {
-  map$values()
+  sapply(map$keys(),
+         map$get,
+         simplify=FALSE)
 }
 length.Map <- function(map) {
   map$size()

R/middleware-shiny.R

@@ -1,88 +0,0 @@
-#' @include globals.R
-NULL
-
-reactLogHandler <- function(req) {
-  if (! rLog$isLogging()) {
-    if (
-      identical(req$PATH_INFO, "/reactlog/mark") ||
-      identical(req$PATH_INFO, "/reactlog")
-    ) {
-      # is not logging, but is a reactlog path...
-
-      return(
-        httpResponse(
-          # Not Implemented
-          # - The server either does not recognize the request method, or it lacks the ability to fulfil the request.
-          status = 501,
-          content_type = "text/plain; charset=utf-8",
-          content = "To enable reactlog, set the following option before running the application: \n\noptions(shiny.reactlog = TRUE)"
-        )
-      )
-
-    } else {
-      # continue on like normal
-      return(NULL)
-    }
-
-  }
-
-  if (identical(req$PATH_INFO, "/reactlog/mark")) {
-    sessionToken <- parseQueryString(req$QUERY_STRING)$s
-    shinysession <- appsByToken$get(sessionToken)
-
-    # log time
-    withReactiveDomain(shinysession, {
-      rLog$userMark(getDefaultReactiveDomain())
-    })
-
-    return(httpResponse(
-      status = 200,
-      content = "marked",
-      content_type = "text/plain"
-    ))
-
-  } else if (identical(req$PATH_INFO, "/reactlog")){
-
-    sessionToken <- parseQueryString(req$QUERY_STRING)$s
-
-    # `renderReactLog` will check/throw if reactlog doesn't exist
-    reactlogFile <- renderReactlog(sessionToken)
-
-    return(httpResponse(
-      status = 200,
-      content = list(
-        file = reactlogFile,
-        owned = TRUE
-      )
-    ))
-
-  } else {
-    # continue on like normal
-    return(NULL)
-  }
-}
-
-sessionHandler <- function(req) {
-  path <- req$PATH_INFO
-  if (is.null(path))
-    return(NULL)
-
-  matches <- regmatches(path, regexec('^(/session/([0-9a-f]+))(/.*)$', path))
-  if (length(matches[[1]]) == 0)
-    return(NULL)
-
-  session <- matches[[1]][3]
-  subpath <- matches[[1]][4]
-
-  shinysession <- appsByToken$get(session)
-  if (is.null(shinysession))
-    return(NULL)
-
-  subreq <- as.environment(as.list(req, all.names=TRUE))
-  subreq$PATH_INFO <- subpath
-  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, matches[[1]][2], sep='')
-
-  withReactiveDomain(shinysession, {
-    shinysession$handleRequest(subreq)
-  })
-}

R/middleware.R

@@ -1,477 +0,0 @@
-# This file contains a general toolkit for routing and combining bits of
-# HTTP-handling logic. It is similar in spirit to Rook (and Rack, and WSGI, and
-# Connect, and...) but adds cascading and routing.
-#
-# This file is called "middleware" because that's the term used for these bits
-# of logic in these other frameworks. However, our code uses the word "handler"
-# so we'll stick to that for the rest of this document; just know that they're
-# basically the same concept.
-#
-# ## Intro to handlers
-#
-# A **handler** (or sometimes, **httpHandler**) is a function that takes a
-# `req` parameter--a request object as described in the Rook specification--and
-# returns `NULL`, or an `httpResponse`.
-#
-## ------------------------------------------------------------------------
-
-#' Create an HTTP response object
-#'
-#' @param status HTTP status code for the response.
-#' @param content_type The value for the `Content-Type` header.
-#' @param content The body of the response, given as a single-element character
-#'   vector (will be encoded as UTF-8) or a raw vector.
-#' @param headers A named list of additional headers to include. Do not include
-#'   `Content-Length` (as it is automatically calculated) or `Content-Type` (the
-#'   `content_type` argument is used instead).
-#'
-#' @examples
-#' httpResponse(status = 405L,
-#'   content_type = "text/plain",
-#'   content = "The requested method was not allowed"
-#' )
-#'
-#' @keywords internal
-#' @export
-httpResponse <- function(status = 200L,
-                         content_type = "text/html; charset=UTF-8",
-                         content = "",
-                         headers = list()) {
-  # Make sure it's a list, not a vector
-  headers <- as.list(headers)
-  if (is.null(headers$`X-UA-Compatible`))
-    headers$`X-UA-Compatible` <- "IE=edge,chrome=1"
-  resp <- list(status = status, content_type = content_type, content = content,
-               headers = headers)
-  class(resp) <- 'httpResponse'
-  return(resp)
-}
-
-#
-# You can think of a web application as being simply an aggregation of these
-# functions, each of which performs one kind of duty. Each handler in turn gets
-# a look at the request and can decide whether it knows how to handle it. If
-# so, it returns an `httpResponse` and processing terminates; if not, it
-# returns `NULL` and the next handler gets to execute. If the final handler
-# returns `NULL`, a 404 response should be returned.
-#
-# We have a similar construct for websockets: **websocket handlers** or
-# **wsHandlers**. These take a single `ws` argument which is the websocket
-# connection that was just opened, and they can either return `TRUE` if they
-# are handling the connection, and `NULL` to pass responsibility on to the next
-# wsHandler.
-#
-# ### Combining handlers
-#
-# Since it's so common for httpHandlers to be invoked in this "cascading"
-# fashion, we'll introduce a function that takes zero or more handlers and
-# returns a single handler. And while we're at it, making a directory of static
-# content available is such a common thing to do, we'll allow strings
-# representing paths to be used instead of handlers; any such strings we
-# encounter will be converted into `staticHandler` objects.
-#
-## ------------------------------------------------------------------------
-joinHandlers <- function(handlers) {
-  # Zero handlers; return a null handler
-  if (length(handlers) == 0)
-    return(function(req) NULL)
-
-  # Just one handler (function)? Return it.
-  if (is.function(handlers))
-    return(handlers)
-
-  handlers <- lapply(handlers, function(h) {
-    if (is.character(h))
-      return(staticHandler(h))
-    else
-      return(h)
-  })
-
-  # Filter out NULL
-  handlers <- handlers[!sapply(handlers, is.null)]
-
-  if (length(handlers) == 0)
-    return(function(req) NULL)
-  if (length(handlers) == 1)
-    return(handlers[[1]])
-
-  function(req) {
-    for (handler in handlers) {
-      response <- handler(req)
-      if (!is.null(response))
-        return(response)
-    }
-    return(NULL)
-  }
-}
-
-#
-# Note that we don't have an equivalent of `joinHandlers` for wsHandlers. It's
-# easy to imagine it, we just haven't needed one.
-#
-# ### Handler routing
-#
-# Handlers do not have a built-in notion of routing. Conceptually, given a list
-# of handlers, all the handlers are peers and they all get to see every request
-# (well, up until the point that a handler returns a response).
-#
-# You could implement routing in each handler by checking the request's
-# `PATH_INFO` field, but since it's such a common need, let's make it simple by
-# introducing a `routeHandler` function. This is a handler
-# [decorator](http://en.wikipedia.org/wiki/Decorator_pattern) and it's
-# responsible for 1) filtering out requests that don't match the given route,
-# and 2) temporarily modifying the request object to take the matched part of
-# the route off of the `PATH_INFO` (and add it to the end of `SCRIPT_NAME`).
-# This way, the handler doesn't need to figure out about what part of its URL
-# path has already been matched via routing.
-#
-# (BTW, it's safe for `routeHandler` calls to nest.)
-#
-## ------------------------------------------------------------------------
-routeHandler <- function(prefix, handler) {
-  force(prefix)
-  force(handler)
-
-  if (identical("", prefix))
-    return(handler)
-
-  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
-    stop("Invalid URL prefix \"", prefix, "\"")
-  }
-
-  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
-  function(req) {
-    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
-      origScript <- req$SCRIPT_NAME
-      origPath <- req$PATH_INFO
-      on.exit({
-        req$SCRIPT_NAME <- origScript
-        req$PATH_INFO <- origPath
-      }, add = TRUE)
-      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
-      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
-      req$PATH_INFO <- pathInfo
-      return(handler(req))
-    } else {
-      return(NULL)
-    }
-  }
-}
-
-#
-# We have a version for websocket handlers as well. Pity about the copy/paste
-# job.
-#
-## ------------------------------------------------------------------------
-routeWSHandler <- function(prefix, wshandler) {
-  force(prefix)
-  force(wshandler)
-
-  if (identical("", prefix))
-    return(wshandler)
-
-  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
-    stop("Invalid URL prefix \"", prefix, "\"")
-  }
-
-  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
-  function(ws) {
-    req <- ws$request
-    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
-      origScript <- req$SCRIPT_NAME
-      origPath <- req$PATH_INFO
-      on.exit({
-        req$SCRIPT_NAME <- origScript
-        req$PATH_INFO <- origPath
-      }, add = TRUE)
-      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
-      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
-      req$PATH_INFO <- pathInfo
-      return(wshandler(ws))
-    } else {
-      return(NULL)
-    }
-  }
-}
-
-#
-# ### Handler implementations
-#
-# Now let's actually write some handlers. Note that these functions aren't
-# *themselves* handlers, you call them and they *return* a handler. Handler
-# factory functions, if you will.
-#
-# Here's one that serves up static assets from a directory.
-#
-## ------------------------------------------------------------------------
-staticHandler <- function(root) {
-  force(root)
-  return(function(req) {
-    if (!identical(req$REQUEST_METHOD, 'GET'))
-      return(NULL)
-
-    path <- URLdecode(req$PATH_INFO)
-
-    if (is.null(path))
-      return(httpResponse(400, content="<h1>Bad Request</h1>"))
-
-    if (path == '/')
-      path <- '/index.html'
-
-    if (grepl('\\', path, fixed = TRUE))
-      return(NULL)
-
-    abs.path <- resolve(root, path)
-    if (is.null(abs.path))
-      return(NULL)
-
-    content.type <- getContentType(abs.path)
-    response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
-    return(httpResponse(200, content.type, response.content))
-  })
-}
-
-#
-# ## Handler manager
-#
-# The handler manager gives you a place to register handlers (of both http and
-# websocket varieties) and provides an httpuv-compatible set of callbacks for
-# invoking them.
-#
-# Create one of these, make zero or more calls to `addHandler` and
-# `addWSHandler` methods (order matters--first one wins!), and then pass the
-# return value of `createHttpuvApp` to httpuv's `startServer` function.
-#
-## ------------------------------------------------------------------------
-HandlerList <- R6Class("HandlerList",
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    handlers = list(),
-
-    add = function(handler, key, tail = FALSE) {
-      if (!is.null(handlers[[key]]))
-        stop("Key ", key, " already in use")
-      newList <- structure(names=key, list(handler))
-
-      if (length(handlers) == 0)
-        handlers <<- newList
-      else if (tail)
-        handlers <<- c(handlers, newList)
-      else
-        handlers <<- c(newList, handlers)
-    },
-    remove = function(key) {
-      handlers[key] <<- NULL
-    },
-    clear = function() {
-      handlers <<- list()
-    },
-    invoke = function(...) {
-      for (handler in handlers) {
-        result <- handler(...)
-        if (!is.null(result))
-          return(result)
-      }
-      return(NULL)
-    }
-  )
-)
-
-HandlerManager <- R6Class("HandlerManager",
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    handlers = "HandlerList",
-    wsHandlers = "HandlerList",
-
-    initialize = function() {
-      handlers <<- HandlerList$new()
-      wsHandlers <<- HandlerList$new()
-    },
-
-    addHandler = function(handler, key, tail = FALSE) {
-      handlers$add(handler, key, tail)
-    },
-    removeHandler = function(key) {
-      handlers$remove(key)
-    },
-    addWSHandler = function(wsHandler, key, tail = FALSE) {
-      wsHandlers$add(wsHandler, key, tail)
-    },
-    removeWSHandler = function(key) {
-      wsHandlers$remove(key)
-    },
-    clear = function() {
-      handlers$clear()
-      wsHandlers$clear()
-    },
-    createHttpuvApp = function() {
-      list(
-        onHeaders = function(req) {
-          maxSize <- getOption('shiny.maxRequestSize') %OR% (5 * 1024 * 1024)
-          if (maxSize <= 0)
-            return(NULL)
-
-          reqSize <- 0
-          if (length(req$CONTENT_LENGTH) > 0)
-            reqSize <- as.numeric(req$CONTENT_LENGTH)
-          else if (length(req$HTTP_TRANSFER_ENCODING) > 0)
-            reqSize <- Inf
-
-          if (reqSize > maxSize) {
-            return(list(status = 413L,
-              headers = list('Content-Type' = 'text/plain'),
-              body = 'Maximum upload size exceeded'))
-          }
-          else {
-            return(NULL)
-          }
-        },
-        call = .httpServer(
-          function (req) {
-            hybrid_chain(
-              hybrid_chain(
-                withCallingHandlers(withLogErrors(handlers$invoke(req)),
-                  error = function(cond) {
-                    sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
-                    if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
-                      stop(cond$message, call. = FALSE)
-                    } else {
-                      stop(paste("An error has occurred. Check your logs or",
-                                 "contact the app author for clarification."),
-                           call. = FALSE)
-                    }
-                  }
-                ),
-                catch = function(err) {
-                  httpResponse(status = 500L,
-                    content_type = "text/html",
-                    content = as.character(htmltools::htmlTemplate(
-                      system.file("template", "error.html", package = "shiny"),
-                      message = conditionMessage(err)
-                    ))
-                  )
-                }
-              ),
-              function(resp) {
-                maybeInjectAutoreload(resp)
-              }
-            )
-          },
-          loadSharedSecret()
-        ),
-        onWSOpen = function(ws) {
-          return(wsHandlers$invoke(ws))
-        }
-      )
-    },
-    .httpServer = function(handler, checkSharedSecret) {
-      filter <- getOption('shiny.http.response.filter')
-      if (is.null(filter))
-        filter <- function(req, response) response
-
-      function(req) {
-        if (!checkSharedSecret(req$HTTP_SHINY_SHARED_SECRET)) {
-          return(list(status=403,
-            body='<h1>403 Forbidden</h1><p>Shared secret mismatch</p>',
-            headers=list('Content-Type' = 'text/html')))
-        }
-
-        # Catch HEAD requests. For the purposes of handler functions, they
-        # should be treated like GET. The difference is that they shouldn't
-        # return a body in the http response.
-        head_request <- FALSE
-        if (identical(req$REQUEST_METHOD, "HEAD")) {
-          head_request <- TRUE
-          req$REQUEST_METHOD <- "GET"
-        }
-
-        response <- handler(req)
-
-        res <- hybrid_chain(response, function(response) {
-          if (is.null(response))
-            response <- httpResponse(404, content="<h1>Not Found</h1>")
-
-          if (inherits(response, "httpResponse")) {
-            headers <- as.list(response$headers)
-            headers$'Content-Type' <- response$content_type
-
-            response <- filter(req, response)
-            if (head_request) {
-
-              headers$`Content-Length` <- getResponseContentLength(response, deleteOwnedContent = TRUE)
-
-              return(list(
-                status = response$status,
-                body = "",
-                headers = headers
-              ))
-            } else {
-              return(list(
-                status = response$status,
-                body = response$content,
-                headers = headers
-              ))
-            }
-
-          } else {
-            # Assume it's a Rook-compatible response
-            return(response)
-          }
-        })
-      }
-    }
-  )
-)
-
-maybeInjectAutoreload <- function(resp) {
-  if (getOption("shiny.autoreload", FALSE) &&
-      isTRUE(grepl("^text/html($|;)", resp$content_type)) &&
-      is.character(resp$content)) {
-
-    resp$content <- gsub(
-      "</head>",
-      "<script src=\"shared/shiny-autoreload.js\"></script>\n</head>",
-      resp$content,
-      fixed = TRUE
-    )
-  }
-
-  resp
-}
-
-# Safely get the Content-Length of a Rook response, or NULL if the length cannot
-# be determined for whatever reason (probably malformed response$content).
-# If deleteOwnedContent is TRUE, then the function should delete response
-# content that is of the form list(file=..., owned=TRUE).
-getResponseContentLength <- function(response, deleteOwnedContent) {
-  force(deleteOwnedContent)
-
-  result <- if (is.character(response$content) && length(response$content) == 1) {
-    nchar(response$content, type = "bytes")
-  } else if (is.raw(response$content)) {
-    length(response$content)
-  } else if (is.list(response$content) && !is.null(response$content$file)) {
-    if (deleteOwnedContent && isTRUE(response$content$owned)) {
-      on.exit(unlink(response$content$file, recursive = FALSE, force = FALSE), add = TRUE)
-    }
-    file.info(response$content$file)$size
-  } else {
-    warning("HEAD request for unexpected content class ", class(response$content)[[1]])
-    NULL
-  }
-
-  if (is.na(result)) {
-    # Mostly for missing file case
-    return(NULL)
-  } else {
-    return(result)
-  }
-}
-
-#
-# ## Next steps
-#
-# See server.R and middleware-shiny.R to see actual implementation and usage of
-# handlers in the context of Shiny.

R/mock-session.R

@@ -1,720 +0,0 @@
-# Promise helpers taken from:
-#   https://github.com/rstudio/promises/blob/master/tests/testthat/common.R
-# Block until all pending later tasks have executed
-wait_for_it <- function() {
-  while (!later::loop_empty()) {
-    later::run_now(0.1)
-  }
-}
-
-# Block until the promise is resolved/rejected. If resolved, return the value.
-# If rejected, throw (yes throw, not return) the error.
-#' @importFrom promises %...!%
-#' @importFrom promises %...>%
-extract <- function(promise) {
-  promise_value <- NULL
-  error <- NULL
-  promise %...>%
-    (function(value) promise_value <<- value) %...!%
-    (function(reason) error <<- reason)
-
-  wait_for_it()
-  if (!is.null(error))
-    stop(error)
-  else
-    promise_value
-}
-
-# TODO: is there a way to get this behavior without exporting these functions? R6?
-# TODO: clientData is documented as a reactiveValues, which this is not. Is it possible that
-#   users are currently assigning into clientData? That would not work as expected here.
-#' @noRd
-#' @export
-`$.mockclientdata` <- function(x, name) {
-  if (name == "pixelratio") { return(1) }
-  if (name == "url_protocol") { return("http:") }
-  if (name == "url_hostname") { return("mocksession") }
-  if (name == "url_port") { return(1234) }
-  if (name == "url_pathname") { return("/mockpath") }
-  if (name == "url_hash") { return("#mockhash") }
-  if (name == "url_hash_initial") { return("#mockhash") }
-  if (name == "url_search") { return("?mocksearch=1") }
-
-  clientRE <- "^output_(.+)_([^_]+)$"
-  if(grepl(clientRE, name)) {
-    # TODO: use proper regex group matching here instead of redundantly parsing
-    el <- sub(clientRE, "\\1", name)
-    att <- sub(clientRE, "\\2", name)
-
-    if (att == "width") {
-      return(600)
-    } else if (att == "height") {
-      return(400)
-    } else if (att == "hidden") {
-      return(FALSE)
-    }
-  }
-  warning("Unexpected clientdata attribute accessed: ", name)
-  return(NULL)
-}
-
-#' @noRd
-#' @export
-`[[.mockclientdata` <- `$.mockclientdata`
-
-#' @noRd
-#' @export
-`[.mockclientdata` <- function(values, name) {
-  stop("Single-bracket indexing of mockclientdata is not allowed.")
-}
-
-#' @noRd
-mapNames <- function(func, vals) {
-  names(vals) <- vapply(names(vals), func, character(1))
-  vals
-}
-
-#' Returns a noop implementation of the public method `name` of ShinySession.
-#' @include shiny.R
-#' @noRd
-makeNoop <- function(name, msg = paste0(name, " is a noop.")) {
-  if (!(name %in% names(ShinySession$public_methods)))
-    stop(name, " is not public method of ShinySession.")
-  impl <- ShinySession$public_methods[[name]]
-  body(impl) <- rlang::expr({
-    # Force arguments
-    !!lapply(formalArgs(impl), rlang::sym)
-    # Evade "no visible binding" note for reference to `private`
-    (!!as.symbol("private"))$noopWarn(!!name, !!msg)
-    invisible()
-  })
-  impl
-}
-
-#' Accepts a series of symbols as arguments and generates corresponding noop
-#' implementations.
-#' @noRd
-makeWarnNoops <- function(...) {
-  methods <- as.character(list(...))
-  names(methods) <- methods
-  lapply(methods, makeNoop)
-}
-
-#' Returns an implementation of a ShinySession public method that signals an
-#' error.
-#' @include shiny.R
-#' @noRd
-makeError <- function(name, msg = paste0(name, " is for internal use only.")) {
-  if (!(name %in% names(ShinySession$public_methods)))
-    stop(name, " is not public method of ShinySession.")
-  impl <- ShinySession$public_methods[[name]]
-  body(impl) <- rlang::expr({
-    base::stop(!!msg)
-  })
-  impl
-}
-
-#' Accepts a series of named arguments. Each name corresponds to a ShinySession
-#' public method that should signal an error, and each argument corresponds to
-#' an error message.
-#' @noRd
-makeErrors <- function(...) {
-  errors <- rlang::list2(...)
-  mapply(makeError, names(errors), errors, USE.NAMES = TRUE, SIMPLIFY = FALSE)
-}
-
-#' @noRd
-makeExtraMethods <- function() {
-  c(makeWarnNoops(
-    "allowReconnect",
-    "decrementBusyCount",
-    "doBookmark",
-    "exportTestValues",
-    "flushOutput",
-    "getBookmarkExclude",
-    "getTestSnapshotUrl",
-    "incrementBusyCount",
-    "manageHiddenOutputs",
-    "manageInputs",
-    "onBookmark",
-    "onBookmarked",
-    "onInputReceived",
-    "onRestore",
-    "onRestored",
-    "outputOptions",
-    "reactlog",
-    # TODO Consider implementing this. Would require a new method like
-    # session$getDataObj() to access in a test expression.
-    "registerDataObj",
-    "reload",
-    "resetBrush",
-    "sendBinaryMessage",
-    "sendChangeTabVisibility",
-    "sendCustomMessage",
-    "sendInputMessage",
-    "sendInsertTab",
-    "sendInsertUI",
-    "sendModal",
-    "setCurrentTheme",
-    "sendNotification",
-    "sendProgress",
-    "sendRemoveTab",
-    "sendRemoveUI",
-    "setBookmarkExclude",
-    "setShowcase",
-    "showProgress",
-    "updateQueryString"
-  ), makeErrors(
-    `@uploadEnd` = "for internal use only",
-    `@uploadInit` = "for internal use only",
-    createBookmarkObservers = "for internal use only",
-    dispatch = "for internal use only",
-    handleRequest = "for internal use only",
-    requestFlush = "for internal use only",
-    startTiming = "for internal use only",
-    wsClosed = "for internal use only"
-  ))
-}
-
-#' @description Adds generated instance methods to a MockShinySession instance.
-#'   Note that `lock_objects = FALSE` must be set in the call to `R6Class()`
-#'   that produced the generator object of the instance.
-#' @param instance instance of an R6 object, generally a `MockShinySession`.
-#' @param methods named list of method names to method implementation functions.
-#'   In our typical usage, each function is derived from a public method of
-#'   `ShinySession`. The environment of each implementation function is set to
-#'   `instance$.__enclos_env` before the method is added.
-#' @noRd
-addGeneratedInstanceMethods <- function(instance, methods = makeExtraMethods()) {
-  mapply(function(name, impl) {
-    environment(impl) <- instance$.__enclos_env__
-    instance[[name]] <- impl
-  }, names(methods), methods)
-}
-
-#' Mock Shiny Session
-#'
-#' @description An R6 class suitable for testing purposes. Simulates, to the
-#'   extent possible, the behavior of the `ShinySession` class. The `session`
-#'   parameter provided to Shiny server functions and modules is an instance of
-#'   a `ShinySession` in normal operation.
-#'
-#'   Most kinds of module and server testing do not require this class be
-#'   instantiated manually. See instead [testServer()].
-#'
-#'   In order to support advanced usage, instances of `MockShinySession` are
-#'   **unlocked** so that public methods and fields of instances may be
-#'   modified. For example, in order to test authentication workflows, the
-#'   `user` or `groups` fields may be overridden. Modified instances of
-#'   `MockShinySession` may then be passed explicitly as the `session` argument
-#'   of [testServer()].
-#'
-#' @include timer.R
-#' @export
-MockShinySession <- R6Class(
-  'MockShinySession',
-  portable = FALSE,
-  lock_objects = FALSE,
-  public = list(
-    #' @field env The environment associated with the session.
-    env = NULL,
-    #' @field returned The value returned by the module under test.
-    returned = NULL,
-    #' @field singletons Hardcoded as empty. Needed for rendering HTML (i.e. renderUI).
-    singletons = character(0),
-    #' @field clientData Mock client data that always returns a size for plots.
-    clientData = structure(list(), class="mockclientdata"),
-    #' @field output The shinyoutputs associated with the session.
-    output = NULL,
-    #' @field input The reactive inputs associated with the session.
-    input = NULL,
-    #' @field userData An environment initialized as empty.
-    userData = NULL,
-    #' @field progressStack A stack of progress objects.
-    progressStack = 'Stack',
-    #' @field token On a real `ShinySession`, used to identify this instance in URLs.
-    token = 'character',
-    #' @field cache The session cache MemoryCache.
-    cache = NULL,
-    #' @field appcache The app cache MemoryCache.
-    appcache = NULL,
-    #' @field restoreContext Part of bookmarking support in a real
-    #'   `ShinySession` but always `NULL` for a `MockShinySession`.
-    restoreContext = NULL,
-    #' @field groups Character vector of groups associated with an authenticated
-    #'   user. Always `NULL` for a `MockShinySesion`.
-    groups = NULL,
-    #' @field user The username of an authenticated user. Always `NULL` for a
-    #'   `MockShinySession`.
-    user = NULL,
-    #' @field options A list containing session-level shinyOptions.
-    options = NULL,
-
-    #' @description Create a new MockShinySession.
-    initialize = function() {
-      private$.input <- ReactiveValues$new(dedupe = FALSE, label = "input")
-      private$flushCBs <- Callbacks$new()
-      private$flushedCBs <- Callbacks$new()
-      private$endedCBs <- Callbacks$new()
-
-      private$file_generators <- fastmap()
-
-      private$timer <- MockableTimerCallbacks$new()
-      self$progressStack <- Stack$new()
-
-      self$userData <- new.env(parent=emptyenv())
-
-      # create output
-      out <- .createOutputWriter(self)
-      class(out) <- "shinyoutput"
-      self$output <- out
-
-      # Create a read-only copy of the inputs reactive.
-      self$input <- .createReactiveValues(private$.input, readonly = TRUE)
-
-      self$token <- createUniqueId(16)
-
-      # Copy app-level options
-      self$options <- getCurrentAppState()$options
-
-      self$cache <- MemoryCache$new()
-      self$appcache <- MemoryCache$new()
-
-      # Adds various generated noop and error-producing method implementations.
-      # Note that noop methods can be configured to produce warnings by setting
-      # the option shiny.mocksession.warn = TRUE; see $noopWarn() for details.
-      addGeneratedInstanceMethods(self)
-    },
-    #' @description Define a callback to be invoked before a reactive flush
-    #' @param fun The function to invoke
-    #' @param once If `TRUE`, will only run once. Otherwise, will run every time reactives are flushed.
-    onFlush = function(fun, once=TRUE) {
-      if (!isTRUE(once)) {
-        return(private$flushCBs$register(fun))
-      } else {
-        dereg <- private$flushCBs$register(function() {
-          dereg()
-          fun()
-        })
-        return(dereg)
-      }
-    },
-    #' @description Define a callback to be invoked after a reactive flush
-    #' @param fun The function to invoke
-    #' @param once If `TRUE`, will only run once. Otherwise, will run every time reactives are flushed.
-    onFlushed = function(fun, once=TRUE) {
-      if (!isTRUE(once)) {
-        return(private$flushedCBs$register(fun))
-      } else {
-        dereg <- private$flushedCBs$register(function() {
-          dereg()
-          fun()
-        })
-        return(dereg)
-      }
-    },
-    #' @description Define a callback to be invoked when the session ends
-    #' @param sessionEndedCallback The callback to invoke when the session has ended.
-    onEnded = function(sessionEndedCallback) {
-      private$endedCBs$register(sessionEndedCallback)
-    },
-
-    #' @description Returns `FALSE` if the session has not yet been closed
-    isEnded = function(){ private$was_closed },
-    #' @description Returns `FALSE` if the session has not yet been closed
-    isClosed = function(){ private$was_closed },
-    #' @description Closes the session
-    close = function(){
-      for (output in private$output) {
-        output$suspend()
-      }
-      withReactiveDomain(self, {
-        private$endedCBs$invoke(onError = printError, ..stacktraceon = TRUE)
-      })
-      private$was_closed <- TRUE
-    },
-
-    #FIXME: this is wrong. Will need to be more complex.
-    #' @description Unsophisticated mock implementation that merely invokes
-    #   the given callback immediately.
-    #' @param callback The callback to be invoked.
-    cycleStartAction = function(callback){ callback() },
-
-    #' @description Base64-encode the given file. Needed for image rendering.
-    #' @param name Not used
-    #' @param file The file to be encoded
-    #' @param contentType The content type of the base64-encoded string
-    fileUrl = function(name, file, contentType='application/octet-stream') {
-      bytes <- file.info(file)$size
-      if (is.na(bytes))
-        return(NULL)
-
-      fileData <- readBin(file, 'raw', n=bytes)
-      b64 <- rawToBase64(fileData)
-      return(paste('data:', contentType, ';base64,', b64, sep=''))
-    },
-
-    #' @description Sets reactive values associated with the `session$inputs`
-    #'  object and flushes the reactives.
-    #' @param ... The inputs to set. These arguments are processed with
-    #'  [rlang::list2()] and so are _[dynamic][rlang::dyn-dots]_. Input names
-    #'  may not be duplicated.
-    #' @examples
-    #' \dontrun{
-    #' session$setInputs(x=1, y=2)
-    #' }
-    setInputs = function(...) {
-      vals <- rlang::dots_list(..., .homonyms = "error")
-      mapply(names(vals), vals, FUN = function(name, value) {
-        private$.input$set(name, value)
-      })
-      private$flush()
-    },
-
-    #' @description An internal method which shouldn't be used by others.
-    #'   Schedules `callback` for execution after some number of `millis`
-    #'   milliseconds.
-    #' @param millis The number of milliseconds on which to schedule a callback
-    #' @param callback The function to schedule.
-    .scheduleTask = function(millis, callback) {
-      id <- private$timer$schedule(millis, callback)
-
-      # Return a deregistration callback
-      function() {
-        invisible(private$timer$unschedule(id))
-      }
-    },
-
-    #' @description Simulate the passing of time by the given number of milliseconds.
-    #' @param millis The number of milliseconds to advance time.
-    elapse = function(millis) {
-      msLeft <- millis
-
-      while (msLeft > 0){
-        t <- private$timer$timeToNextEvent()
-
-        if (is.infinite(t) || t <= 0 || msLeft < t){
-          # Either there's no good upcoming event or we can't make it to it in the allotted time.
-          break
-        }
-        msLeft <- msLeft - t
-        private$timer$elapse(t)
-
-        # timerCallbacks must run before flushReact.
-        private$timer$executeElapsed()
-        private$flush()
-      }
-
-      private$timer$elapse(msLeft)
-
-      # Run again in case our callbacks resulted in a scheduled
-      # function that needs executing.
-      private$timer$executeElapsed()
-      private$flush()
-    },
-
-    #' @description An internal method which shouldn't be used by others.
-    #' @return Elapsed time in milliseconds.
-    .now = function() {
-      private$timer$getElapsed()
-    },
-
-    #' @description An internal method which shouldn't be used by others.
-    #'   Defines an output in a way that sets private$currentOutputName
-    #'   appropriately.
-    #' @param name The name of the output.
-    #' @param func The render definition.
-    #' @param label Not used.
-    defineOutput = function(name, func, label) {
-      force(name)
-
-      if (!is.null(private$outs[[name]]$obs)) {
-        private$outs[[name]]$obs$destroy()
-      }
-
-      if (is.null(func)) func <- missingOutput
-
-      if (!is.function(func))
-        stop(paste("Unexpected", class(func), "output for", name))
-
-      obs <- observe({
-        # We could just stash the promise, but we get an "unhandled promise error". This bypasses
-        prom <- NULL
-        tryCatch({
-          v <- private$withCurrentOutput(name, func(self, name))
-          if (!promises::is.promise(v)){
-            # Make our sync value into a promise
-            prom <- promises::promise(function(resolve, reject){ resolve(v) })
-          } else {
-            prom <- v
-          }
-        }, error=function(e){
-          # Error running value()
-          prom <<- promises::promise(function(resolve, reject){ reject(e) })
-        })
-
-        private$outs[[name]]$promise <- hybrid_chain(
-          prom,
-          function(v){
-            list(val = v, err = NULL)
-          }, catch=function(e){
-            list(val = NULL, err = e)
-          })
-      })
-      private$outs[[name]] <- list(obs = obs, func = func, promise = NULL)
-    },
-
-    #' @description An internal method which shouldn't be used by others. Forces
-    #'   evaluation of any reactive dependencies of the output function.
-    #' @param name The name of the output.
-    #' @return The return value of the function responsible for rendering the
-    #'   output.
-    getOutput = function(name) {
-      # Unlike the real outputs, we're going to return the last value rather than the unevaluated function
-      if (is.null(private$outs[[name]])) {
-        stop("The test referenced an output that hasn't been defined yet: output$", name)
-      }
-
-      if (is.null(private$outs[[name]]$promise)) {
-        # Means the output was defined but the observer hasn't had a chance to run
-        # yet. Run flushReact() now to force the observer to run.
-        flushReact()
-
-        if (is.null(private$outs[[name]]$promise)) {
-          stop("output$", name, " encountered an unexpected error resolving its promise")
-        }
-      }
-
-      # Make promise return
-      v <- extract(private$outs[[name]]$promise)
-      if (!is.null(v$err)){
-        stop(v$err)
-      } else if (private$file_generators$has(self$ns(name))) {
-        download <- private$file_generators$get(self$ns(name))
-        private$renderFile(self$ns(name), download)
-      } else {
-        v$val
-      }
-    },
-
-    #' @description Returns the given id prefixed by this namespace's id.
-    #' @param id The id to prefix with a namespace id.
-    #' @return The id with a namespace prefix.
-    ns = function(id) {
-      NS(private$nsPrefix, id)
-    },
-    #' @description Trigger a reactive flush right now.
-    flushReact = function(){
-      private$flush()
-    },
-    #' @description Create and return a namespace-specific session proxy.
-    #' @param namespace Character vector indicating a namespace.
-    #' @return A new session proxy.
-    makeScope = function(namespace) {
-      ns <- NS(namespace)
-      createSessionProxy(
-        self,
-        input = .createReactiveValues(private$.input, readonly = TRUE, ns = ns),
-        output = structure(.createOutputWriter(self, ns = ns), class = "shinyoutput"),
-        makeScope = function(namespace) self$makeScope(ns(namespace)),
-        ns = function(namespace) ns(namespace),
-        setInputs = function(...) {
-          self$setInputs(!!!mapNames(ns, rlang::dots_list(..., .homonyms = "error")))
-        }
-      )
-    },
-    #' @description Set the environment associated with a testServer() call, but
-    #'  only if it has not previously been set. This ensures that only the
-    #'  environment of the outermost module under test is the one retained. In
-    #'  other words, the first assignment wins.
-    #' @param env The environment to retain.
-    #' @return The provided `env`.
-    setEnv = function(env) {
-      if (is.null(self$env)) {
-        stopifnot(all(c("input", "output", "session") %in% ls(env)))
-        self$env <- env
-      }
-    },
-    #' @description Set the value returned by the module call and proactively
-    #'  flush. Note that this method may be called multiple times if modules
-    #'  are nested. The last assignment, corresponding to an invocation of
-    #'  setReturned() in the outermost module, wins.
-    #' @param value The value returned from the module
-    #' @return The provided `value`.
-    setReturned = function(value) {
-      self$returned <- value
-      value
-    },
-    #' @description Get the value returned by the module call.
-    #' @return The value returned by the module call
-    getReturned = function() self$returned,
-    #' @description Generate a distinct character identifier for use as a proxy
-    #'   namespace.
-    #' @return A character identifier unique to the current session.
-    genId = function() {
-      private$idCounter <- private$idCounter + 1
-      paste0("proxy", private$idCounter)
-    },
-    #' @description Provides a way to access the root `MockShinySession` from
-    #'   any descendant proxy.
-    #' @return The root `MockShinySession`.
-    rootScope = function() {
-      self
-    },
-    #' @description Called by observers when a reactive expression errors.
-    #' @param e An error object.
-    unhandledError = function(e) {
-      self$close()
-    },
-    #' @description Freeze a value until the flush cycle completes.
-    #' @param x A `ReactiveValues` object.
-    #' @param name The name of a reactive value within `x`.
-    freezeValue = function(x, name) {
-      if (!is.reactivevalues(x))
-        stop("x must be a reactivevalues object")
-
-      impl <- .subset2(x, 'impl')
-      key <- .subset2(x, 'ns')(name)
-      impl$freeze(key)
-      self$onFlushed(function() impl$thaw(key))
-    },
-    #' @description Registers the given callback to be invoked when the session
-    #'   is closed (i.e. the connection to the client has been severed). The
-    #'   return value is a function which unregisters the callback. If multiple
-    #'   callbacks are registered, the order in which they are invoked is not
-    #'   guaranteed.
-    #' @param sessionEndedCallback Function to call when the session ends.
-    onSessionEnded = function(sessionEndedCallback) {
-      self$onEnded(sessionEndedCallback)
-    },
-    #' @description Associated a downloadable file with the session.
-    #' @param name The un-namespaced output name to associate with the
-    #'   downloadable file.
-    #' @param filename A string or function designating the name of the file.
-    #' @param contentType A string of the content type of the file. Not used by
-    #'   `MockShinySession`.
-    #' @param content A function that takes a single argument file that is a
-    #'   file path (string) of a nonexistent temp file, and writes the content
-    #'   to that file path. (Reactive values and functions may be used from this
-    #'   function.)
-    registerDownload = function(name, filename, contentType, content) {
-      private$file_generators$set(self$ns(name), list(
-        filename = if (is.function(filename)) filename else function() filename,
-        content = content
-      ))
-    },
-    #' @description Get information about the output that is currently being
-    #'   executed.
-    #' @return A list with with the `name` of the output. If no output is
-    #'   currently being executed, this will return `NULL`.
-    getCurrentOutputInfo = function() {
-      name <- private$currentOutputName
-      if (is.null(name)) NULL else list(name = name)
-    }
-  ),
-  private = list(
-    # @field .input Internal ReactiveValues object for normal input sent from client.
-    .input = NULL,
-    # @field flushCBs `Callbacks` called before flush.
-    flushCBs = NULL,
-    # @field flushedCBs `Callbacks` called after flush.
-    flushedCBs = NULL,
-    # @field endedCBs `Callbacks` called when session ends.
-    endedCBs = NULL,
-    # @field timer `MockableTimerCallbacks` called at particular times.
-    timer = NULL,
-    # @field was_closed Set to `TRUE` once the session is closed.
-    was_closed = FALSE,
-    # @field outs List of namespaced output names.
-    outs = list(),
-    # @field nsPrefix Prefix with which to namespace inputs and outputs.
-    nsPrefix = "mock-session",
-    # @field idCounter Incremented every time `$genId()` is called.
-    idCounter = 0,
-    # @field file_generators Map of namespaced output names to lists with
-    #   `filename` and `output` elements, each a function. Updated by
-    #   `$registerDownload()` and read by `$getOutput()`. Files are generated
-    #   on demand when the output is accessed.
-    file_generators = NULL,
-    # @field currentOutputName Namespaced name of the currently executing
-    #'   output, or `NULL` if no output is currently executing.
-    currentOutputName = NULL,
-
-    # @description Writes a downloadable file to disk. If the `content` function
-    #   associated with a download handler does not write a file, an error is
-    #   signaled. Created files are deleted upon session close.
-    # @param name The eamespaced output name associated with the downloadable
-    #   file.
-    # @param download List with two names, `filename` and `content`. Both should
-    #   be functions. `filename` should take no arguments and return a string.
-    #   `content` should accept a path argument and create a file at that path.
-    # @return A path to a temp file.
-    renderFile = function(name, download) {
-      # We make our own tempdir here because it's not safe to delete the result
-      # of tempdir().
-      tmpd <- tempfile()
-      dir.create(tmpd, recursive = TRUE)
-      self$onSessionEnded(function() unlink(tmpd, recursive = TRUE))
-      file <- file.path(tmpd, download$filename())
-      download$content(file)
-      if (!file.exists(file))
-        error("downloadHandler for ", name, " did not write a file.")
-      file
-    },
-
-    # @description Calls `shiny:::flushReact()` and executes all callbacks
-    #   related to reactivity.
-    flush = function(){
-      isolate(private$flushCBs$invoke(..stacktraceon = TRUE))
-      shiny:::flushReact() # namespace to avoid calling our own method
-      isolate(private$flushedCBs$invoke(..stacktraceon = TRUE))
-      later::run_now()
-    },
-
-    # @description Produces a warning if the option `shiny.mocksession.warn` is
-    #   unset and not `FALSE`.
-    # @param name The name of the mocked method.
-    # @param msg A message describing why the method is not implemented.
-    noopWarn = function(name, msg) {
-      if (getOption("shiny.mocksession.warn", FALSE) == FALSE)
-        return(invisible())
-      out <- paste0(name, " is not fully implemented by MockShinySession: ", msg)
-      out <- paste0(out, "\n", "To disable messages like this, run `options(shiny.mocksession.warn=FALSE)`")
-      warning(out, call. = FALSE)
-    },
-
-    # @description Binds a domain to `expr` and uses `createVarPromiseDomain()`
-    #   to ensure `private$currentOutputName` is set to `name` around any of
-    #   the promise's callbacks. Domains are something like dynamic scopes but
-    #   for promise chains instead of the call stack.
-    # @return A promise.
-    withCurrentOutput = function(name, expr) {
-      if (!is.null(private$currentOutputName)) {
-        stop("Nested calls to withCurrentOutput() are not allowed.")
-      }
-
-      promises::with_promise_domain(
-        createVarPromiseDomain(private, "currentOutputName", name),
-        expr
-      )
-    }
-  ),
-  active = list(
-    #' @field files For internal use only.
-    files = function() stop("$files is for internal use only."),
-    #' @field downloads For internal use only.
-    downloads = function() stop("$downloads is for internal use only."),
-    #' @field closed Deprecated in `ShinySession` and signals an error.
-    closed = function() stop("$closed is deprecated"),
-    #' @field session Deprecated in ShinySession and signals an error.
-    session = function() stop("$session is deprecated"),
-    #' @field request An empty environment where the request should be. The request isn't meaningfully mocked currently.
-    request = function(value) {
-      if (!missing(value)){
-        stop("session$request can't be assigned to")
-      }
-      warning("session$request doesn't currently simulate a realistic request on MockShinySession")
-      new.env(parent=emptyenv())
-    }
-  )
-)

R/modal.R

@@ -1,184 +0,0 @@
-#' Show or remove a modal dialog
-#'
-#' This causes a modal dialog to be displayed in the client browser, and is
-#' typically used with [modalDialog()].
-#'
-#' @param ui UI content to show in the modal.
-#' @param session The `session` object passed to function given to
-#'   `shinyServer`.
-#'
-#' @seealso [modalDialog()] for examples.
-#' @export
-showModal <- function(ui, session = getDefaultReactiveDomain()) {
-  res <- processDeps(ui, session)
-
-  session$sendModal("show",
-    list(
-      html = res$html,
-      deps = res$deps
-    )
-  )
-}
-
-#' @rdname showModal
-#' @export
-removeModal <- function(session = getDefaultReactiveDomain()) {
-  session$sendModal("remove", NULL)
-}
-
-
-#' Create a modal dialog UI
-#'
-#' @description
-#' `modalDialog()` creates the UI for a modal dialog, using Bootstrap's modal
-#' class. Modals are typically used for showing important messages, or for
-#' presenting UI that requires input from the user, such as a user name and
-#' password input.
-#'
-#' `modalButton()` creates a button that will dismiss the dialog when clicked,
-#' typically used when customising the `footer`.
-#'
-#' @inheritParams actionButton
-#' @param ... UI elements for the body of the modal dialog box.
-#' @param title An optional title for the dialog.
-#' @param footer UI for footer. Use `NULL` for no footer.
-#' @param size One of `"s"` for small, `"m"` (the default) for medium,
-#'   or `"l"` for large.
-#' @param easyClose If `TRUE`, the modal dialog can be dismissed by
-#'   clicking outside the dialog box, or be pressing the Escape key. If
-#'   `FALSE` (the default), the modal dialog can't be dismissed in those
-#'   ways; instead it must be dismissed by clicking on a `modalButton()`, or
-#'   from a call to [removeModal()] on the server.
-#' @param fade If `FALSE`, the modal dialog will have no fade-in animation
-#'   (it will simply appear rather than fade in to view).
-#'
-#' @examples
-#' if (interactive()) {
-#' # Display an important message that can be dismissed only by clicking the
-#' # dismiss button.
-#' shinyApp(
-#'   ui = basicPage(
-#'     actionButton("show", "Show modal dialog")
-#'   ),
-#'   server = function(input, output) {
-#'     observeEvent(input$show, {
-#'       showModal(modalDialog(
-#'         title = "Important message",
-#'         "This is an important message!"
-#'       ))
-#'     })
-#'   }
-#' )
-#'
-#'
-#' # Display a message that can be dismissed by clicking outside the modal dialog,
-#' # or by pressing Esc.
-#' shinyApp(
-#'   ui = basicPage(
-#'     actionButton("show", "Show modal dialog")
-#'   ),
-#'   server = function(input, output) {
-#'     observeEvent(input$show, {
-#'       showModal(modalDialog(
-#'         title = "Somewhat important message",
-#'         "This is a somewhat important message.",
-#'         easyClose = TRUE,
-#'         footer = NULL
-#'       ))
-#'     })
-#'   }
-#' )
-#'
-#'
-#' # Display a modal that requires valid input before continuing.
-#' shinyApp(
-#'   ui = basicPage(
-#'     actionButton("show", "Show modal dialog"),
-#'     verbatimTextOutput("dataInfo")
-#'   ),
-#'
-#'   server = function(input, output) {
-#'     # reactiveValues object for storing current data set.
-#'     vals <- reactiveValues(data = NULL)
-#'
-#'     # Return the UI for a modal dialog with data selection input. If 'failed' is
-#'     # TRUE, then display a message that the previous value was invalid.
-#'     dataModal <- function(failed = FALSE) {
-#'       modalDialog(
-#'         textInput("dataset", "Choose data set",
-#'           placeholder = 'Try "mtcars" or "abc"'
-#'         ),
-#'         span('(Try the name of a valid data object like "mtcars", ',
-#'              'then a name of a non-existent object like "abc")'),
-#'         if (failed)
-#'           div(tags$b("Invalid name of data object", style = "color: red;")),
-#'
-#'         footer = tagList(
-#'           modalButton("Cancel"),
-#'           actionButton("ok", "OK")
-#'         )
-#'       )
-#'     }
-#'
-#'     # Show modal when button is clicked.
-#'     observeEvent(input$show, {
-#'       showModal(dataModal())
-#'     })
-#'
-#'     # When OK button is pressed, attempt to load the data set. If successful,
-#'     # remove the modal. If not show another modal, but this time with a failure
-#'     # message.
-#'     observeEvent(input$ok, {
-#'       # Check that data object exists and is data frame.
-#'       if (!is.null(input$dataset) && nzchar(input$dataset) &&
-#'           exists(input$dataset) && is.data.frame(get(input$dataset))) {
-#'         vals$data <- get(input$dataset)
-#'         removeModal()
-#'       } else {
-#'         showModal(dataModal(failed = TRUE))
-#'       }
-#'     })
-#'
-#'     # Display information about selected data
-#'     output$dataInfo <- renderPrint({
-#'       if (is.null(vals$data))
-#'         "No data selected"
-#'       else
-#'         summary(vals$data)
-#'     })
-#'   }
-#' )
-#' }
-#' @export
-modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
-  size = c("m", "s", "l"), 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",
-
-    div(
-      class = "modal-dialog",
-      class = switch(size, s = "modal-sm", m = NULL, l = "modal-lg"),
-      div(class = "modal-content",
-        if (!is.null(title)) div(class = "modal-header",
-          tags$h4(class = "modal-title", title)
-        ),
-        div(class = "modal-body", ...),
-        if (!is.null(footer)) div(class = "modal-footer", footer)
-      )
-    ),
-    tags$script("$('#shiny-modal').modal().focus();")
-  )
-}
-
-#' @export
-#' @rdname modalDialog
-modalButton <- function(label, icon = NULL) {
-  tags$button(type = "button", class = "btn btn-default",
-    `data-dismiss` = "modal", validateIcon(icon), label
-  )
-}

R/modules.R

@@ -1,174 +0,0 @@
-# Creates an object whose $ and [[ pass through to the parent
-# session, unless the name is matched in ..., in which case
-# that value is returned instead. (See Decorator pattern.)
-createSessionProxy <- function(parentSession, ...) {
-  e <- new.env(parent = emptyenv())
-  e$parent <- parentSession
-  e$overrides <- list(...)
-
-  structure(
-    e,
-    class = "session_proxy"
-  )
-}
-
-#' @export
-`$.session_proxy` <- function(x, name) {
-  if (name %in% names(.subset2(x, "overrides")))
-    .subset2(x, "overrides")[[name]]
-  else
-    .subset2(x, "parent")[[name]]
-}
-
-#' @export
-`[[.session_proxy` <- `$.session_proxy`
-
-
-#' @export
-`$<-.session_proxy` <- function(x, name, value) {
-  # this line allows users to write into session$userData
-  # (e.g. it allows something like `session$userData$x <- TRUE`,
-  # but not `session$userData <- TRUE`) from within a module
-  # without any hacks (see PR #1732)
-  if (identical(x[[name]], value)) return(x)
-  stop("Attempted to assign value on session proxy.")
-}
-
-`[[<-.session_proxy` <- `$<-.session_proxy`
-
-#' Shiny modules
-#'
-#' Shiny's module feature lets you break complicated UI and server logic into
-#' smaller, self-contained pieces. Compared to large monolithic Shiny apps,
-#' modules are easier to reuse and easier to reason about. See the article at
-#' <http://shiny.rstudio.com/articles/modules.html> to learn more.
-#'
-#' Starting in Shiny 1.5.0, we recommend using `moduleServer` instead of
-#' [`callModule()`], because the syntax is a little easier
-#' to understand, and modules created with `moduleServer` can be tested with
-#' [`testServer()`].
-#'
-#' @param module A Shiny module server function.
-#' @param id An ID string that corresponds with the ID used to call the module's
-#'   UI function.
-#' @param session Session from which to make a child scope (the default should
-#'   almost always be used).
-#'
-#' @return The return value, if any, from executing the module server function
-#' @seealso <http://shiny.rstudio.com/articles/modules.html>
-#'
-#' @examples
-#' # Define the UI for a module
-#' counterUI <- function(id, label = "Counter") {
-#'   ns <- NS(id)
-#'   tagList(
-#'     actionButton(ns("button"), label = label),
-#'     verbatimTextOutput(ns("out"))
-#'   )
-#' }
-#'
-#' # Define the server logic for a module
-#' counterServer <- function(id) {
-#'   moduleServer(
-#'     id,
-#'     function(input, output, session) {
-#'       count <- reactiveVal(0)
-#'       observeEvent(input$button, {
-#'         count(count() + 1)
-#'       })
-#'       output$out <- renderText({
-#'         count()
-#'       })
-#'       count
-#'     }
-#'   )
-#' }
-#'
-#' # Use the module in an app
-#' ui <- fluidPage(
-#'   counterUI("counter1", "Counter #1"),
-#'   counterUI("counter2", "Counter #2")
-#' )
-#' server <- function(input, output, session) {
-#'   counterServer("counter1")
-#'   counterServer("counter2")
-#' }
-#' if (interactive()) {
-#'   shinyApp(ui, server)
-#' }
-#'
-#'
-#'
-#' # If you want to pass extra parameters to the module's server logic, you can
-#' # add them to your function. In this case `prefix` is text that will be
-#' # printed before the count.
-#' counterServer2 <- function(id, prefix = NULL) {
-#'   moduleServer(
-#'     id,
-#'     function(input, output, session) {
-#'       count <- reactiveVal(0)
-#'       observeEvent(input$button, {
-#'         count(count() + 1)
-#'       })
-#'       output$out <- renderText({
-#'         paste0(prefix, count())
-#'       })
-#'       count
-#'     }
-#'   )
-#' }
-#'
-#' ui <- fluidPage(
-#'   counterUI("counter", "Counter"),
-#' )
-#' server <- function(input, output, session) {
-#'   counterServer2("counter", "The current count is: ")
-#' }
-#' if (interactive()) {
-#'   shinyApp(ui, server)
-#' }
-#'
-#' @export
-moduleServer <- function(id, module, session = getDefaultReactiveDomain()) {
-  if (inherits(session, "MockShinySession")) {
-    body(module) <- rlang::expr({
-      session$setEnv(base::environment())
-      !!body(module)
-    })
-    session$setReturned(callModule(module, id, session = session))
-  } else {
-    callModule(module, id, session = session)
-  }
-}
-
-
-#' Invoke a Shiny module
-#'
-#' Note: As of Shiny 1.5.0, we recommend using [`moduleServer()`] instead of
-#' [`callModule()`], because the syntax is a little easier
-#' to understand, and modules created with `moduleServer` can be tested with
-#' [`testServer()`].
-#'
-#' @param module A Shiny module server function
-#' @param id An ID string that corresponds with the ID used to call the module's
-#'   UI function
-#' @param ... Additional parameters to pass to module server function
-#' @param session Session from which to make a child scope (the default should
-#'   almost always be used)
-#'
-#' @return The return value, if any, from executing the module server function
-#' @export
-callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
-  if (!inherits(session, c("ShinySession", "session_proxy", "MockShinySession"))) {
-    stop("session must be a ShinySession or session_proxy object.")
-  }
-  childScope <- session$makeScope(id)
-
-  withReactiveDomain(childScope, {
-    if (!is.function(module)) {
-      stop("module argument must be a function")
-    }
-
-    module(childScope$input, childScope$output, childScope, ...)
-  })
-}

R/notifications.R

@@ -1,106 +0,0 @@
-#' Show or remove a notification
-#'
-#' These functions show and remove notifications in a Shiny application.
-#'
-#' @param ui Content of message.
-#' @param action Message content that represents an action. For example, this
-#'   could be a link that the user can click on. This is separate from `ui`
-#'   so customized layouts can handle the main notification content separately
-#'   from action content.
-#' @param duration Number of seconds to display the message before it
-#'   disappears. Use `NULL` to make the message not automatically
-#'   disappear.
-#' @param closeButton If `TRUE`, display a button which will make the
-#'   notification disappear when clicked. If `FALSE` do not display.
-#' @param id A unique identifier for the notification.
-#'
-#'   `id` is optional for `showNotification()`: Shiny will automatically create
-#'   one if needed. If you do supply it, Shiny will update an existing
-#'   notification if it exists, otherwise it will create a new one.
-#'
-#'   `id` is required for `removeNotification()`.
-#' @param type A string which controls the color of the notification. One of
-#'   "default" (gray), "message" (blue), "warning" (yellow), or "error" (red).
-#' @param session Session object to send notification to.
-#'
-#' @return An ID for the notification.
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' # Show a message when button is clicked
-#' shinyApp(
-#'   ui = fluidPage(
-#'     actionButton("show", "Show")
-#'   ),
-#'   server = function(input, output) {
-#'     observeEvent(input$show, {
-#'       showNotification("Message text",
-#'         action = a(href = "javascript:location.reload();", "Reload page")
-#'       )
-#'     })
-#'   }
-#' )
-#'
-#' # App with show and remove buttons
-#' shinyApp(
-#'   ui = fluidPage(
-#'     actionButton("show", "Show"),
-#'     actionButton("remove", "Remove")
-#'   ),
-#'   server = function(input, output) {
-#'     # A queue of notification IDs
-#'     ids <- character(0)
-#'     # A counter
-#'     n <- 0
-#'
-#'     observeEvent(input$show, {
-#'       # Save the ID for removal later
-#'       id <- showNotification(paste("Message", n), duration = NULL)
-#'       ids <<- c(ids, id)
-#'       n <<- n + 1
-#'     })
-#'
-#'     observeEvent(input$remove, {
-#'       if (length(ids) > 0)
-#'         removeNotification(ids[1])
-#'       ids <<- ids[-1]
-#'     })
-#'   }
-#' )
-#' }
-#' @export
-showNotification <- function(ui, action = NULL, duration = 5,
-  closeButton = TRUE, id = NULL,
-  type = c("default", "message", "warning", "error"),
-  session = getDefaultReactiveDomain())
-{
-
-  if (is.null(id))
-    id <- createUniqueId(8)
-
-  res <- processDeps(ui, session)
-  actionRes <- processDeps(action, session)
-
-  session$sendNotification("show",
-    list(
-      html = res$html,
-      action = actionRes$html,
-      deps = c(res$deps, actionRes$deps),
-      duration = if (!is.null(duration)) duration * 1000,
-      closeButton = closeButton,
-      id = id,
-      type = match.arg(type)
-    )
-  )
-
-  id
-}
-
-#' @rdname showNotification
-#' @export
-removeNotification <- function(id, session = getDefaultReactiveDomain()) {
-  force(id)
-  session$sendNotification("remove", id)
-  id
-}

R/priorityqueue.R

@@ -4,24 +4,20 @@
 # elements have the same priority, they are served according to their order in
 # the queue." (http://en.wikipedia.org/wiki/Priority_queue)
 
-PriorityQueue <- R6Class(
+PriorityQueue <- setRefClass(
   'PriorityQueue',
-  portable = FALSE,
-  class = FALSE,
-  public = list(
+  fields = list(
     # Keys are priorities, values are subqueues (implemented as list)
     .itemsByPriority = 'Map',
     # Sorted vector (largest first)
-    .priorities = numeric(0),
-
-    initialize = function() {
-      .itemsByPriority <<- Map$new()
-    },
-    # Enqueue an item, with the given priority level (must be integer). Higher
+    .priorities = 'numeric'  
+  ),
+  methods = list(
+    # Enqueue an item, with the given priority level (must be integer). Higher 
     # priority numbers are dequeued earlier than lower.
     enqueue = function(item, priority) {
       priority <- normalizePriority(priority)
-
+      
       if (!(priority %in% .priorities)) {
         .priorities <<- c(.priorities, priority)
         .priorities <<- sort(.priorities, decreasing=TRUE)
@@ -34,14 +30,14 @@ PriorityQueue <- R6Class(
       }
       return(invisible())
     },
-    # Retrieve a single item by 1) priority number (highest first) and then 2)
-    # insertion order (first in, first out). If there are no items to be
+    # Retrieve a single item by 1) priority number (highest first) and then 2) 
+    # insertion order (first in, first out). If there are no items to be 
     # dequeued, then NULL is returned. If it is necessary to distinguish between
     # a NULL value and the empty case, call isEmpty() before dequeue().
     dequeue = function() {
       if (length(.priorities) == 0)
         return(NULL)
-
+      
       maxPriority <- .priorities[[1]]
       items <- .itemsByPriority$get(.key(maxPriority))
       firstItem <- items[[1]]
@@ -71,17 +67,17 @@ PriorityQueue <- R6Class(
 )
 
 normalizePriority <- function(priority) {
-
+  
   if (is.null(priority))
     priority <- 0
-
+  
   # Cast integers to numeric to prevent any inconsistencies
   if (is.integer(priority))
     priority <- as.numeric(priority)
-
+  
   if (!is.numeric(priority))
     stop('priority must be an integer or numeric')
-
+  
   # Check length
   if (length(priority) == 0) {
     warning('Zero-length priority vector was passed; using 0')
@@ -90,7 +86,7 @@ normalizePriority <- function(priority) {
     warning('Priority has length > 1 and only the first element will be used')
     priority <- priority[1]
   }
-
+  
   # NA == 0
   if (is.na(priority))
     priority <- 0

R/progress.R

@@ -1,320 +0,0 @@
-#' Reporting progress (object-oriented API)
-#'
-#' Reports progress to the user during long-running operations.
-#'
-#' This package exposes two distinct programming APIs for working with
-#' progress. [withProgress()] and [setProgress()]
-#' together provide a simple function-based interface, while the
-#' `Progress` reference class provides an object-oriented API.
-#'
-#' Instantiating a `Progress` object causes a progress panel to be
-#' created, and it will be displayed the first time the `set`
-#' method is called. Calling `close` will cause the progress panel
-#' to be removed.
-#'
-#' As of version 0.14, the progress indicators use Shiny's new notification API.
-#' If you want to use the old styling (for example, you may have used customized
-#' CSS), you can use `style="old"` each time you call
-#' `Progress$new()`. If you don't want to set the style each time
-#' `Progress$new` is called, you can instead call
-#' [`shinyOptions(progress.style="old")`][shinyOptions] just once, inside the server
-#' function.
-#'
-#' @param message A single-element character vector; the message to be
-#'   displayed to the user, or `NULL` to hide the current message (if any).
-#' @param detail A single-element character vector; the detail message to be
-#'   displayed to the user, or `NULL` to hide the current detail message (if
-#'   any). The detail message will be shown with a de-emphasized appearance
-#'   relative to `message`.
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' ui <- fluidPage(
-#'   plotOutput("plot")
-#' )
-#'
-#' server <- function(input, output, session) {
-#'   output$plot <- renderPlot({
-#'     progress <- Progress$new(session, min=1, max=15)
-#'     on.exit(progress$close())
-#'
-#'     progress$set(message = 'Calculation in progress',
-#'                  detail = 'This may take a while...')
-#'
-#'     for (i in 1:15) {
-#'       progress$set(value = i)
-#'       Sys.sleep(0.5)
-#'     }
-#'     plot(cars)
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#' }
-#' @seealso [withProgress()]
-#' @format NULL
-#' @usage NULL
-#' @export
-Progress <- R6Class(
-  'Progress',
-  public = list(
-
-    #' @description Creates a new progress panel (but does not display it).
-    #' @param session The Shiny session object, as provided by `shinyServer` to
-    #'   the server function.
-    #' @param min The value that represents the starting point of the progress
-    #'   bar. Must be less than `max`.
-    #' @param max The value that represents the end of the progress bar. Must be
-    #'   greater than `min`.
-    #' @param style Progress display style. If `"notification"` (the default),
-    #'   the progress indicator will show using Shiny's notification API. If
-    #'   `"old"`, use the same HTML and CSS used in Shiny 0.13.2 and below (this
-    #'   is for backward-compatibility).
-    initialize = function(session = getDefaultReactiveDomain(),
-      min = 0, max = 1,
-      style = getShinyOption("progress.style", default = "notification"))
-    {
-      if (is.null(session$progressStack))
-        stop("'session' is not a ShinySession object.")
-
-      private$session <- session
-      private$id <- createUniqueId(8)
-      private$min <- min
-      private$max <- max
-      private$value <- NULL
-      private$style <- match.arg(style, choices = c("notification", "old"))
-      private$closed <- FALSE
-
-      session$sendProgress('open', list(id = private$id, style = private$style))
-    },
-
-    #' @description Updates the progress panel. When called the first time, the
-    #'   progress panel is displayed.
-    #' @param value Single-element numeric vector; the value at which to set the
-    #'   progress bar, relative to `min` and `max`. `NULL` hides the progress
-    #'   bar, if it is currently visible.
-    set = function(value = NULL, message = NULL, detail = NULL) {
-      if (private$closed) {
-        warning("Attempting to set progress, but progress already closed.")
-        return()
-      }
-
-      if (is.null(value) || is.na(value))
-        value <- NULL
-
-      if (!is.null(value)) {
-        private$value <- value
-        # Normalize value to number between 0 and 1
-        value <- min(1, max(0, (value - private$min) / (private$max - private$min)))
-      }
-
-      data <- dropNulls(list(
-        id = private$id,
-        message = message,
-        detail = detail,
-        value = value,
-        style = private$style
-      ))
-
-      private$session$sendProgress('update', data)
-    },
-
-    #' @description Like `set`, this updates the progress panel. The difference
-    #'   is that `inc` increases the progress bar by `amount`, instead of
-    #'   setting it to a specific value.
-    #' @param amount For the `inc()` method, a numeric value to increment the
-    #'   progress bar.
-    inc = function(amount = 0.1, message = NULL, detail = NULL) {
-      if (is.null(private$value))
-        private$value <- private$min
-
-      value <- min(private$value + amount, private$max)
-      self$set(value, message, detail)
-    },
-
-    #' @description Returns the minimum value.
-    getMin = function() private$min,
-
-    #' @description Returns the maximum value.
-    getMax = function() private$max,
-
-    #' @description Returns the current value.
-    getValue = function() private$value,
-
-    #' @description Removes the progress panel. Future calls to `set` and
-    #'   `close` will be ignored.
-    close = function() {
-      if (private$closed) {
-        warning("Attempting to close progress, but progress already closed.")
-        return()
-      }
-
-      private$session$sendProgress('close',
-        list(id = private$id, style = private$style)
-      )
-      private$closed <- TRUE
-    }
-  ),
-
-  private = list(
-    session = 'ShinySession',
-    id = character(0),
-    min = numeric(0),
-    max = numeric(0),
-    style = character(0),
-    value = numeric(0),
-    closed = logical(0)
-  )
-)
-
-#' Reporting progress (functional API)
-#'
-#' Reports progress to the user during long-running operations.
-#'
-#' This package exposes two distinct programming APIs for working with progress.
-#' Using `withProgress` with `incProgress` or `setProgress`
-#' provide a simple function-based interface, while the [Progress()]
-#' reference class provides an object-oriented API.
-#'
-#' Use `withProgress` to wrap the scope of your work; doing so will cause a
-#' new progress panel to be created, and it will be displayed the first time
-#' `incProgress` or `setProgress` are called. When `withProgress`
-#' exits, the corresponding progress panel will be removed.
-#'
-#' The `incProgress` function increments the status bar by a specified
-#' amount, whereas the `setProgress` function sets it to a specific value,
-#' and can also set the text displayed.
-#'
-#' Generally, `withProgress`/`incProgress`/`setProgress` should
-#' be sufficient; the exception is if the work to be done is asynchronous (this
-#' is not common) or otherwise cannot be encapsulated by a single scope. In that
-#' case, you can use the `Progress` reference class.
-#'
-#' As of version 0.14, the progress indicators use Shiny's new notification API.
-#' If you want to use the old styling (for example, you may have used customized
-#' CSS), you can use `style="old"` each time you call
-#' `withProgress()`. If you don't want to set the style each time
-#' `withProgress` is called, you can instead call
-#' [`shinyOptions(progress.style="old")`][shinyOptions] just once, inside the server
-#' function.
-#'
-#' @param session The Shiny session object, as provided by `shinyServer` to
-#'   the server function. The default is to automatically find the session by
-#'   using the current reactive domain.
-#' @param expr The work to be done. This expression should contain calls to
-#'   [setProgress()] or [incProgress()].
-#' @param min The value that represents the starting point of the progress bar.
-#'   Must be less tham `max`. Default is 0.
-#' @param max The value that represents the end of the progress bar. Must be
-#'   greater than `min`. Default is 1.
-#' @param amount For `incProgress`, the amount to increment the status bar.
-#'   Default is 0.1.
-#' @param env The environment in which `expr` should be evaluated.
-#' @param quoted Whether `expr` is a quoted expression (this is not
-#'   common).
-#' @param message A single-element character vector; the message to be displayed
-#'   to the user, or `NULL` to hide the current message (if any).
-#' @param detail A single-element character vector; the detail message to be
-#'   displayed to the user, or `NULL` to hide the current detail message
-#'   (if any). The detail message will be shown with a de-emphasized appearance
-#'   relative to `message`.
-#' @param style Progress display style. If `"notification"` (the default),
-#'   the progress indicator will show using Shiny's notification API. If
-#'   `"old"`, use the same HTML and CSS used in Shiny 0.13.2 and below
-#'   (this is for backward-compatibility).
-#' @param value Single-element numeric vector; the value at which to set the
-#'   progress bar, relative to `min` and `max`.
-#'
-#' @return The result of `expr`.
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#' options(device.ask.default = FALSE)
-#'
-#' ui <- fluidPage(
-#'   plotOutput("plot")
-#' )
-#'
-#' server <- function(input, output) {
-#'   output$plot <- renderPlot({
-#'     withProgress(message = 'Calculation in progress',
-#'                  detail = 'This may take a while...', value = 0, {
-#'       for (i in 1:15) {
-#'         incProgress(1/15)
-#'         Sys.sleep(0.25)
-#'       }
-#'     })
-#'     plot(cars)
-#'   })
-#' }
-#'
-#' shinyApp(ui, server)
-#' }
-#' @seealso [Progress()]
-#' @rdname withProgress
-#' @export
-withProgress <- function(expr, min = 0, max = 1,
-  value = min + (max - min) * 0.1,
-  message = NULL, detail = NULL,
-  style = getShinyOption("progress.style", default = "notification"),
-  session = getDefaultReactiveDomain(),
-  env = parent.frame(), quoted = FALSE)
-{
-
-  if (!quoted)
-    expr <- substitute(expr)
-
-  if (is.null(session$progressStack))
-    stop("'session' is not a ShinySession object.")
-
-  style <- match.arg(style, c("notification", "old"))
-
-  p <- Progress$new(session, min = min, max = max, style = style)
-
-  session$progressStack$push(p)
-  on.exit({
-    session$progressStack$pop()
-    p$close()
-  })
-
-  p$set(value, message, detail)
-
-  eval(expr, env)
-}
-
-#' @rdname withProgress
-#' @export
-setProgress <- function(value = NULL, message = NULL, detail = NULL,
-                        session = getDefaultReactiveDomain()) {
-
-  if (is.null(session$progressStack))
-    stop("'session' is not a ShinySession object.")
-
-  if (session$progressStack$size() == 0) {
-    warning('setProgress was called outside of withProgress; ignoring')
-    return()
-  }
-
-  session$progressStack$peek()$set(value, message, detail)
-  invisible()
-}
-
-#' @rdname withProgress
-#' @export
-incProgress <- function(amount = 0.1, message = NULL, detail = NULL,
-                        session = getDefaultReactiveDomain()) {
-
-  if (is.null(session$progressStack))
-    stop("'session' is not a ShinySession object.")
-
-  if (session$progressStack$size() == 0) {
-    warning('incProgress was called outside of withProgress; ignoring')
-    return()
-  }
-
-  p <- session$progressStack$peek()
-  p$inc(amount, message, detail)
-  invisible()
-}

R/react.R

@@ -1,95 +1,45 @@
-processId <- local({
-  # pid is not sufficient to uniquely identify a process, because
-  # distributed futures span machines which could introduce pid
-  # collisions.
-  cached <- NULL
-  function() {
-    if (is.null(cached)) {
-      cached <<- digest::digest(list(
-        Sys.info(),
-        Sys.time()
-      ))
-    }
-    # Sys.getpid() cannot be cached because forked children will
-    # then have the same processId as their parents.
-    paste(cached, Sys.getpid())
-  }
-})
-
-#' @include graph.R
-Context <- R6Class(
+Context <- setRefClass(
   'Context',
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    id = character(0),
-    .reactId = character(0),
-    .reactType = "other",
-    .label = character(0),      # For debug purposes
-    .invalidated = FALSE,
-    .invalidateCallbacks = list(),
-    .flushCallbacks = list(),
-    .domain = NULL,
-    .pid = NULL,
-    .weak = NULL,
-
-    initialize = function(
-      domain, label='', type='other', prevId='',
-      reactId = rLog$noReactId,
-      id = .getReactiveEnvironment()$nextId(), # For dummy context
-      weak = FALSE
-    ) {
-      id <<- id
+  fields = list(
+    id = 'character',
+    .label = 'character',      # For debug purposes
+    .invalidated = 'logical',
+    .invalidateCallbacks = 'list',
+    .flushCallbacks = 'list'
+  ),
+  methods = list(
+    initialize = function(label='', type='other', prevId='') {
+      id <<- .getReactiveEnvironment()$nextId()
+      .invalidated <<- FALSE
+      .invalidateCallbacks <<- list()
+      .flushCallbacks <<- list()
       .label <<- label
-      .domain <<- domain
-      .pid <<- processId()
-      .reactId <<- reactId
-      .reactType <<- type
-      .weak <<- weak
-      rLog$createContext(id, label, type, prevId, domain)
+      .graphCreateContext(id, label, type, prevId)
     },
     run = function(func) {
       "Run the provided function under this context."
-
-      promises::with_promise_domain(reactivePromiseDomain(), {
-        withReactiveDomain(.domain, {
-          env <- .getReactiveEnvironment()
-          rLog$enter(.reactId, id, .reactType, .domain)
-          on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
-          env$runWith(self, func)
-        })
-      })
+      env <- .getReactiveEnvironment()
+      .graphEnterContext(id)
+      on.exit(.graphExitContext(id))
+      env$runWith(.self, func)
     },
     invalidate = function() {
       "Invalidate this context. It will immediately call the callbacks
         that have been registered with onInvalidate()."
-
-      if (!identical(.pid, processId())) {
-        stop("Reactive context was created in one process and invalidated from another")
-      }
-
       if (.invalidated)
         return()
       .invalidated <<- TRUE
 
-      rLog$invalidateStart(.reactId, id, .reactType, .domain)
-      on.exit(rLog$invalidateEnd(.reactId, id, .reactType, .domain), add = TRUE)
-
+      .graphInvalidate(id)
       lapply(.invalidateCallbacks, function(func) {
         func()
       })
-      .invalidateCallbacks <<- list()
       NULL
     },
     onInvalidate = function(func) {
       "Register a function to be called when this context is invalidated.
         If this context is already invalidated, the function is called
         immediately."
-
-      if (!identical(.pid, processId())) {
-        stop("Reactive context was created in one process and accessed from another")
-      }
-
       if (.invalidated)
         func()
       else
@@ -99,7 +49,7 @@ Context <- R6Class(
     addPendingFlush = function(priority) {
       "Tell the reactive environment that this context should be flushed the
         next time flushReact() called."
-      .getReactiveEnvironment()$addPendingFlush(self, priority)
+      .getReactiveEnvironment()$addPendingFlush(.self, priority)
     },
     onFlush = function(func) {
       "Register a function to be called when this context is flushed."
@@ -107,29 +57,33 @@ Context <- R6Class(
     },
     executeFlushCallbacks = function() {
       "For internal use only."
-
-      lapply(.flushCallbacks, function(flushCallback) {
-        flushCallback()
+      lapply(.flushCallbacks, function(func) {
+        withCallingHandlers({
+          func()
+        }, warning = function(e) {
+          # TODO: Callbacks in app
+        }, error = function(e) {
+          # TODO: Callbacks in app
+        })
       })
-    },
-    isWeak = function() {
-      .weak
     }
   )
 )
 
-ReactiveEnvironment <- R6Class(
+ReactiveEnvironment <- setRefClass(
   'ReactiveEnvironment',
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    .currentContext = NULL,
-    .nextId = 0L,
+  fields = list(
+    .currentContext = 'ANY',
+    .nextId = 'integer',
     .pendingFlush = 'PriorityQueue',
-    .inFlush = FALSE,
-
+    .inFlush = 'logical'
+  ),
+  methods = list(
     initialize = function() {
+      .currentContext <<- NULL
+      .nextId <<- 0L
       .pendingFlush <<- PriorityQueue$new()
+      .inFlush <<- FALSE
     },
     nextId = function() {
       .nextId <<- .nextId + 1L
@@ -137,63 +91,43 @@ ReactiveEnvironment <- R6Class(
     },
     currentContext = function() {
       if (is.null(.currentContext)) {
-        if (isTRUE(getOption('shiny.suppressMissingContextError'))) {
-          return(getDummyContext())
-        } else {
-          stop('Operation not allowed without an active reactive context. ',
-               '(You tried to do something that can only be done from inside a ',
-               'reactive expression or observer.)')
-        }
+        stop('Operation not allowed without an active reactive context. ',
+             '(You tried to do something that can only be done from inside a ',
+             'reactive function.)')
       }
       return(.currentContext)
     },
-    runWith = function(ctx, contextFunc) {
+    runWith = function(ctx, func) {
       old.ctx <- .currentContext
       .currentContext <<- ctx
       on.exit(.currentContext <<- old.ctx)
-      contextFunc()
+      func()
     },
     addPendingFlush = function(ctx, priority) {
       .pendingFlush$enqueue(ctx, priority)
     },
-    hasPendingFlush = function() {
-      return(!.pendingFlush$isEmpty())
-    },
-    # Returns TRUE if anything was actually called
     flush = function() {
-      # If nothing to flush, exit early
-      if (!hasPendingFlush()) return(invisible(FALSE))
       # If already in a flush, don't start another one
-      if (.inFlush) return(invisible(FALSE))
+      if (.inFlush) return()
       .inFlush <<- TRUE
-      on.exit({
-        .inFlush <<- FALSE
-        rLog$idle(domain = NULL)
-      })
+      on.exit(.inFlush <<- FALSE)
 
-      while (hasPendingFlush()) {
+      while (!.pendingFlush$isEmpty()) {
         ctx <- .pendingFlush$dequeue()
         ctx$executeFlushCallbacks()
       }
-
-      invisible(TRUE)
     }
   )
 )
 
-.getReactiveEnvironment <- local({
-  reactiveEnvironment <- NULL
-  function() {
-    if (is.null(reactiveEnvironment))
-      reactiveEnvironment <<- ReactiveEnvironment$new()
-    return(reactiveEnvironment)
-  }
-})
+.reactiveEnvironment <- ReactiveEnvironment$new()
+.getReactiveEnvironment <- function() {
+  .reactiveEnvironment
+}
 
-# Causes any pending invalidations to run. Returns TRUE if any invalidations
-# were pending (i.e. if work was actually done).
+# Causes any pending invalidations to run.
 flushReact <- function() {
-  return(.getReactiveEnvironment()$flush())
+  .getReactiveEnvironment()$flush()
 }
 
 # Retrieves the current reactive context, or errors if there is no reactive
@@ -201,41 +135,3 @@ flushReact <- function() {
 getCurrentContext <- function() {
   .getReactiveEnvironment()$currentContext()
 }
-hasCurrentContext <- function() {
-  !is.null(.getReactiveEnvironment()$.currentContext)
-}
-
-getDummyContext <- function() {
-  Context$new(
-    getDefaultReactiveDomain(), '[none]', type = 'isolate',
-    id = "Dummy", reactId = rLog$dummyReactId
-  )
-}
-
-wrapForContext <- function(func, ctx) {
-  force(func)
-  force(ctx)
-
-  function(...) {
-    ctx$run(function() {
-      captureStackTraces(
-        func(...)
-      )
-    })
-  }
-}
-
-reactivePromiseDomain <- function() {
-  promises::new_promise_domain(
-    wrapOnFulfilled = function(onFulfilled) {
-      force(onFulfilled)
-      ctx <- getCurrentContext()
-      wrapForContext(onFulfilled, ctx)
-    },
-    wrapOnRejected = function(onRejected) {
-      force(onRejected)
-      ctx <- getCurrentContext()
-      wrapForContext(onRejected, ctx)
-    }
-  )
-}

R/reactive-domains.R

@@ -1,251 +0,0 @@
-#' @include globals.R
-NULL
-
-#
-# Over the last few months we've seen a number of cases where it'd be helpful
-# for objects that are instantiated within a Shiny app to know what Shiny
-# session they are "owned" by. I put "owned" in quotes because there isn't a
-# built-in notion of object ownership in Shiny today, any more than there is a
-# notion of one object owning another in R.
-#
-# But it's intuitive to everyone, I think, that the outputs for a session are
-# owned by that session, and any logic that is executed as part of the output
-# is done on behalf of that session. And it seems like in the vast majority of
-# cases, observers that are created inside a shinyServer function (i.e. one per
-# session) are also intuitively owned by the session that's starting up.
-#
-# This notion of ownership is important/helpful for a few scenarios that have
-# come up in recent months:
-#
-# 1. The showcase mode that Jonathan implemented recently highlights
-# observers/reactives as they execute. In order for sessions to only receive
-# highlights for their own code execution, we need to know which sessions own
-# which observers. 2. We've seen a number of apps crash out when observers
-# outlive their sessions and then try to do things with their sessions (the
-# most common error message was something like "Can't write to a closed
-# websocket", but we now silently ignore writes to closed websockets). It'd be
-# convenient for the default behavior of observers to be that they don't
-# outlive their parent sessions. 3. The reactive log visualizer currently
-# visualizes all reactivity in the process; it would be great if by default it
-# only visualized the current session. 4. When an observer has an error, it
-# would be great to be able to send the error to the session so it can do its
-# own handling (such as sending the error info to the client so the user can be
-# notified). 5. Shiny Server Pro wants to show the admin how much time is being
-# spent servicing each session.
-#
-# So what are the rules for establishing ownership?
-#
-# 1. Define the "current domain" as a global variable whose value will own any
-# newly created observer (by default). A domain is a reference class or
-# environment that contains the functions `onEnded(callback)`, `isEnded()`, and
-# `reactlog(logEntry)`.
-#
-## ------------------------------------------------------------------------
-createMockDomain <- function() {
-  callbacks <- Callbacks$new()
-  ended <- FALSE
-  domain <- new.env(parent = emptyenv())
-  domain$onEnded <- function(callback) {
-    return(callbacks$register(callback))
-  }
-  domain$isEnded <- function() {
-    ended
-  }
-  domain$reactlog <- function(logEntry) NULL
-  domain$end <- function() {
-    if (!ended) {
-      ended <<- TRUE
-      callbacks$invoke()
-    }
-    invisible()
-  }
-  domain$incrementBusyCount <- function() NULL
-  domain$decrementBusyCount <- function() NULL
-  return(domain)
-}
-
-#
-# 2. The initial value of "current domain" is null.
-#
-## ------------------------------------------------------------------------
-.globals$domain <- NULL
-
-#
-# 3. Objects that can be owned include observers, reactive expressions,
-# invalidateLater instances, reactiveTimer instances. Whenever one of these is
-# created, by default its owner will be the current domain.
-#
-## ------------------------------------------------------------------------
-
-#' @name domains
-#' @rdname domains
-#' @export
-getDefaultReactiveDomain <- function() {
-  .globals$domain
-}
-
-#
-# 4. While a session is being created and the shinyServer function is executed,
-# the current domain is set to the new session. When the shinyServer function
-# is done executing, the previous value of the current domain is restored. This
-# is made foolproof using a `withReactiveDomain` function.
-#
-## ------------------------------------------------------------------------
-
-#' @rdname domains
-#' @export
-withReactiveDomain <- function(domain, expr) {
-  promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
-}
-
-#
-# 5. While an observer or reactive expression is executing, the current domain
-# is set to the owner of the observer. When the observer completes, the
-# previous value of the current domain is restored.
-#
-# 6. Note that once created, an observer/reactive expression belongs to the
-# same domain forever, regardless of how many times it is invalidated and
-# re-executed, and regardless of what caused the invalidation to happen.
-#
-# 7. When a session ends, any observers that it owns are suspended, any
-# invalidateLater/reactiveTimers are stopped.
-#
-## ------------------------------------------------------------------------
-
-#' @rdname domains
-#' @export
-onReactiveDomainEnded <- function(domain, callback, failIfNull = FALSE) {
-  if (is.null(domain)) {
-    if (isTRUE(failIfNull))
-      stop("onReactiveDomainEnded called with null domain and failIfNull=TRUE")
-    else
-      return()
-  }
-  domain$onEnded(callback)
-}
-
-#
-# 8. If an uncaught error occurs while executing an observer, the session gets
-# a chance to handle it. I suppose the default behavior would be to send the
-# message to the client if possible, and then perhaps end the session (or not,
-# I could argue either way).
-#
-# The basic idea here is inspired by Node.js domains, which you can think of as
-# a way to track execution contexts across callback- or listener-oriented
-# asynchronous code. They use it to unify error handling code across a graph of
-# related objects. Our domains will be to unify both lifetime and error
-# handling across a graph of related reactive primitives.
-#
-# (You could imagine that as a client update is being processed, the session
-# associated with that client would become the current domain. IIRC this is how
-# showcase mode is implemented today. I don't think this would cover any cases
-# not covered by rule 5 above, and the absence of rule 5 would leave cases that
-# this rule would not cover.)
-#
-# Pitfalls/open issues:
-#
-# 1. Our current approach has the issue of observers staying alive longer than
-# they ought to. This proposal introduces the opposite risk: that
-# observers/invalidateLater/reactiveTimer instances, having implicitly been
-# assigned a parent, are suspended/disposed earlier than they ought to have
-# been. I find this especially worrisome for invalidateLater/reactiveTimer,
-# which will often be called in a reactive expression, and thus execute under
-# unpredictable circumstances. Perhaps those should continue to accept an
-# explicit "session=" parameter that the user is warned about if they don't
-# provide a value.
-#
-# 2. Are there situations where it is ambiguous what the right thing to do is,
-# and we should warn/error to ask the user to provide a domain explicitly?
-#
-## ------------------------------------------------------------------------
-
-#' Reactive domains
-#'
-#' Reactive domains are a mechanism for establishing ownership over reactive
-#' primitives (like reactive expressions and observers), even if the set of
-#' reactive primitives is dynamically created. This is useful for lifetime
-#' management (i.e. destroying observers when the Shiny session that created
-#' them ends) and error handling.
-#'
-#' At any given time, there can be either a single "default" reactive domain
-#' object, or none (i.e. the reactive domain object is `NULL`). You can
-#' access the current default reactive domain by calling
-#' `getDefaultReactiveDomain`.
-#'
-#' Unless you specify otherwise, newly created observers and reactive
-#' expressions will be assigned to the current default domain (if any). You can
-#' override this assignment by providing an explicit `domain` argument to
-#' [reactive()] or [observe()].
-#'
-#' For advanced usage, it's possible to override the default domain using
-#' `withReactiveDomain`. The `domain` argument will be made the
-#' default domain while `expr` is evaluated.
-#'
-#' Implementers of new reactive primitives can use `onReactiveDomainEnded`
-#' as a convenience function for registering callbacks. If the reactive domain
-#' is `NULL` and `failIfNull` is `FALSE`, then the callback will
-#' never be invoked.
-#'
-#' @name domains
-#' @param domain A valid domain object (for example, a Shiny session), or
-#'   `NULL`
-#' @param expr An expression to evaluate under `domain`
-#' @param callback A callback function to be invoked
-#' @param failIfNull If `TRUE` then an error is given if the `domain`
-#'   is `NULL`
-NULL
-
-#
-# Example 1
-# ---
-# ```
-# obs1 <- observe({
-# })
-# shinyServer(function(input, output) {
-#   obs2 <- observe({
-#     obs3 <- observe({
-#     })
-#   })
-# })
-# # obs1 would have no domain, obs2 and obs3 would be owned by the session
-# ```
-#
-# Example 2
-# ---
-# ```
-# globalValues <- reactiveValues(broadcast="")
-# shinyServer(function(input, output) {
-#   sessionValues <- reactiveValues()
-#   output$messageOutput <- renderText({
-#     globalValues$broadcast
-#     obs1 <- observe({...})
-#   })
-#   observe({
-#     if (input$goButton == 0) return()
-#     isolate( globalValues$broadcast <- input$messageInput )
-#   })
-# })
-# # The observer behind messageOutput would be owned by the session,
-# # as would all the many instances of obs1 that were created.
-# ```
-# ---
-#
-# Example 3
-# ---
-# ```
-# rexpr1 <- reactive({
-#   invalidateLater(1000)
-#   obs1 <- observe({...})
-# })
-# observeSomething <- function() {
-#   obs2 <- observe({...})
-# })
-# shinyServer(function(input, output) {
-#   obs3 <- observe({
-#     observeSomething()
-#     rexpr1()
-#   })
-# })
-# # rexpr1, the invalidateLater call, and obs1 would all have no owner;
-# # obs2 and obs3 would be owned by the session.
-# ```

R/reexports.R

@@ -1,195 +0,0 @@
-####
-# Generated by `./tools/updateReexports.R`: do not edit by hand
-# Please call `source('tools/updateReexports.R') from the root folder to update`
-####
-
-
-# fastmap key_missing.Rd -------------------------------------------------------
-
-#' @importFrom fastmap key_missing
-#' @export
-fastmap::key_missing
-
-#' @importFrom fastmap is.key_missing
-#' @export
-fastmap::is.key_missing
-
-
-
-# htmltools builder.Rd ---------------------------------------------------------
-
-#' @importFrom htmltools tags
-#' @export
-htmltools::tags
-
-#' @importFrom htmltools p
-#' @export
-htmltools::p
-
-#' @importFrom htmltools h1
-#' @export
-htmltools::h1
-
-#' @importFrom htmltools h2
-#' @export
-htmltools::h2
-
-#' @importFrom htmltools h3
-#' @export
-htmltools::h3
-
-#' @importFrom htmltools h4
-#' @export
-htmltools::h4
-
-#' @importFrom htmltools h5
-#' @export
-htmltools::h5
-
-#' @importFrom htmltools h6
-#' @export
-htmltools::h6
-
-#' @importFrom htmltools a
-#' @export
-htmltools::a
-
-#' @importFrom htmltools br
-#' @export
-htmltools::br
-
-#' @importFrom htmltools div
-#' @export
-htmltools::div
-
-#' @importFrom htmltools span
-#' @export
-htmltools::span
-
-#' @importFrom htmltools pre
-#' @export
-htmltools::pre
-
-#' @importFrom htmltools code
-#' @export
-htmltools::code
-
-#' @importFrom htmltools img
-#' @export
-htmltools::img
-
-#' @importFrom htmltools strong
-#' @export
-htmltools::strong
-
-#' @importFrom htmltools em
-#' @export
-htmltools::em
-
-#' @importFrom htmltools hr
-#' @export
-htmltools::hr
-
-
-# htmltools tag.Rd -------------------------------------------------------------
-
-#' @importFrom htmltools tag
-#' @export
-htmltools::tag
-
-#' @importFrom htmltools tagList
-#' @export
-htmltools::tagList
-
-#' @importFrom htmltools tagAppendAttributes
-#' @export
-htmltools::tagAppendAttributes
-
-#' @importFrom htmltools tagHasAttribute
-#' @export
-htmltools::tagHasAttribute
-
-#' @importFrom htmltools tagGetAttribute
-#' @export
-htmltools::tagGetAttribute
-
-#' @importFrom htmltools tagAppendChild
-#' @export
-htmltools::tagAppendChild
-
-#' @importFrom htmltools tagAppendChildren
-#' @export
-htmltools::tagAppendChildren
-
-#' @importFrom htmltools tagSetChildren
-#' @export
-htmltools::tagSetChildren
-
-
-# htmltools HTML.Rd ------------------------------------------------------------
-
-#' @importFrom htmltools HTML
-#' @export
-htmltools::HTML
-
-
-# htmltools include.Rd ---------------------------------------------------------
-
-#' @importFrom htmltools includeHTML
-#' @export
-htmltools::includeHTML
-
-#' @importFrom htmltools includeText
-#' @export
-htmltools::includeText
-
-#' @importFrom htmltools includeMarkdown
-#' @export
-htmltools::includeMarkdown
-
-#' @importFrom htmltools includeCSS
-#' @export
-htmltools::includeCSS
-
-#' @importFrom htmltools includeScript
-#' @export
-htmltools::includeScript
-
-
-# htmltools singleton.Rd -------------------------------------------------------
-
-#' @importFrom htmltools singleton
-#' @export
-htmltools::singleton
-
-#' @importFrom htmltools is.singleton
-#' @export
-htmltools::is.singleton
-
-
-# htmltools validateCssUnit.Rd -------------------------------------------------
-
-#' @importFrom htmltools validateCssUnit
-#' @export
-htmltools::validateCssUnit
-
-
-# htmltools htmlTemplate.Rd ----------------------------------------------------
-
-#' @importFrom htmltools htmlTemplate
-#' @export
-htmltools::htmlTemplate
-
-
-# htmltools suppressDependencies.Rd --------------------------------------------
-
-#' @importFrom htmltools suppressDependencies
-#' @export
-htmltools::suppressDependencies
-
-
-# htmltools withTags.Rd --------------------------------------------------------
-
-#' @importFrom htmltools withTags
-#' @export
-htmltools::withTags

R/render-cached-plot.R

@@ -1,616 +0,0 @@
-#' Plot output with cached images
-#'
-#' Renders a reactive plot, with plot images cached to disk.
-#'
-#' `expr` is an expression that generates a plot, similar to that in
-#' `renderPlot`. Unlike with `renderPlot`, this expression does not
-#' take reactive dependencies. It is re-executed only when the cache key
-#' changes.
-#'
-#' `cacheKeyExpr` is an expression which, when evaluated, returns an object
-#' which will be serialized and hashed using the [digest::digest()]
-#' function to generate a string that will be used as a cache key. This key is
-#' used to identify the contents of the plot: if the cache key is the same as a
-#' previous time, it assumes that the plot is the same and can be retrieved from
-#' the cache.
-#'
-#' This `cacheKeyExpr` is reactive, and so it will be re-evaluated when any
-#' upstream reactives are invalidated. This will also trigger re-execution of
-#' the plotting expression, `expr`.
-#'
-#' The key should consist of "normal" R objects, like vectors and lists. Lists
-#' should in turn contain other normal R objects. If the key contains
-#' environments, external pointers, or reference objects --- or even if it has
-#' such objects attached as attributes --- then it is possible that it will
-#' change unpredictably even when you do not expect it to. Additionally, because
-#' the entire key is serialized and hashed, if it contains a very large object
-#' --- a large data set, for example --- there may be a noticeable performance
-#' penalty.
-#'
-#' If you face these issues with the cache key, you can work around them by
-#' extracting out the important parts of the objects, and/or by converting them
-#' to normal R objects before returning them. Your expression could even
-#' serialize and hash that information in an efficient way and return a string,
-#' which will in turn be hashed (very quickly) by the
-#' [digest::digest()] function.
-#'
-#' Internally, the result from `cacheKeyExpr` is combined with the name of
-#' the output (if you assign it to `output$plot1`, it will be combined
-#' with `"plot1"`) to form the actual key that is used. As a result, even
-#' if there are multiple plots that have the same `cacheKeyExpr`, they
-#' will not have cache key collisions.
-#'
-#' @section Cache scoping:
-#'
-#'   There are a number of different ways you may want to scope the cache. For
-#'   example, you may want each user session to have their own plot cache, or
-#'   you may want each run of the application to have a cache (shared among
-#'   possibly multiple simultaneous user sessions), or you may want to have a
-#'   cache that persists even after the application is shut down and started
-#'   again.
-#'
-#'   To control the scope of the cache, use the `cache` parameter. There
-#'   are two ways of having Shiny automatically create and clean up the disk
-#'   cache.
-#'
-#' \describe{
-#'   \item{1}{To scope the cache to one run of a Shiny application (shared
-#'     among possibly multiple user sessions), use `cache="app"`. This
-#'     is the default. The cache will be shared across multiple sessions, so
-#'     there is potentially a large performance benefit if there are many users
-#'     of the application. When the application stops running, the cache will
-#'     be deleted. If plots cannot be safely shared across users, this should
-#'     not be used.}
-#'   \item{2}{To scope the cache to one session, use `cache="session"`.
-#'     When a new user session starts --- in other words, when a web browser
-#'     visits the Shiny application --- a new cache will be created on disk
-#'     for that session. When the session ends, the cache will be deleted.
-#'     The cache will not be shared across multiple sessions.}
-#'  }
-#'
-#'   If either `"app"` or `"session"` is used, the cache will be 10 MB
-#'   in size, and will be stored stored in memory, using a
-#'   [memoryCache()] object. Note that the cache space will be shared
-#'   among all cached plots within a single application or session.
-#'
-#'   In some cases, you may want more control over the caching behavior. For
-#'   example, you may want to use a larger or smaller cache, share a cache
-#'   among multiple R processes, or you may want the cache to persist across
-#'   multiple runs of an application, or even across multiple R processes.
-#'
-#'   To use different settings for an application-scoped cache, you can call
-#'   [shinyOptions()] at the top of your app.R, server.R, or
-#'   global.R. For example, this will create a cache with 20 MB of space
-#'   instead of the default 10 MB:
-#'   \preformatted{
-#'   shinyOptions(cache = memoryCache(size = 20e6))
-#'   }
-#'
-#'   To use different settings for a session-scoped cache, you can call
-#'   [shinyOptions()] at the top of your server function. To use
-#'   the session-scoped cache, you must also call `renderCachedPlot` with
-#'   `cache="session"`. This will create a 20 MB cache for the session:
-#'   \preformatted{
-#'   function(input, output, session) {
-#'     shinyOptions(cache = memoryCache(size = 20e6))
-#'
-#'     output$plot <- renderCachedPlot(
-#'       ...,
-#'       cache = "session"
-#'     )
-#'   }
-#'   }
-#'
-#'   If you want to create a cache that is shared across multiple concurrent
-#'   R processes, you can use a [diskCache()]. You can create an
-#'   application-level shared cache by putting this at the top of your app.R,
-#'   server.R, or global.R:
-#'   \preformatted{
-#'   shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
-#'   }
-#'
-#'   This will create a subdirectory in your system temp directory named
-#'   `myapp-cache` (replace `myapp-cache` with a unique name of
-#'   your choosing). On most platforms, this directory will be removed when
-#'   your system reboots. This cache will persist across multiple starts and
-#'   stops of the R process, as long as you do not reboot.
-#'
-#'   To have the cache persist even across multiple reboots, you can create the
-#'   cache in a location outside of the temp directory. For example, it could
-#'   be a subdirectory of the application:
-#'   \preformatted{
-#'   shinyOptions(cache = diskCache("./myapp-cache"))
-#'   }
-#'
-#'   In this case, resetting the cache will have to be done manually, by deleting
-#'   the directory.
-#'
-#'   You can also scope a cache to just one plot, or selected plots. To do that,
-#'   create a [memoryCache()] or [diskCache()], and pass it
-#'   as the `cache` argument of `renderCachedPlot`.
-#'
-#' @section Interactive plots:
-#'
-#'   `renderCachedPlot` can be used to create interactive plots. See
-#'   [plotOutput()] for more information and examples.
-#'
-#'
-#' @inheritParams renderPlot
-#' @param cacheKeyExpr An expression that returns a cache key. This key should
-#'   be a unique identifier for a plot: the assumption is that if the cache key
-#'   is the same, then the plot will be the same.
-#' @param sizePolicy A function that takes two arguments, `width` and
-#'   `height`, and returns a list with `width` and `height`. The
-#'   purpose is to round the actual pixel dimensions from the browser to some
-#'   other dimensions, so that this will not generate and cache images of every
-#'   possible pixel dimension. See [sizeGrowthRatio()] for more
-#'   information on the default sizing policy.
-#' @param res The resolution of the PNG, in pixels per inch.
-#' @param cache The scope of the cache, or a cache object. This can be
-#'   `"app"` (the default), `"session"`, or a cache object like
-#'   a [diskCache()]. See the Cache Scoping section for more
-#'   information.
-#' @param width,height not used. They are specified via the argument
-#'   `sizePolicy`.
-#'
-#' @seealso See [renderPlot()] for the regular, non-cached version of
-#'   this function. For more about configuring caches, see
-#'   [memoryCache()] and [diskCache()].
-#'
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#' # A basic example that uses the default app-scoped memory cache.
-#' # The cache will be shared among all simultaneous users of the application.
-#' shinyApp(
-#'   fluidPage(
-#'     sidebarLayout(
-#'       sidebarPanel(
-#'         sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
-#'       ),
-#'       mainPanel(plotOutput("plot"))
-#'     )
-#'   ),
-#'   function(input, output, session) {
-#'     output$plot <- renderCachedPlot({
-#'         Sys.sleep(2)  # Add an artificial delay
-#'         seqn <- seq_len(input$n)
-#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
-#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
-#'       },
-#'       cacheKeyExpr = { list(input$n) }
-#'     )
-#'   }
-#' )
-#'
-#'
-#'
-#' # An example uses a data object shared across sessions. mydata() is part of
-#' # the cache key, so when its value changes, plots that were previously
-#' # stored in the cache will no longer be used (unless mydata() changes back
-#' # to its previous value).
-#' mydata <- reactiveVal(data.frame(x = rnorm(400), y = rnorm(400)))
-#'
-#' ui <- fluidPage(
-#'   sidebarLayout(
-#'     sidebarPanel(
-#'       sliderInput("n", "Number of points", 50, 400, 100, step = 50),
-#'       actionButton("newdata", "New data")
-#'     ),
-#'     mainPanel(
-#'       plotOutput("plot")
-#'     )
-#'   )
-#' )
-#'
-#' server <- function(input, output, session) {
-#'   observeEvent(input$newdata, {
-#'     mydata(data.frame(x = rnorm(400), y = rnorm(400)))
-#'   })
-#'
-#'   output$plot <- renderCachedPlot(
-#'     {
-#'       Sys.sleep(2)
-#'       d <- mydata()
-#'       seqn <- seq_len(input$n)
-#'       plot(d$x[seqn], d$y[seqn], xlim = range(d$x), ylim = range(d$y))
-#'     },
-#'     cacheKeyExpr = { list(input$n, mydata()) },
-#'   )
-#' }
-#'
-#' shinyApp(ui, server)
-#'
-#'
-#' # A basic application with two plots, where each plot in each session has
-#' # a separate cache.
-#' shinyApp(
-#'   fluidPage(
-#'     sidebarLayout(
-#'       sidebarPanel(
-#'         sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
-#'       ),
-#'       mainPanel(
-#'         plotOutput("plot1"),
-#'         plotOutput("plot2")
-#'       )
-#'     )
-#'   ),
-#'   function(input, output, session) {
-#'     output$plot1 <- renderCachedPlot({
-#'         Sys.sleep(2)  # Add an artificial delay
-#'         seqn <- seq_len(input$n)
-#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
-#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
-#'       },
-#'       cacheKeyExpr = { list(input$n) },
-#'       cache = memoryCache()
-#'     )
-#'     output$plot2 <- renderCachedPlot({
-#'         Sys.sleep(2)  # Add an artificial delay
-#'         seqn <- seq_len(input$n)
-#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
-#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
-#'       },
-#'       cacheKeyExpr = { list(input$n) },
-#'       cache = memoryCache()
-#'     )
-#'   }
-#' )
-#'
-#' }
-#'
-#' \dontrun{
-#' # At the top of app.R, this set the application-scoped cache to be a memory
-#' # cache that is 20 MB in size, and where cached objects expire after one
-#' # hour.
-#' shinyOptions(cache = memoryCache(max_size = 20e6, max_age = 3600))
-#'
-#' # At the top of app.R, this set the application-scoped cache to be a disk
-#' # cache that can be shared among multiple concurrent R processes, and is
-#' # deleted when the system reboots.
-#' shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
-#'
-#' # At the top of app.R, this set the application-scoped cache to be a disk
-#' # cache that can be shared among multiple concurrent R processes, and
-#' # persists on disk across reboots.
-#' shinyOptions(cache = diskCache("./myapp-cache"))
-#'
-#' # At the top of the server function, this set the session-scoped cache to be
-#' # a memory cache that is 5 MB in size.
-#' server <- function(input, output, session) {
-#'   shinyOptions(cache = memoryCache(max_size = 5e6))
-#'
-#'   output$plot <- renderCachedPlot(
-#'     ...,
-#'     cache = "session"
-#'   )
-#' }
-#'
-#' }
-#' @export
-renderCachedPlot <- function(expr,
-  cacheKeyExpr,
-  sizePolicy = sizeGrowthRatio(width = 400, height = 400, growthRate = 1.2),
-  res = 72,
-  cache = "app",
-  ...,
-  alt = "Plot object",
-  outputArgs = list(),
-  width = NULL,
-  height = NULL
-) {
-
-  # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
-  # is called
-  installExprFunction(expr, "func", parent.frame(), quoted = FALSE, ..stacktraceon = TRUE)
-  # This is so that the expr doesn't re-execute by itself; it needs to be
-  # triggered by the cache key (or width/height) changing.
-  isolatedFunc <- function() isolate(func())
-
-  args <- list(...)
-
-  if (!is.null(width) || !is.null(height)) {
-    warning("Unused argument(s) 'width' and/or 'height'. ",
-            "'sizePolicy' is used instead.")
-  }
-
-  cacheKeyExpr <- substitute(cacheKeyExpr)
-  # The real cache key we'll use also includes width, height, res, pixelratio.
-  # This is just the part supplied by the user.
-  userCacheKey <- reactive(cacheKeyExpr, env = parent.frame(), quoted = TRUE, label = "userCacheKey")
-
-  ensureCacheSetup <- function() {
-    # For our purposes, cache objects must support these methods.
-    isCacheObject <- function(x) {
-      # Use tryCatch in case the object does not support `$`.
-      tryCatch(
-        is.function(x$get) && is.function(x$set),
-        error = function(e) FALSE
-      )
-    }
-
-    if (isCacheObject(cache)) {
-      # If `cache` is already a cache object, do nothing
-      return()
-
-    } else if (identical(cache, "app")) {
-      cache <<- getShinyOption("cache")
-
-    } else if (identical(cache, "session")) {
-      cache <<- session$cache
-
-    } else {
-      stop('`cache` must either be "app", "session", or a cache object with methods, `$get`, and `$set`.')
-    }
-  }
-
-  # The width and height of the plot to draw, given from sizePolicy. These
-  # values get filled by an observer below.
-  fitDims <- reactiveValues(width = NULL, height = NULL)
-
-  # Make sure alt param to be reactive function
-  if (is.reactive(alt))
-    altWrapper <- alt
-  else if (is.function(alt))
-    altWrapper <- reactive({ alt() })
-  else
-    altWrapper <- function() { alt }
-
-  resizeObserver <- NULL
-  ensureResizeObserver <- function() {
-    if (!is.null(resizeObserver))
-      return()
-
-    # Given the actual width/height of the image in the browser, this gets the
-    # width/height from sizePolicy() and pushes those values into `fitDims`.
-    # It's done this way so that the `fitDims` only change (and cause
-    # invalidations) when the rendered image size changes, and not every time
-    # the browser's <img> tag changes size.
-    doResizeCheck <- function() {
-      width  <- session$clientData[[paste0('output_', outputName, '_width')]]
-      height <- session$clientData[[paste0('output_', outputName, '_height')]]
-
-      if (is.null(width)) width <- 0
-      if (is.null(height)) height <- 0
-
-      rect <- sizePolicy(c(width, height))
-      fitDims$width  <- rect[1]
-      fitDims$height <- rect[2]
-    }
-
-    # Run it once immediately, then set up the observer
-    isolate(doResizeCheck())
-
-    resizeObserver <<- observe(doResizeCheck())
-  }
-
-  # Vars to store session and output, so that they can be accessed from
-  # the plotObj() reactive.
-  session <- NULL
-  outputName <- NULL
-
-
-  drawReactive <- reactive(label = "plotObj", {
-    hybrid_chain(
-      # Depend on the user cache key, even though we don't use the value. When
-      # it changes, it can cause the drawReactive to re-execute. (Though
-      # drawReactive will not necessarily re-execute --- it must be called from
-      # renderFunc, which happens only if there's a cache miss.)
-      userCacheKey(),
-      function(userCacheKeyValue) {
-        # Get width/height, but don't depend on them.
-        isolate({
-          width  <- fitDims$width
-          height <- fitDims$height
-          # Make sure alt text to be reactive function
-          alt <- altWrapper()
-        })
-
-        pixelratio <- session$clientData$pixelratio %OR% 1
-
-        do.call("drawPlot", c(
-          list(
-            name = outputName,
-            session = session,
-            func = isolatedFunc,
-            width = width,
-            height = height,
-            alt = alt,
-            pixelratio = pixelratio,
-            res = res
-          ),
-          args
-        ))
-      },
-      catch = function(reason) {
-        # Non-isolating read. A common reason for errors in plotting is because
-        # the dimensions are too small. By taking a dependency on width/height,
-        # we can try again if the plot output element changes size.
-        fitDims$width
-        fitDims$height
-
-        # Propagate the error
-        stop(reason)
-      }
-    )
-  })
-
-
-  # This function is the one that's returned from renderPlot(), and gets
-  # wrapped in an observer when the output value is assigned.
-  renderFunc <- function(shinysession, name, ...) {
-    outputName <<- name
-    session <<- shinysession
-    ensureCacheSetup()
-    ensureResizeObserver()
-
-    hybrid_chain(
-      # This use of the userCacheKey() sets up the reactive dependency that
-      # causes plot re-draw events. These may involve pulling from the cache,
-      # replaying a display list, or re-executing user code.
-      userCacheKey(),
-      function(userCacheKeyResult) {
-        width  <- fitDims$width
-        height <- fitDims$height
-        alt <- altWrapper()
-        pixelratio <- session$clientData$pixelratio %OR% 1
-
-        key <- digest::digest(list(outputName, userCacheKeyResult, width, height, res, pixelratio), "xxhash64")
-
-        plotObj <- cache$get(key)
-
-        # First look in cache.
-        # Case 1. cache hit.
-        if (!is.key_missing(plotObj)) {
-          return(list(
-            cacheHit = TRUE,
-            key = key,
-            plotObj = plotObj,
-            width = width,
-            height = height,
-            alt = alt,
-            pixelratio = pixelratio
-          ))
-        }
-
-        # If not in cache, hybrid_chain call to drawReactive
-        #
-        # Two more possible cases:
-        #   2. drawReactive will re-execute and return a plot that's the
-        #      correct size.
-        #   3. It will not re-execute, but it will return the previous value,
-        #      which is the wrong size. It will include a valid display list
-        #      which can be used by resizeSavedPlot.
-        hybrid_chain(
-          drawReactive(),
-          function(drawReactiveResult) {
-            # Pass along the key for caching in the next stage
-            list(
-              cacheHit = FALSE,
-              key = key,
-              plotObj = drawReactiveResult,
-              width = width,
-              height = height,
-              alt = alt,
-              pixelratio = pixelratio
-            )
-          }
-        )
-      },
-      function(possiblyAsyncResult) {
-        hybrid_chain(possiblyAsyncResult, function(result) {
-          width      <- result$width
-          height     <- result$height
-          alt        <- result$alt
-          pixelratio <- result$pixelratio
-
-          # Three possibilities when we get here:
-          # 1. There was a cache hit. No need to set a value in the cache.
-          # 2. There was a cache miss, and the plotObj is already the correct
-          #    size (because drawReactive re-executed). In this case, we need
-          #    to cache it.
-          # 3. There was a cache miss, and the plotObj was not the corect size.
-          #    In this case, we need to replay the display list, and then cache
-          #    the result.
-          if (!result$cacheHit) {
-            # If the image is already the correct size, this just returns the
-            # object unchanged.
-            result$plotObj <- do.call("resizeSavedPlot", c(
-              list(
-                name,
-                shinysession,
-                result$plotObj,
-                width,
-                height,
-                alt,
-                pixelratio,
-                res
-              ),
-              args
-            ))
-
-            # Save a cached copy of the plotObj. The recorded displaylist for
-            # the plot can't be serialized and restored properly within the same
-            # R session, so we NULL it out before saving. (The image data and
-            # other metadata be saved and restored just fine.) Displaylists can
-            # also be very large (~1.5MB for a basic ggplot), and they would not
-            # be commonly used. Note that displaylist serialization was fixed in
-            # revision 74506 (2e6c669), and should be in R 3.6. A MemoryCache
-            # doesn't need to serialize objects, so it could actually save a
-            # display list, but for the reasons listed previously, it's
-            # generally not worth it.
-            # The plotResult is not the same as the recordedPlot (it is used to
-            # retrieve coordmap information for ggplot2 objects) but it is only
-            # used in conjunction with the recordedPlot, and we'll remove it
-            # because it can be quite large.
-            result$plotObj$plotResult <- NULL
-            result$plotObj$recordedPlot <- NULL
-            cache$set(result$key, result$plotObj)
-          }
-
-          img <- result$plotObj$img
-          # Replace exact pixel dimensions; instead, the max-height and
-          # max-width will be set to 100% from CSS.
-          img$class <- "shiny-scalable"
-          img$width  <- NULL
-          img$height <- NULL
-
-          img
-        })
-      }
-    )
-  }
-
-  # If renderPlot isn't going to adapt to the height of the div, then the
-  # div needs to adapt to the height of renderPlot. By default, plotOutput
-  # sets the height to 400px, so to make it adapt we need to override it
-  # with NULL.
-  outputFunc <- plotOutput
-  formals(outputFunc)['height'] <- list(NULL)
-
-  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
-}
-
-
-#' Create a sizing function that grows at a given ratio
-#'
-#' Returns a function which takes a two-element vector representing an input
-#' width and height, and returns a two-element vector of width and height. The
-#' possible widths are the base width times the growthRate to any integer power.
-#' For example, with a base width of 500 and growth rate of 1.25, the possible
-#' widths include 320, 400, 500, 625, 782, and so on, both smaller and larger.
-#' Sizes are rounded up to the next pixel. Heights are computed the same way as
-#' widths.
-#'
-#' @param width,height Base width and height.
-#' @param growthRate Growth rate multiplier.
-#'
-#' @seealso This is to be used with [renderCachedPlot()].
-#'
-#' @examples
-#' f <- sizeGrowthRatio(500, 500, 1.25)
-#' f(c(400, 400))
-#' f(c(500, 500))
-#' f(c(530, 550))
-#' f(c(625, 700))
-#'
-#' @export
-sizeGrowthRatio <- function(width = 400, height = 400, growthRate = 1.2) {
-  round_dim_up <- function(x, base, rate) {
-    power <- ceiling(log(x / base, rate))
-    ceiling(base * rate^power)
-  }
-
-  function(dims) {
-    if (length(dims) != 2) {
-      stop("dims must be a vector with two numbers, for width and height.")
-    }
-    c(
-      round_dim_up(dims[1], width,  growthRate),
-      round_dim_up(dims[2], height, growthRate)
-    )
-  }
-}

R/render-table.R

@@ -1,228 +0,0 @@
-#' Table Output
-#'
-#' Creates a reactive table that is suitable for assigning to an `output`
-#' slot.
-#'
-#' The corresponding HTML output tag should be `div` and have the CSS
-#' class name `shiny-html-output`.
-#'
-#' @param expr An expression that returns an R object that can be used with
-#'   [xtable::xtable()].
-#' @param striped,hover,bordered Logicals: if `TRUE`, apply the
-#'   corresponding Bootstrap table format to the output table.
-#' @param spacing The spacing between the rows of the table (`xs`
-#'   stands for "extra small", `s` for "small", `m` for "medium"
-#'   and `l` for "large").
-#' @param width Table width. Must be a valid CSS unit (like "100%", "400px",
-#'   "auto") or a number, which will be coerced to a string and
-#'   have "px" appended.
-#' @param align A string that specifies the column alignment. If equal to
-#'   `'l'`, `'c'` or `'r'`, then all columns will be,
-#'   respectively, left-, center- or right-aligned. Otherwise, `align`
-#'   must have the same number of characters as the resulting table (if
-#'   `rownames = TRUE`, this will be equal to `ncol()+1`), with
-#'   the *i*-th character specifying the alignment for the
-#'   *i*-th column (besides `'l'`, `'c'` and
-#'   `'r'`, `'?'` is also permitted - `'?'` is a placeholder
-#'   for that particular column, indicating that it should keep its default
-#'   alignment). If `NULL`, then all numeric/integer columns (including
-#'   the row names, if they are numbers) will be right-aligned and
-#'   everything else will be left-aligned (`align = '?'` produces the
-#'   same result).
-#' @param rownames,colnames Logicals: include rownames? include colnames
-#'   (column headers)?
-#' @param digits An integer specifying the number of decimal places for
-#'   the numeric columns (this will not apply to columns with an integer
-#'   class). If `digits` is set to a negative value, then the numeric
-#'   columns will be displayed in scientific format with a precision of
-#'   `abs(digits)` digits.
-#' @param na The string to use in the table cells whose values are missing
-#'   (i.e. they either evaluate to `NA` or `NaN`).
-#' @param ... Arguments to be passed through to [xtable::xtable()]
-#'   and [xtable::print.xtable()].
-#' @param env The environment in which to evaluate `expr`.
-#' @param quoted Is `expr` a quoted expression (with `quote()`)?
-#'   This is useful if you want to save an expression in a variable.
-#' @param outputArgs A list of arguments to be passed through to the
-#'   implicit call to [tableOutput()] when `renderTable` is
-#'   used in an interactive R Markdown document.
-#' @export
-renderTable <- function(expr, striped = FALSE, hover = FALSE,
-                        bordered = FALSE, spacing = c("s", "xs", "m", "l"),
-                        width = "auto", align = NULL,
-                        rownames = FALSE, colnames = TRUE,
-                        digits = NULL, na = "NA", ...,
-                        env = parent.frame(), quoted = FALSE,
-                        outputArgs=list()) {
-  installExprFunction(expr, "func", env, quoted)
-
-  if (!is.function(spacing)) spacing <- match.arg(spacing)
-
-  # A small helper function to create a wrapper for an argument that was
-  # passed to renderTable()
-  createWrapper <- function(arg) {
-    if (is.function(arg)) wrapper <- arg
-    else wrapper <- function() arg
-    return(wrapper)
-  }
-
-  # Create wrappers for most arguments so that functions can also be passed
-  # in, rather than only literals (useful for shiny apps)
-  stripedWrapper <- createWrapper(striped)
-  hoverWrapper <- createWrapper(hover)
-  borderedWrapper <- createWrapper(bordered)
-  spacingWrapper <- createWrapper(spacing)
-  widthWrapper <- createWrapper(width)
-  alignWrapper <- createWrapper(align)
-  rownamesWrapper <- createWrapper(rownames)
-  colnamesWrapper <- createWrapper(colnames)
-  digitsWrapper <- createWrapper(digits)
-  naWrapper <- createWrapper(na)
-
-  dots <- list(...)  ## used later (but defined here because of scoping)
-
-  createRenderFunction(
-    func,
-    function(data, session, name, ...) {
-      striped <- stripedWrapper()
-      hover <- hoverWrapper()
-      bordered <- borderedWrapper()
-      format <- c(striped = striped, hover = hover, bordered = bordered)
-      spacing <- spacingWrapper()
-      width <- widthWrapper()
-      align <- alignWrapper()
-      rownames <- rownamesWrapper()
-      colnames <- colnamesWrapper()
-      digits <- digitsWrapper()
-      na <- naWrapper()
-
-      spacing_choices <- c("s", "xs", "m", "l")
-      if (!(spacing %in% spacing_choices)) {
-        stop(paste("`spacing` must be one of",
-          paste0("'", spacing_choices, "'", collapse=", ")))
-      }
-
-      # For css styling
-      classNames <- paste0("table shiny-table",
-        paste0(" table-", names(format)[format], collapse = "" ),
-        paste0(" spacing-", spacing))
-
-      data <- as.data.frame(data)
-
-      # Return NULL if no data is provided
-      if (is.null(data) ||
-          (is.data.frame(data) && nrow(data) == 0 && ncol(data) == 0))
-        return(NULL)
-
-      # Separate the ... args to pass to xtable() vs print.xtable()
-      xtable_argnames <- setdiff(names(formals(xtable)), c("x", "..."))
-      xtable_args <- dots[intersect(names(dots), xtable_argnames)]
-      non_xtable_args <- dots[setdiff(names(dots), xtable_argnames)]
-
-      # By default, numbers are right-aligned and everything else is left-aligned.
-      defaultAlignment <- function(col) {
-        if (is.numeric(col)) "r" else "l"
-      }
-
-      # Figure out column alignment
-      ## Case 1: default alignment
-      if (is.null(align) || align == "?") {
-        names <- defaultAlignment(attr(data, "row.names"))
-        cols <- paste(vapply(data, defaultAlignment, character(1)), collapse = "")
-        cols <- paste0(names, cols)
-      } else {
-        ## Case 2: user-specified alignment
-        num_cols <- if (rownames) nchar(align) else nchar(align)+1
-        valid <- !grepl("[^lcr\\?]", align)
-        if (num_cols == ncol(data)+1 && valid) {
-          cols <- if (rownames) align else paste0("r", align)
-          defaults <- grep("\\?", strsplit(cols,"")[[1]])
-          if (length(defaults) != 0) {
-            vals <- vapply(data[,defaults-1], defaultAlignment, character(1))
-            for (i in seq_len(length(defaults))) {
-              substr(cols, defaults[i], defaults[i]) <- vals[i]
-            }
-          }
-        } else if (nchar(align) == 1 && valid) {
-          cols <- paste0(rep(align, ncol(data)+1), collapse="")
-        } else {
-          stop("`align` must contain only the characters `l`, `c`, `r` and/or `?` and",
-            "have length either equal to 1 or to the total number of columns")
-        }
-      }
-
-      # Call xtable with its (updated) args
-      xtable_args <- c(xtable_args, align = cols, digits = digits)
-      xtable_res <- do.call(xtable, c(list(data), xtable_args))
-
-      # Set up print args
-      print_args <- list(
-        x = xtable_res,
-        type = 'html',
-        include.rownames = {
-          if ("include.rownames" %in% names(dots)) dots$include.rownames
-          else rownames
-        },
-        include.colnames = {
-          if ("include.colnames" %in% names(dots)) dots$include.colnames
-          else colnames
-        },
-        NA.string = {
-          if ("NA.string" %in% names(dots)) dots$NA.string
-          else na
-        },
-        html.table.attributes =
-          paste0({
-            if ("html.table.attributes" %in% names(dots)) dots$html.table.attributes
-            else ""
-          }, " ",
-            "class = '", htmlEscape(classNames, TRUE), "' ",
-            "style = 'width:", validateCssUnit(width), ";'"),
-        comment = {
-          if ("comment" %in% names(dots)) dots$comment
-          else FALSE
-        }
-      )
-
-      print_args <- c(print_args, non_xtable_args)
-      print_args <- print_args[unique(names(print_args))]
-
-      # Capture the raw html table returned by print.xtable(), and store it in
-      # a variable for further processing
-      tab <- paste(utils::capture.output(do.call(print, print_args)),collapse = "\n")
-
-      # Add extra class to cells with NA value, to be able to style them separately
-      tab <- gsub(paste(">", na, "<"), paste(" class='NA'>", na, "<"), tab)
-
-      # All further processing concerns the table headers, so we don't need to run
-      # any of this if colnames=FALSE
-      if (colnames) {
-        # Make sure that the final html table has a proper header (not included
-        # in the print.xtable() default)
-        tab <- sub("<tr>", "<thead> <tr>", tab)
-        tab <- sub("</tr>", "</tr> </thead> <tbody>", tab)
-        tab <- sub("</table>$", "</tbody> </table>", tab)
-
-        # Update the `cols` string (which stores the alignment of each column) so
-        # that it only includes the alignment for the table variables (and not
-        # for the row.names)
-        cols <- if (rownames) cols else substr(cols, 2, nchar(cols))
-
-        # Create a vector whose i-th entry corresponds to the i-th table variable
-        # alignment (substituting "l" by "left", "c" by "center" and "r" by "right")
-        cols <- strsplit(cols, "")[[1]]
-        cols[cols == "l"] <- "left"
-        cols[cols == "r"] <- "right"
-        cols[cols == "c"] <- "center"
-
-        # Align each header accordingly (this guarantees that each header and its
-        # corresponding column have the same alignment)
-        for (i in seq_len(length(cols))) {
-          tab <- sub("<th>", paste0("<th style='text-align: ", cols[i], ";'>"), tab)
-        }
-      }
-      return(tab)
-    },
-    tableOutput, outputArgs
-  )
-}

R/run-url.R

@@ -1,35 +1,124 @@
-#' Run a Shiny application from a URL
+#' Run a Shiny application from https://gist.github.com
 #'
-#' `runUrl()` downloads and launches a Shiny application that is hosted at
-#' a downloadable URL. The Shiny application must be saved in a .zip, .tar, or
-#' .tar.gz file. The Shiny application files must be contained in the root
-#' directory or a subdirectory in the archive. For example, the files might be
-#' `myapp/server.r` and `myapp/ui.r`. The functions `runGitHub()`
-#' and `runGist()` are based on `runUrl()`, using URL's from GitHub
-#' (<https://github.com>) and GitHub gists (<https://gist.github.com>),
-#' respectively.
-#' @param url URL of the application.
-#' @param filetype The file type (`".zip"`, `".tar"`, or
-#'   `".tar.gz"`. Defaults to the file extension taken from the url.
+#' Download and launch a Shiny application that is hosted on GitHub as a gist.
+#'
+#' @param gist The identifier of the gist. For example, if the gist is
+#'   https://gist.github.com/jcheng5/3239667, then \code{3239667},
+#'   \code{'3239667'}, and \code{'https://gist.github.com/jcheng5/3239667'}
+#'   are all valid values.
+#' @param port The TCP port that the application should listen on. Defaults to
+#'   port 8100.
+#' @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.
+#'
+#' @examples
+#' \dontrun{
+#' runGist(3239667)
+#' runGist("https://gist.github.com/jcheng5/3239667")
+#'
+#' # Old URL format without username
+#' runGist("https://gist.github.com/3239667")
+#' }
+#'
+#' @export
+runGist <- function(gist,
+                    port=8100L,
+                    launch.browser=getOption('shiny.launch.browser',
+                                             interactive())) {
+
+  gistUrl <- if (is.numeric(gist) || grepl('^[0-9a-f]+$', gist)) {
+    sprintf('https://gist.github.com/%s/download', gist)
+  } else if(grepl('^https://gist.github.com/([^/]+/)?([0-9a-f]+)$', gist)) {
+    paste(gist, '/download', sep='')
+  } else {
+    stop('Unrecognized gist identifier format')
+  }
+
+  runUrl(gistUrl, filetype=".tar.gz", subdir=NULL, port=port,
+    launch.browser=launch.browser)
+}
+
+
+#' Run a Shiny application from a GitHub repository
+#'
+#' Download and launch a Shiny application that is hosted in a GitHub repository.
+#'
+#' @param repo Name of the repository
+#' @param username GitHub username
+#' @param ref Desired git reference. Could be a commit, tag, or branch
+#'   name. Defaults to \code{"master"}.
 #' @param subdir A subdirectory in the repository that contains the app. By
 #'   default, this function will run an app from the top level of the repo, but
-#'   you can use a path such as `"inst/shinyapp"`.
-#' @param destdir Directory to store the downloaded application files. If `NULL`
-#'   (the default), the application files will be stored in a temporary directory
-#'   and removed when the app exits
-#' @param ... Other arguments to be passed to [runApp()], such as
-#'   `port` and `launch.browser`.
-#' @export
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
+#'   you can use a path such as `\code{"inst/shinyapp"}.
+#' @param port The TCP port that the application should listen on. Defaults to
+#'   port 8100.
+#' @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.
 #'
-#'   # Can run an app from a subdirectory in the archive
-#'   runUrl("https://github.com/rstudio/shiny_example/archive/master.zip",
-#'     subdir = "inst/shinyapp/")
+#' @examples
+#' \dontrun{
+#' runGitHub("shiny_example", "rstudio")
+#'
+#' # Can run an app from a subdirectory in the repo
+#' runGitHub("shiny_example", "rstudio", subdir = "inst/shinyapp/")
 #' }
-runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
+#'
+#' @export
+runGitHub <- function(repo, username = getOption("github.user"),
+  ref = "master", subdir = NULL, port = 8100,
+  launch.browser = getOption('shiny.launch.browser', interactive())) {
+
+  if (is.null(ref)) {
+    stop("Must specify either a ref. ")
+  }
+
+  message("Downloading github repo(s) ",
+    paste(repo, ref, sep = "/", collapse = ", "),
+    " from ",
+    paste(username, collapse = ", "))
+  name <- paste(username, "-", repo, sep = "")
+
+  url <- paste("https://github.com/", username, "/", repo, "/archive/",
+    ref, ".tar.gz", sep = "")
+
+  runUrl(url, subdir=subdir, port=port, launch.browser=launch.browser)
+}
+
+
+#' Run a Shiny application from a URL
+#'
+#' Download and launch a Shiny application that is hosted at a downloadable
+#' URL. The Shiny application must be saved in a .zip, .tar, or .tar.gz file.
+#' The Shiny application files must be contained in a subdirectory in the
+#' archive. For example, the files might be \code{myapp/server.r} and
+#' \code{myapp/ui.r}.
+#'
+#' @param url URL of the application.
+#' @param filetype The file type (\code{".zip"}, \code{".tar"}, or
+#'   \code{".tar.gz"}. Defaults to the file extension taken from the url.
+#' @param subdir A subdirectory in the repository that contains the app. By
+#'   default, this function will run an app from the top level of the repo, but
+#'   you can use a path such as `\code{"inst/shinyapp"}.
+#' @param port The TCP port that the application should listen on. Defaults to
+#'   port 8100.
+#' @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.
+#'
+#' @examples
+#' \dontrun{
+#' runUrl('https://github.com/rstudio/shiny_example/archive/master.tar.gz')
+#'
+#' # Can run an app from a subdirectory in the archive
+#' runUrl("https://github.com/rstudio/shiny_example/archive/master.zip",
+#'  subdir = "inst/shinyapp/")
+#' }
+#'
+#' @export
+runUrl <- function(url, filetype = NULL, subdir = NULL, port = 8100,
+  launch.browser = getOption('shiny.launch.browser', interactive())) {
 
   if (!is.null(subdir) && ".." %in% strsplit(subdir, '/')[[1]])
     stop("'..' not allowed in subdir")
@@ -47,15 +136,7 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
     stop("Unknown file extension.")
 
   message("Downloading ", url)
-  if (is.null(destdir)) {
-    filePath <- tempfile('shinyapp', fileext = fileext)
-    fileDir  <- tempfile('shinyapp')
-  } else {
-    fileDir <- destdir
-    filePath <- paste(destdir, fileext)
-  }
-
-  dir.create(fileDir, showWarnings = FALSE)
+  filePath <- tempfile('shinyapp', fileext=fileext)
   if (download(url, filePath, mode = "wb", quiet = TRUE) != 0)
     stop("Failed to download URL ", url)
   on.exit(unlink(filePath))
@@ -67,83 +148,17 @@ runUrl <- function(url, filetype = NULL, subdir = NULL, destdir = NULL, ...) {
     #   2) If the internal untar implementation is used, it chokes on the 'g'
     #      type flag that github uses (to stash their commit hash info).
     # By using our own forked/modified untar2 we sidestep both issues.
-    first <- untar2(filePath, list=TRUE)[1]
-    untar2(filePath, exdir = fileDir)
+    dirname <- untar2(filePath, list=TRUE)[1]
+    untar2(filePath, exdir = dirname(filePath))
 
   } else if (fileext == ".zip") {
-    first <- as.character(utils::unzip(filePath, list=TRUE)$Name)[1]
-    utils::unzip(filePath, exdir = fileDir)
+    dirname <- as.character(unzip(filePath, list=TRUE)$Name[1])
+    unzip(filePath, exdir = dirname(filePath))
   }
 
-  if(is.null(destdir)){
-    on.exit(unlink(fileDir, recursive = TRUE), add = TRUE)
-  }
+  appdir <- file.path(dirname(filePath), dirname)
+  on.exit(unlink(appdir, recursive = TRUE), add = TRUE)
 
-  appdir <- file.path(fileDir, first)
-  if (!utils::file_test('-d', appdir)) appdir <- dirname(appdir)
-
-  if (!is.null(subdir)) appdir <- file.path(appdir, subdir)
-  runApp(appdir, ...)
-}
-
-#' @rdname runUrl
-#' @param gist The identifier of the gist. For example, if the gist is
-#'   https://gist.github.com/jcheng5/3239667, then `3239667`,
-#'   `'3239667'`, and `'https://gist.github.com/jcheng5/3239667'` are
-#'   all valid values.
-#' @export
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   runGist(3239667)
-#'   runGist("https://gist.github.com/jcheng5/3239667")
-#'
-#'   # Old URL format without username
-#'   runGist("https://gist.github.com/3239667")
-#' }
-#'
-runGist <- function(gist, destdir = NULL, ...) {
-
-  gistUrl <- if (is.numeric(gist) || grepl('^[0-9a-f]+$', gist)) {
-    sprintf('https://gist.github.com/%s/download', gist)
-  } else if(grepl('^https://gist.github.com/([^/]+/)?([0-9a-f]+)$', gist)) {
-    paste(gist, '/download', sep='')
-  } else {
-    stop('Unrecognized gist identifier format')
-  }
-
-  runUrl(gistUrl, filetype = ".zip", destdir = destdir, ...)
-}
-
-
-#' @rdname runUrl
-#' @param repo Name of the repository.
-#' @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"`.
-#' @export
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   runGitHub("shiny_example", "rstudio")
-#'   # or runGitHub("rstudio/shiny_example")
-#'
-#'   # Can run an app from a subdirectory in the repo
-#'   runGitHub("shiny_example", "rstudio", subdir = "inst/shinyapp/")
-#' }
-runGitHub <- function(repo, username = getOption("github.user"),
-                      ref = "master", subdir = NULL, destdir = NULL, ...) {
-
-  if (grepl('/', repo)) {
-    res <- strsplit(repo, '/')[[1]]
-    if (length(res) != 2) stop("'repo' must be of the form 'username/repo'")
-    username <- res[1]
-    repo     <- res[2]
-  }
-
-  url <- paste("https://github.com/", username, "/", repo, "/archive/",
-               ref, ".tar.gz", sep = "")
-
-  runUrl(url, subdir = subdir, destdir = destdir, ...)
+  appsubdir <- ifelse(is.null(subdir), appdir, file.path(appdir, subdir))
+  runApp(appsubdir, port=port, launch.browser=launch.browser)
 }

R/runapp.R

@@ -1,564 +0,0 @@
-#' Run Shiny Application
-#'
-#' Runs a Shiny application. This function normally does not return; interrupt R
-#' to stop the application (usually by pressing Ctrl+C or Esc).
-#'
-#' The host parameter was introduced in Shiny 0.9.0. Its default value of
-#' `"127.0.0.1"` means that, contrary to previous versions of Shiny, only
-#' the current machine can access locally hosted Shiny apps. To allow other
-#' clients to connect, use the value `"0.0.0.0"` instead (which was the
-#' value that was hard-coded into Shiny in 0.8.0 and earlier).
-#'
-#' @param appDir The application to run. Should be one of the following:
-#'   \itemize{
-#'   \item A directory containing `server.R`, plus, either `ui.R` or
-#'    a `www` directory that contains the file `index.html`.
-#'   \item A directory containing `app.R`.
-#'   \item An `.R` file containing a Shiny application, ending with an
-#'    expression that produces a Shiny app object.
-#'   \item A list with `ui` and `server` components.
-#'   \item A Shiny app object created by [shinyApp()].
-#'   }
-#' @param port The TCP port that the application should listen on. If the
-#'   `port` is not specified, and the `shiny.port` option is set (with
-#'   `options(shiny.port = XX)`), then that port will be used. Otherwise,
-#'   use a random port.
-#' @param launch.browser If true, the system's default web browser will be
-#'   launched automatically after the app is started. Defaults to true in
-#'   interactive sessions only. This value of this parameter can also be a
-#'   function to call with the application's URL.
-#' @param host The IPv4 address that the application should listen on. Defaults
-#'   to the `shiny.host` option, if set, or `"127.0.0.1"` if not. See
-#'   Details.
-#' @param workerId Can generally be ignored. Exists to help some editions of
-#'   Shiny Server Pro route requests to the correct process.
-#' @param quiet Should Shiny status messages be shown? Defaults to FALSE.
-#' @param display.mode The mode in which to display the application. If set to
-#'   the value `"showcase"`, shows application code and metadata from a
-#'   `DESCRIPTION` file in the application directory alongside the
-#'   application. If set to `"normal"`, displays the application normally.
-#'   Defaults to `"auto"`, which displays the application in the mode given
-#'   in its `DESCRIPTION` file, if any.
-#' @param test.mode Should the application be launched in test mode? This is
-#'   only used for recording or running automated tests. Defaults to the
-#'   `shiny.testmode` option, or FALSE if the option is not set.
-#'
-#' @examples
-#' \dontrun{
-#' # Start app in the current working directory
-#' runApp()
-#'
-#' # Start app in a subdirectory called myapp
-#' runApp("myapp")
-#' }
-#'
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   options(device.ask.default = FALSE)
-#'
-#'   # Apps can be run without a server.r and ui.r file
-#'   runApp(list(
-#'     ui = bootstrapPage(
-#'       numericInput('n', 'Number of obs', 100),
-#'       plotOutput('plot')
-#'     ),
-#'     server = function(input, output) {
-#'       output$plot <- renderPlot({ hist(runif(input$n)) })
-#'     }
-#'   ))
-#'
-#'
-#'   # Running a Shiny app object
-#'   app <- shinyApp(
-#'     ui = bootstrapPage(
-#'       numericInput('n', 'Number of obs', 100),
-#'       plotOutput('plot')
-#'     ),
-#'     server = function(input, output) {
-#'       output$plot <- renderPlot({ hist(runif(input$n)) })
-#'     }
-#'   )
-#'   runApp(app)
-#' }
-#' @export
-runApp <- function(appDir=getwd(),
-                   port=getOption('shiny.port'),
-                   launch.browser=getOption('shiny.launch.browser',
-                                            interactive()),
-                   host=getOption('shiny.host', '127.0.0.1'),
-                   workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase"),
-                   test.mode=getOption('shiny.testmode', FALSE)) {
-  on.exit({
-    handlerManager$clear()
-  }, add = TRUE)
-
-  if (isRunning()) {
-    stop("Can't call `runApp()` from within `runApp()`. If your ",
-         "application code contains `runApp()`, please remove it.")
-  }
-
-  # Make warnings print immediately
-  # Set pool.scheduler to support pool package
-  ops <- options(
-    # Raise warn level to 1, but don't lower it
-    warn = max(1, getOption("warn", default = 1)),
-    pool.scheduler = scheduleTask
-  )
-  on.exit(options(ops), add = TRUE)
-
-  # ============================================================================
-  # Global onStart/onStop callbacks
-  # ============================================================================
-  # Invoke user-defined onStop callbacks, before the application's internal
-  # onStop callbacks.
-  on.exit({
-    .globals$onStopCallbacks$invoke()
-    .globals$onStopCallbacks <- Callbacks$new()
-  }, add = TRUE)
-
-  require(shiny)
-
-  # ============================================================================
-  # Convert to Shiny app object
-  # ============================================================================
-  appParts <- as.shiny.appobj(appDir)
-
-  # ============================================================================
-  # Initialize app state object
-  # ============================================================================
-  # This is so calls to getCurrentAppState() can be used to find (A) whether an
-  # app is running and (B), get options and data associated with the app.
-  initCurrentAppState(appParts)
-  on.exit(clearCurrentAppState(), add = TRUE)
-  # Any shinyOptions set after this point will apply to the current app only
-  # (and will not persist after the app stops).
-
-  # ============================================================================
-  # shinyOptions
-  # ============================================================================
-  # A unique identifier associated with this run of this application. It is
-  # shared across sessions.
-  shinyOptions(appToken = createUniqueId(8))
-
-  # Set up default cache for app.
-  if (is.null(getShinyOption("cache"))) {
-    shinyOptions(cache = MemoryCache$new())
-  }
-
-  # Extract appOptions (which is a list) and store them as shinyOptions, for
-  # this app. (This is the only place we have to store settings that are
-  # accessible both the UI and server portion of the app.)
-  applyCapturedAppOptions(appParts$appOptions)
-
-  # ============================================================================
-  # runApp options set via shinyApp(options = list(...))
-  # ============================================================================
-  # The lines below set some of the app's running options, which
-  # can be:
-  #   - left unspecified (in which case the arguments' default
-  #     values from `runApp` kick in);
-  #   - passed through `shinyApp`
-  #   - passed through `runApp` (this function)
-  #   - passed through both `shinyApp` and `runApp` (the latter
-  #     takes precedence)
-  #
-  # Matrix of possibilities:
-  # | IN shinyApp | IN runApp | result       | check                                                                                                                                  |
-  # |-------------|-----------|--------------|----------------------------------------------------------------------------------------------------------------------------------------|
-  # | no          | no        | use defaults | exhaust all possibilities: if it's missing (runApp does not specify); THEN if it's not in shinyApp appParts$options; THEN use defaults |
-  # | yes         | no        | use shinyApp | if it's missing (runApp does not specify); THEN if it's in shinyApp appParts$options; THEN use shinyApp                                |
-  # | no          | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
-  # | yes         | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
-  #
-  # I tried to make this as compact and intuitive as possible,
-  # given that there are four distinct possibilities to check
-  appOps <- appParts$options
-  findVal <- function(arg, default) {
-    if (arg %in% names(appOps)) appOps[[arg]] else default
-  }
-
-  if (missing(port))
-    port <- findVal("port", port)
-  if (missing(launch.browser))
-    launch.browser <- findVal("launch.browser", launch.browser)
-  if (missing(host))
-    host <- findVal("host", host)
-  if (missing(quiet))
-    quiet <- findVal("quiet", quiet)
-  if (missing(display.mode))
-    display.mode <- findVal("display.mode", display.mode)
-  if (missing(test.mode))
-    test.mode <- findVal("test.mode", test.mode)
-
-  if (is.null(host) || is.na(host)) host <- '0.0.0.0'
-
-  # ============================================================================
-  # Hosted environment
-  # ============================================================================
-  workerId(workerId)
-
-  if (inShinyServer()) {
-    # If SHINY_PORT is set, we're running under Shiny Server. Check the version
-    # to make sure it is compatible. Older versions of Shiny Server don't set
-    # SHINY_SERVER_VERSION, those will return "" which is considered less than
-    # any valid version.
-    ver <- Sys.getenv('SHINY_SERVER_VERSION')
-    if (utils::compareVersion(ver, .shinyServerMinVersion) < 0) {
-      warning('Shiny Server v', .shinyServerMinVersion,
-              ' or later is required; please upgrade!')
-    }
-  }
-
-  # ============================================================================
-  # Shinytest
-  # ============================================================================
-  # Set the testmode shinyoption so that this can be read by both the
-  # ShinySession and the UI code (which executes separately from the
-  # ShinySession code).
-  shinyOptions(testmode = test.mode)
-  if (test.mode) {
-    message("Running application in test mode.")
-  }
-
-  # ============================================================================
-  # Showcase mode
-  # ============================================================================
-  # Showcase mode is disabled by default; it must be explicitly enabled in
-  # either the DESCRIPTION file for directory-based apps, or via
-  # the display.mode parameter. The latter takes precedence.
-  setShowcaseDefault(0)
-
-  # If appDir specifies a path, and display mode is specified in the
-  # DESCRIPTION file at that path, apply it here.
-  if (is.character(appDir)) {
-    # if appDir specifies a .R file (single-file Shiny app), look for the
-    # DESCRIPTION in the parent directory
-    desc <- file.path.ci(
-      if (tolower(tools::file_ext(appDir)) == "r")
-        dirname(appDir)
-      else
-        appDir, "DESCRIPTION")
-    if (file.exists(desc)) {
-      con <- file(desc, encoding = checkEncoding(desc))
-      on.exit(close(con), add = TRUE)
-      settings <- read.dcf(con)
-      if ("DisplayMode" %in% colnames(settings)) {
-        mode <- settings[1, "DisplayMode"]
-        if (mode == "Showcase") {
-          setShowcaseDefault(1)
-          if ("IncludeWWW" %in% colnames(settings)) {
-            .globals$IncludeWWW <- as.logical(settings[1, "IncludeWWW"])
-            if (is.na(.globals$IncludeWWW)) {
-              stop("In your Description file, `IncludeWWW` ",
-                   "must be set to `True` (default) or `False`")
-            }
-          } else {
-            .globals$IncludeWWW <- TRUE
-          }
-        }
-      }
-    }
-  }
-
-  ## default is to show the .js, .css and .html files in the www directory
-  ## (if not in showcase mode, this variable will simply be ignored)
-  if (is.null(.globals$IncludeWWW) || is.na(.globals$IncludeWWW)) {
-    .globals$IncludeWWW <- TRUE
-  }
-
-  # If display mode is specified as an argument, apply it (overriding the
-  # value specified in DESCRIPTION, if any).
-  display.mode <- match.arg(display.mode)
-  if (display.mode == "normal") {
-    setShowcaseDefault(0)
-  }
-  else if (display.mode == "showcase") {
-    setShowcaseDefault(1)
-  }
-
-  # ============================================================================
-  # Server port
-  # ============================================================================
-  # determine port if we need to
-  if (is.null(port)) {
-
-    # Try up to 20 random ports. If we don't succeed just plow ahead
-    # with the final value we tried, and let the "real" startServer
-    # somewhere down the line fail and throw the error to the user.
-    #
-    # If we (think we) succeed, save the value as .globals$lastPort,
-    # and try that first next time the user wants a random port.
-
-    for (i in 1:20) {
-      if (!is.null(.globals$lastPort)) {
-        port <- .globals$lastPort
-        .globals$lastPort <- NULL
-      }
-      else {
-        # Try up to 20 random ports
-        while (TRUE) {
-          port <- p_randomInt(3000, 8000)
-          # Reject ports in this range that are considered unsafe by Chrome
-          # http://superuser.com/questions/188058/which-ports-are-considered-unsafe-on-chrome
-          # https://github.com/rstudio/shiny/issues/1784
-          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
-            break
-          }
-        }
-      }
-
-      # Test port to see if we can use it
-      tmp <- try(startServer(host, port, list()), silent=TRUE)
-      if (!inherits(tmp, 'try-error')) {
-        stopServer(tmp)
-        .globals$lastPort <- port
-        break
-      }
-    }
-  }
-
-  # ============================================================================
-  # onStart/onStop callbacks
-  # ============================================================================
-  # Set up the onStop before we call onStart, so that it gets called even if an
-  # error happens in onStart.
-  if (!is.null(appParts$onStop))
-    on.exit(appParts$onStop(), add = TRUE)
-  if (!is.null(appParts$onStart))
-    appParts$onStart()
-
-  # ============================================================================
-  # Start/stop httpuv app
-  # ============================================================================
-  server <- startApp(appParts, port, host, quiet)
-
-  # Make the httpuv server object accessible. Needed for calling
-  # addResourcePath while app is running.
-  shinyOptions(server = server)
-
-  on.exit({
-    stopServer(server)
-  }, add = TRUE)
-
-  # ============================================================================
-  # Launch web browser
-  # ============================================================================
-  if (!is.character(port)) {
-    browseHost <- host
-    if (identical(host, "0.0.0.0")) {
-      # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
-      browseHost <- "127.0.0.1"
-    } else if (identical(host, "::")) {
-      browseHost <- "::1"
-    }
-
-    if (httpuv::ipFamily(browseHost) == 6L) {
-      browseHost <- paste0("[", browseHost, "]")
-    }
-
-    appUrl <- paste("http://", browseHost, ":", port, sep="")
-    if (is.function(launch.browser))
-      launch.browser(appUrl)
-    else if (launch.browser)
-      utils::browseURL(appUrl)
-  } else {
-    appUrl <- NULL
-  }
-
-  # ============================================================================
-  # Application hooks
-  # ============================================================================
-  callAppHook("onAppStart", appUrl)
-  on.exit({
-    callAppHook("onAppStop", appUrl)
-  }, add = TRUE)
-
-  # ============================================================================
-  # Run event loop via httpuv
-  # ============================================================================
-  .globals$reterror <- NULL
-  .globals$retval <- NULL
-  .globals$stopped <- FALSE
-  # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
-  # reactive(), Callbacks$invoke(), and others
-  ..stacktraceoff..(
-    captureStackTraces({
-      while (!.globals$stopped) {
-        ..stacktracefloor..(serviceApp())
-      }
-    })
-  )
-
-  if (isTRUE(.globals$reterror)) {
-    stop(.globals$retval)
-  }
-  else if (.globals$retval$visible)
-    .globals$retval$value
-  else
-    invisible(.globals$retval$value)
-}
-
-#' Stop the currently running Shiny app
-#'
-#' Stops the currently running Shiny app, returning control to the caller of
-#' [runApp()].
-#'
-#' @param returnValue The value that should be returned from
-#'   [runApp()].
-#' @export
-stopApp <- function(returnValue = invisible()) {
-  # reterror will indicate whether retval is an error (i.e. it should be passed
-  # to stop() when the serviceApp loop stops) or a regular value (in which case
-  # it should simply be returned with the appropriate visibility).
-  .globals$reterror <- FALSE
-  ..stacktraceoff..(
-    tryCatch(
-      {
-        captureStackTraces(
-          .globals$retval <- withVisible(..stacktraceon..(force(returnValue)))
-        )
-      },
-      error = function(e) {
-        .globals$retval <- e
-        .globals$reterror <- TRUE
-      }
-    )
-  )
-
-  .globals$stopped <- TRUE
-  httpuv::interrupt()
-}
-
-#' Run Shiny Example Applications
-#'
-#' Launch Shiny example applications, and optionally, your system's web browser.
-#'
-#' @param example The name of the example to run, or `NA` (the default) to
-#'   list the available examples.
-#' @param launch.browser If true, the system's default web browser will be
-#'   launched automatically after the app is started. Defaults to true in
-#'   interactive sessions only.
-#' @param host The IPv4 address that the application should listen on. Defaults
-#'   to the `shiny.host` option, if set, or `"127.0.0.1"` if not.
-#' @param display.mode The mode in which to display the example. Defaults to
-#'   `showcase`, but may be set to `normal` to see the example without
-#'   code or commentary.
-#' @inheritParams runApp
-#'
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   # List all available examples
-#'   runExample()
-#'
-#'   # Run one of the examples
-#'   runExample("01_hello")
-#'
-#'   # Print the directory containing the code for all examples
-#'   system.file("examples", package="shiny")
-#' }
-#' @export
-runExample <- function(example=NA,
-                       port=getOption("shiny.port"),
-                       launch.browser=getOption('shiny.launch.browser',
-                                                interactive()),
-                       host=getOption('shiny.host', '127.0.0.1'),
-                       display.mode=c("auto", "normal", "showcase")) {
-  examplesDir <- system.file('examples', package='shiny')
-  dir <- resolve(examplesDir, example)
-  if (is.null(dir)) {
-    if (is.na(example)) {
-      errFun <- message
-      errMsg <- ''
-    }
-    else {
-      errFun <- stop
-      errMsg <- paste('Example', example, 'does not exist. ')
-    }
-
-    errFun(errMsg,
-           'Valid examples are "',
-           paste(list.files(examplesDir), collapse='", "'),
-           '"')
-  }
-  else {
-    runApp(dir, port = port, host = host, launch.browser = launch.browser,
-           display.mode = display.mode)
-  }
-}
-
-#' Run a gadget
-#'
-#' Similar to `runApp`, but handles `input$cancel` automatically, and
-#' if running in RStudio, defaults to viewing the app in the Viewer pane.
-#'
-#' @param app Either a Shiny app object as created by
-#'   [`shinyApp()`][shiny] et al, or, a UI object.
-#' @param server Ignored if `app` is a Shiny app object; otherwise, passed
-#'   along to `shinyApp` (i.e. `shinyApp(ui = app, server = server)`).
-#' @param port See [`runApp()`][shiny].
-#' @param viewer Specify where the gadget should be displayed--viewer pane,
-#'   dialog window, or external browser--by passing in a call to one of the
-#'   [viewer()] functions.
-#' @param stopOnCancel If `TRUE` (the default), then an `observeEvent`
-#'   is automatically created that handles `input$cancel` by calling
-#'   `stopApp()` with an error. Pass `FALSE` if you want to handle
-#'   `input$cancel` yourself.
-#' @return The value returned by the gadget.
-#'
-#' @examples
-#' \dontrun{
-#' library(shiny)
-#'
-#' ui <- fillPage(...)
-#'
-#' server <- function(input, output, session) {
-#'   ...
-#' }
-#'
-#' # Either pass ui/server as separate arguments...
-#' runGadget(ui, server)
-#'
-#' # ...or as a single app object
-#' runGadget(shinyApp(ui, server))
-#' }
-#' @export
-runGadget <- function(app, server = NULL, port = getOption("shiny.port"),
-  viewer = paneViewer(), stopOnCancel = TRUE) {
-
-  if (!is.shiny.appobj(app)) {
-    app <- shinyApp(app, server)
-  }
-
-  if (isTRUE(stopOnCancel)) {
-    app <- decorateServerFunc(app, function(input, output, session) {
-      observeEvent(input$cancel, {
-        stopApp(stop("User cancel", call. = FALSE))
-      })
-    })
-  }
-
-  if (is.null(viewer)) {
-    viewer <- utils::browseURL
-  }
-
-  shiny::runApp(app, port = port, launch.browser = viewer)
-}
-
-# Add custom functionality to a Shiny app object's server func
-decorateServerFunc <- function(appobj, serverFunc) {
-  origServerFuncSource <- appobj$serverFuncSource
-  appobj$serverFuncSource <- function() {
-    origServerFunc <- origServerFuncSource()
-    function(input, output, session) {
-      serverFunc(input, output, session)
-
-      # The clientData and session arguments are optional; check if
-      # each exists
-      args <- argsForServerFunc(origServerFunc, session)
-      do.call(origServerFunc, args)
-    }
-  }
-  appobj
-}

R/serializers.R

@@ -1,91 +0,0 @@
-#' Add a function for serializing an input before bookmarking application state
-#'
-#' @param inputId Name of the input value.
-#' @param fun A function that takes the input value and returns a modified
-#'   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)) {
-    stop("setSerializer() needs a session object.")
-  }
-
-  input_impl <- .subset2(session$input, "impl")
-  input_impl$setMeta(inputId, "shiny.serializer", fun)
-}
-
-
-# For most types of values, simply return the value unchanged.
-serializerDefault <- function(value, stateDir) {
-  value
-}
-
-
-serializerFileInput <- function(value, stateDir = NULL) {
-  # File inputs can be serialized only if there's a stateDir
-  if (is.null(stateDir)) {
-    return(serializerUnserializable())
-  }
-
-  # value is a data frame. When persisting files, we need to copy the file to
-  # the persistent dir and then strip the original path before saving.
-  newpaths <- file.path(stateDir, basename(value$datapath))
-  file.copy(value$datapath, newpaths, overwrite = TRUE)
-  value$datapath <- basename(newpaths)
-
-  value
-}
-
-
-# Return a sentinel value that represents "unserializable". This is applied to
-# for example, passwords and actionButtons.
-serializerUnserializable <- function(value, stateDir) {
-  structure(
-    list(),
-    serializable = FALSE
-  )
-}
-
-# Is this an "unserializable" sentinel value?
-isUnserializable <- function(x) {
-  identical(
-    attr(x, "serializable", exact = TRUE),
-    FALSE
-  )
-}
-
-
-# Given a reactiveValues object and optional directory for saving state, apply
-# serializer function to each of the values, and return a list of the returned
-# values. This function passes stateDir to the serializer functions, so if
-# stateDir is non-NULL, it can have a side effect of writing values to disk (in
-# stateDir).
-serializeReactiveValues <- function(values, exclude, stateDir = NULL) {
-  impl <- .subset2(values, "impl")
-
-  # Get named list where keys and values are the names of inputs; we'll retrieve
-  # actual values later.
-  vals <- isolate(impl$names())
-  vals <- setdiff(vals, exclude)
-  names(vals) <- vals
-
-  # Get values and apply serializer functions
-  vals <- lapply(vals, function(name) {
-    val <- impl$get(name)
-
-    # Get the serializer function for this input value. If none specified, use
-    # the default.
-    serializer_fun <- impl$getMeta(name, "shiny.serializer")
-    if (is.null(serializer_fun))
-      serializer_fun <- serializerDefault
-
-    # Apply serializer function.
-    serializer_fun(val, stateDir)
-  })
-
-  # Filter out any values that were marked as unserializable.
-  vals <- Filter(Negate(isUnserializable), vals)
-  vals
-}

R/server-input-handlers.R

@@ -1,239 +0,0 @@
-# Create a map for input handlers and register the defaults.
-inputHandlers <- Map$new()
-
-#' Register an Input Handler
-#'
-#' Adds an input handler for data of this type. When called, Shiny will use the
-#' function provided to refine the data passed back from the client (after being
-#' deserialized by jsonlite) before making it available in the `input` variable
-#' of the `server.R` file.
-#'
-#' This function will register the handler for the duration of the R process
-#' (unless Shiny is explicitly reloaded). For that reason, the `type` used
-#' should be very specific to this package to minimize the risk of colliding
-#' with another Shiny package which might use this data type name. We recommend
-#' the format of "packageName.widgetName". It should be called from the
-#' package's `.onLoad()` function.
-#'
-#' Currently Shiny registers the following handlers: `shiny.matrix`,
-#' `shiny.number`, and `shiny.date`.
-#'
-#' The `type` of a custom Shiny Input widget will be deduced using the
-#' `getType()` JavaScript function on the registered Shiny inputBinding.
-#' @param type The type for which the handler should be added --- should be a
-#'   single-element character vector.
-#' @param fun The handler function. This is the function that will be used to
-#'   parse the data delivered from the client before it is available in the
-#'   `input` variable. The function will be called with the following three
-#'   parameters: \enumerate{ \item{The value of this input as provided by the
-#'   client, deserialized using jsonlite.} \item{The `shinysession` in which the
-#'   input exists.} \item{The name of the input.} }
-#' @param force If `TRUE`, will overwrite any existing handler without warning.
-#'   If `FALSE`, will throw an error if this class already has a handler
-#'   defined.
-#' @examples
-#' \dontrun{
-#' # Register an input handler which rounds a input number to the nearest integer
-#' # In a package, this should be called from the .onLoad function.
-#' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
-#'   if (is.null(x)) return(NA)
-#'   round(x)
-#' })
-#'
-#' ## On the Javascript side, the associated input binding must have a corresponding getType method:
-#' getType: function(el) {
-#'   return "mypackage.validint";
-#' }
-#'
-#' }
-#' @seealso [removeInputHandler()]
-#' @export
-registerInputHandler <- function(type, fun, force=FALSE){
-  if (inputHandlers$containsKey(type) && !force){
-    stop("There is already an input handler for type: ", type)
-  }
-  inputHandlers$set(type, fun)
-}
-
-#' Deregister an Input Handler
-#'
-#' Removes an Input Handler. Rather than using the previously specified handler
-#' for data of this type, the default jsonlite serialization will be used.
-#'
-#' @param type The type for which handlers should be removed.
-#' @return The handler previously associated with this `type`, if one
-#'   existed. Otherwise, `NULL`.
-#' @seealso [registerInputHandler()]
-#' @export
-removeInputHandler <- function(type){
-  inputHandlers$remove(type)
-}
-
-
-# Apply input handler to a single input value
-applyInputHandler <- function(name, val, shinysession) {
-  splitName <- strsplit(name, ':')[[1]]
-  if (length(splitName) > 1) {
-    if (!inputHandlers$containsKey(splitName[[2]])) {
-      # No input handler registered for this type
-      stop("No handler registered for type ", name)
-    }
-
-    inputName <- splitName[[1]]
-
-    # Get the function for processing this type of input
-    inputHandler <- inputHandlers$get(splitName[[2]])
-
-    return(inputHandler(val, shinysession, inputName))
-
-  } else if (is.list(val) && is.null(names(val))) {
-    return(unlist(val, recursive = TRUE))
-  } else {
-    return(val)
-  }
-}
-
-#' Apply input handlers to raw input values
-#'
-#' The purpose of this function is to make it possible for external packages to
-#' test Shiny inputs. It takes a named list of raw input values, applies input
-#' handlers to those values, and then returns a named list of the processed
-#' values.
-#'
-#' The raw input values should be in a named list. Some values may have names
-#' like `"x:shiny.date"`. This function would apply the `"shiny.date"`
-#' input handler to the value, and then rename the result to `"x"`, in the
-#' output.
-#'
-#' @param inputs A named list of input values.
-#' @param shinysession A Shiny session object.
-#'
-#' @seealso registerInputHandler
-#' @keywords internal
-applyInputHandlers <- function(inputs, shinysession = getDefaultReactiveDomain()) {
-  inputs <- mapply(applyInputHandler, names(inputs), inputs,
-                   MoreArgs = list(shinysession = shinysession),
-                   SIMPLIFY = FALSE)
-
-  # Convert names like "button1:shiny.action" to "button1"
-  names(inputs) <- vapply(
-    names(inputs),
-    function(name) { strsplit(name, ":")[[1]][1] },
-    FUN.VALUE = character(1)
-  )
-
-  inputs
-}
-
-
-# Takes a list-of-lists and returns a matrix. The lists
-# must all be the same length. NULL is replaced by NA.
-registerInputHandler("shiny.matrix", function(data, ...) {
-  if (length(data) == 0)
-    return(matrix(nrow=0, ncol=0))
-
-  m <- matrix(unlist(lapply(data, function(x) {
-    sapply(x, function(y) {
-      ifelse(is.null(y), NA, y)
-    })
-  })), nrow = length(data[[1]]), ncol = length(data))
-  return(m)
-})
-
-
-registerInputHandler("shiny.number", function(val, ...){
-  ifelse(is.null(val), NA, val)
-})
-
-registerInputHandler("shiny.password", function(val, shinysession, name) {
-  # Mark passwords as not serializable
-  setSerializer(name, serializerUnserializable)
-  val
-})
-
-registerInputHandler("shiny.date", function(val, ...){
-  # First replace NULLs with NA, then convert to Date vector
-  datelist <- ifelse(lapply(val, is.null), NA, val)
-
-  res <- NULL
-  tryCatch({
-      res <- as.Date(unlist(datelist))
-    },
-    error = function(e) {
-      # It's possible for client to send a string like "99999-01-01", which
-      # as.Date can't handle.
-      warning(e$message)
-      res <<- as.Date(rep(NA, length(datelist)))
-    }
-  )
-
-  res
-})
-
-registerInputHandler("shiny.datetime", function(val, ...){
-  # First replace NULLs with NA, then convert to POSIXct vector
-  times <- lapply(val, function(x) {
-    if (is.null(x)) NA
-    else x
-  })
-  as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
-})
-
-registerInputHandler("shiny.action", function(val, shinysession, name) {
-  # mark up the action button value with a special class so we can recognize it later
-  class(val) <- c(class(val), "shinyActionButtonValue")
-  val
-})
-
-registerInputHandler("shiny.file", function(val, shinysession, name) {
-  # This function is only used when restoring a Shiny fileInput. When a file is
-  # uploaded the usual way, it takes a different code path and won't hit this
-  # function.
-  if (is.null(val))
-    return(NULL)
-
-  # The data will be a named list of lists; convert to a data frame.
-  val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
-
-  # `val$datapath` should be a filename without a path, for security reasons.
-  if (basename(val$datapath) != val$datapath) {
-    stop("Invalid '/' found in file input path.")
-  }
-
-  # Prepend the persistent dir
-  oldfile <- file.path(getCurrentRestoreContext()$dir, val$datapath)
-
-  # Copy the original file to a new temp dir, so that a restored session can't
-  # modify the original.
-  newdir <- file.path(tempdir(), createUniqueId(12))
-  dir.create(newdir)
-  val$datapath <- file.path(newdir, val$datapath)
-  file.copy(oldfile, val$datapath)
-
-  # Need to mark this input value with the correct serializer. When a file is
-  # uploaded the usual way (instead of being restored), this occurs in
-  # session$`@uploadEnd`.
-  setSerializer(name, serializerFileInput)
-
-  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
-
-  val
-})
-
-
-# to be used with !!!answer
-registerInputHandler("shiny.symbolList", function(val, ...) {
-  if (is.null(val)) {
-    list()
-  } else {
-    lapply(val, as.symbol)
-  }
-})
-# to be used with !!answer
-registerInputHandler("shiny.symbol", function(val, ...) {
-  if (is.null(val) || identical(val, "")) {
-    NULL
-  } else {
-    as.symbol(val)
-  }
-})

R/server-resource-paths.R

@@ -1,169 +0,0 @@
-.globals$resourcePaths <- list()
-.globals$resources <- list()
-
-#' Resource Publishing
-#'
-#' Add, remove, or list directory of static resources to Shiny's web server,
-#' with the given path prefix. Primarily intended for package authors to make
-#' supporting JavaScript/CSS files available to their components.
-#'
-#' Shiny provides two ways of serving static files (i.e., resources):
-#'
-#' 1. Static files under the `www/` directory are automatically made available
-#' under a request path that begins with `/`.
-#' 2. `addResourcePath()` makes static files in a `directoryPath` available
-#' under a request path that begins with `prefix`.
-#'
-#' The second approach is primarily intended for package authors to make
-#' supporting JavaScript/CSS files available to their components.
-#'
-#' Tools for managing static resources published by Shiny's web server:
-#'  * `addResourcePath()` adds a directory of static resources.
-#'  * `resourcePaths()` lists the currently active resource mappings.
-#'  * `removeResourcePath()` removes a directory of static resources.
-#'
-#' @param prefix The URL prefix (without slashes). Valid characters are a-z,
-#'   A-Z, 0-9, hyphen, period, and underscore. For example, a value of 'foo'
-#'   means that any request paths that begin with '/foo' will be mapped to the
-#'   given directory.
-#' @param directoryPath The directory that contains the static resources to be
-#'   served.
-#'
-#' @rdname resourcePaths
-#' @seealso [singleton()]
-#'
-#' @examples
-#' addResourcePath('datasets', system.file('data', package='datasets'))
-#' resourcePaths()
-#' removeResourcePath('datasets')
-#' resourcePaths()
-#'
-#' # make sure all resources are removed
-#' lapply(names(resourcePaths()), removeResourcePath)
-#' @export
-addResourcePath <- function(prefix, directoryPath) {
-  if (length(prefix) != 1) stop("prefix must be of length 1")
-  if (grepl("^\\.+$", prefix)) stop("prefix can't be composed of dots only")
-  if (!grepl('[a-z0-9\\-_.]+$', prefix, ignore.case = TRUE, perl = TRUE)) {
-    stop("addResourcePath called with invalid prefix; please see documentation")
-  }
-  if (prefix %in% c('shared')) {
-    stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
-         "please use a different prefix")
-  }
-  normalizedPath <- tryCatch(normalizePath(directoryPath, mustWork = TRUE),
-    error = function(e) {
-      stop("Couldn't normalize path in `addResourcePath`, with arguments: ",
-        "`prefix` = '", prefix, "'; `directoryPath` = '" , directoryPath, "'")
-    }
-  )
-
-  # # Often times overwriting a resource path is "what you want",
-  # # but sometimes it can lead to difficult to diagnose issues
-  # # (e.g. an implict dependency might set a resource path that
-  # # conflicts with what you, the app author, are trying to register)
-  # # Note that previous versions of shiny used to warn about this case,
-  # # but it was eventually removed since it caused confusion (#567).
-  # # It seems a good compromise is to throw a more information message.
-  # if (getOption("shiny.resourcePathChanges", FALSE) &&
-  #     prefix %in% names(.globals$resourcePaths)) {
-  #   existingPath <- .globals$resourcePaths[[prefix]]$path
-  #   if (normalizedPath != existingPath) {
-  #     message(
-  #       "The resource path '", prefix, "' used to point to ",
-  #       existingPath, ", but it now points to ", normalizedPath, ". ",
-  #       "If your app doesn't work as expected, you may want to ",
-  #       "choose a different prefix name."
-  #     )
-  #   }
-  # }
-
-  # If a shiny app is currently running, dynamically register this path with
-  # the corresponding httpuv server object.
-  if (!is.null(getShinyOption("server")))
-  {
-    getShinyOption("server")$setStaticPath(.list = stats::setNames(normalizedPath, prefix))
-  }
-
-  # .globals$resourcePaths and .globals$resources persist across runs of applications.
-  .globals$resourcePaths[[prefix]] <- staticPath(normalizedPath)
-  # This is necessary because resourcePaths is only for serving assets out of C++;
-  # to support subapps, we also need assets to be served out of R, because those
-  # URLs are rewritten by R code (i.e. routeHandler) before they can be matched to
-  # a resource path.
-  .globals$resources[[prefix]] <- list(
-    directoryPath = normalizedPath,
-    func = staticHandler(normalizedPath)
-  )
-}
-
-#' @rdname resourcePaths
-#' @export
-resourcePaths <- function() {
-  urls <- names(.globals$resourcePaths)
-  paths <- vapply(.globals$resourcePaths, function(x) x$path, character(1))
-  stats::setNames(paths, urls)
-}
-
-hasResourcePath <- function(prefix) {
-  prefix %in% names(resourcePaths())
-}
-
-#' @rdname resourcePaths
-#' @export
-removeResourcePath <- function(prefix) {
-  if (length(prefix) > 1) stop("`prefix` must be of length 1.")
-  if (!hasResourcePath(prefix)) {
-    warning("Resource ", prefix, " not found.")
-    return(invisible(FALSE))
-  }
-  .globals$resourcePaths[[prefix]] <- NULL
-  .globals$resources[[prefix]] <- NULL
-  invisible(TRUE)
-}
-
-# This function handles any GET request with two or more path elements where the
-# first path element matches a prefix that was previously added using
-# addResourcePath().
-#
-# For example, if `addResourcePath("foo", "~/bar")` was called, then a GET
-# request for /foo/one/two.html would rewrite the PATH_INFO as /one/two.html and
-# send it to the resource path function for "foo". As of this writing, that
-# function will always be a staticHandler, which serves up a file if it exists
-# and NULL if it does not.
-#
-# Since Shiny 1.3.x, assets registered via addResourcePath should mostly be
-# served out of httpuv's native static file serving features. However, in the
-# specific case of subapps, the R code path must be used, because subapps insert
-# a giant random ID into the beginning of the URL that must be stripped off by
-# an R route handler (see addSubApp()).
-resourcePathHandler <- function(req) {
-  if (!identical(req$REQUEST_METHOD, 'GET'))
-    return(NULL)
-
-  # e.g. "/foo/one/two.html"
-  path <- req$PATH_INFO
-
-  match <- regexpr('^/([^/]+)/', path, perl=TRUE)
-  if (match == -1)
-    return(NULL)
-  len <- attr(match, 'capture.length')
-  # e.g. "foo"
-  prefix <- substr(path, 2, 2 + len - 1)
-
-  resInfo <- .globals$resources[[prefix]]
-  if (is.null(resInfo))
-    return(NULL)
-
-  # e.g. "/one/two.html"
-  suffix <- substr(path, 2 + len, nchar(path))
-
-  # Create a new request that's a clone of the current request, but adjust
-  # PATH_INFO and SCRIPT_NAME to reflect that we have already matched the first
-  # path element (e.g. "/foo"). See routeHandler() for more info.
-  subreq <- as.environment(as.list(req, all.names=TRUE))
-  subreq$PATH_INFO <- suffix
-  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, substr(path, 1, 2 + len), sep='')
-
-  return(resInfo$func(subreq))
-}

R/server.R

@@ -1,499 +0,0 @@
-#' @include server-input-handlers.R
-
-appsByToken <- Map$new()
-appsNeedingFlush <- Map$new()
-
-# Provide a character representation of the WS that can be used
-# as a key in a Map.
-wsToKey <- function(WS) {
-  as.character(WS$socket)
-}
-
-.globals$clients <- function(req) NULL
-
-
-clearClients <- function() {
-  .globals$clients <- function(req) NULL
-}
-
-
-registerClient <- function(client) {
-  .globals$clients <- append(.globals$clients, client)
-}
-
-
-.globals$showcaseDefault <- 0
-
-.globals$showcaseOverride <- FALSE
-
-
-#' Define Server Functionality
-#'
-#' Defines the server-side logic of the Shiny application. This generally
-#' involves creating functions that map user inputs to various kinds of output.
-#' In older versions of Shiny, it was necessary to call `shinyServer()` in
-#' the `server.R` file, but this is no longer required as of Shiny 0.10.
-#' Now the `server.R` file may simply return the appropriate server
-#' function (as the last expression in the code), without calling
-#' `shinyServer()`.
-#'
-#' Call `shinyServer` from your application's `server.R`
-#' file, passing in a "server function" that provides the server-side logic of
-#' your application.
-#'
-#' The server function will be called when each client (web browser) first loads
-#' the Shiny application's page. It must take an `input` and an
-#' `output` parameter. Any return value will be ignored. It also takes an
-#' optional `session` parameter, which is used when greater control is
-#' needed.
-#'
-#' See the [tutorial](http://rstudio.github.com/shiny/tutorial/) for more
-#' on how to write a server function.
-#'
-#' @param func The server function for this application. See the details section
-#'   for more information.
-#'
-#' @examples
-#' \dontrun{
-#' # A very simple Shiny app that takes a message from the user
-#' # and outputs an uppercase version of it.
-#' shinyServer(function(input, output, session) {
-#'   output$uppercase <- renderText({
-#'     toupper(input$message)
-#'   })
-#' })
-#'
-#'
-#' # It is also possible for a server.R file to simply return the function,
-#' # without calling shinyServer().
-#' # For example, the server.R file could contain just the following:
-#' function(input, output, session) {
-#'   output$uppercase <- renderText({
-#'     toupper(input$message)
-#'   })
-#' }
-#' }
-#' @export
-#' @keywords internal
-shinyServer <- function(func) {
-  .globals$server <- list(func)
-  invisible(func)
-}
-
-decodeMessage <- function(data) {
-  readInt <- function(pos) {
-    packBits(rawToBits(data[pos:(pos+3)]), type='integer')
-  }
-
-  if (readInt(1) != 0x01020202L) {
-    # Treat message as UTF-8
-    charData <- rawToChar(data)
-    Encoding(charData) <- 'UTF-8'
-    return(safeFromJSON(charData, simplifyVector=FALSE))
-  }
-
-  i <- 5
-  parts <- list()
-  while (i <= length(data)) {
-    length <- readInt(i)
-    i <- i + 4
-    if (length != 0)
-      parts <- append(parts, list(data[i:(i+length-1)]))
-    else
-      parts <- append(parts, list(raw(0)))
-    i <- i + length
-  }
-
-  mainMessage <- decodeMessage(parts[[1]])
-  mainMessage$blobs <- parts[2:length(parts)]
-  return(mainMessage)
-}
-
-autoReloadCallbacks <- Callbacks$new()
-
-createAppHandlers <- function(httpHandlers, serverFuncSource) {
-  appvars <- new.env()
-  appvars$server <- NULL
-
-  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
-  # denied (403 response for HTTP, and instant close for websocket).
-  checkSharedSecret <- loadSharedSecret()
-
-  appHandlers <- list(
-    http = joinHandlers(c(
-      sessionHandler,
-      httpHandlers,
-      sys.www.root,
-      resourcePathHandler,
-      reactLogHandler
-    )),
-    ws = function(ws) {
-      if (!checkSharedSecret(ws$request$HTTP_SHINY_SHARED_SECRET)) {
-        ws$close()
-        return(TRUE)
-      }
-
-      if (identical(ws$request$PATH_INFO, "/autoreload/")) {
-        if (!getOption("shiny.autoreload", FALSE)) {
-          ws$close()
-          return(TRUE)
-        }
-
-        callbackHandle <- autoReloadCallbacks$register(function() {
-          ws$send("autoreload")
-          ws$close()
-        })
-        ws$onClose(function() {
-          callbackHandle()
-        })
-        return(TRUE)
-      }
-
-      if (!is.null(getOption("shiny.observer.error", NULL))) {
-        warning(
-          call. = FALSE,
-          "options(shiny.observer.error) is no longer supported; please unset it!"
-        )
-        stopApp()
-      }
-
-      shinysession <- ShinySession$new(ws)
-      appsByToken$set(shinysession$token, shinysession)
-      shinysession$setShowcase(.globals$showcaseDefault)
-
-      messageHandler <- function(binary, msg) {
-        withReactiveDomain(shinysession, {
-          # To ease transition from websockets-based code. Should remove once we're stable.
-          if (is.character(msg))
-            msg <- charToRaw(msg)
-
-          traceOption <- getOption('shiny.trace', FALSE)
-          if (isTRUE(traceOption) || traceOption == "recv") {
-            if (binary)
-              message("RECV ", '$$binary data$$')
-            else
-              message("RECV ", rawToChar(msg))
-          }
-
-          if (isEmptyMessage(msg))
-            return()
-
-          msg <- decodeMessage(msg)
-
-          # Set up a restore context from .clientdata_url_search before
-          # handling all the input values, because the restore context may be
-          # used by an input handler (like the one for "shiny.file"). This
-          # should only happen once, when the app starts.
-          if (is.null(shinysession$restoreContext)) {
-            bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
-            if (bookmarkStore == "disable") {
-              # If bookmarking is disabled, use empty context
-              shinysession$restoreContext <- RestoreContext$new()
-            } else {
-              # If there's bookmarked state, save it on the session object
-              shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
-              shinysession$createBookmarkObservers()
-            }
-          }
-
-
-          msg$data <- applyInputHandlers(msg$data)
-
-          switch(
-            msg$method,
-            init = {
-
-              serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-              if (!identicalFunctionBodies(serverFunc, appvars$server)) {
-                appvars$server <- serverFunc
-                if (!is.null(appvars$server))
-                {
-                  # Tag this function as the Shiny server function. A debugger may use this
-                  # tag to give this function special treatment.
-                  # It's very important that it's appvars$server itself and NOT a copy that
-                  # is invoked, otherwise new breakpoints won't be picked up.
-                  attr(appvars$server, "shinyServerFunction") <- TRUE
-                  registerDebugHook("server", appvars, "Server Function")
-                }
-              }
-
-              # Check for switching into/out of showcase mode
-              if (.globals$showcaseOverride &&
-                  exists(".clientdata_url_search", where = msg$data)) {
-                mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
-                if (!is.null(mode))
-                  shinysession$setShowcase(mode)
-              }
-
-              # In shinysession$createBookmarkObservers() above, observers may be
-              # created, which puts the shiny session in busyCount > 0 state. That
-              # prevents the manageInputs here from taking immediate effect, by
-              # default. The manageInputs here needs to take effect though, because
-              # otherwise the bookmark observers won't find the clientData they are
-              # looking for. So use `now = TRUE` to force the changes to be
-              # immediate.
-              #
-              # FIXME: break createBookmarkObservers into two separate steps, one
-              # before and one after manageInputs, and put the observer creation
-              # in the latter. Then add an assertion that busyCount == 0L when
-              # this manageInputs is called.
-              shinysession$manageInputs(msg$data, now = TRUE)
-
-              # The client tells us what singletons were rendered into
-              # the initial page
-              if (!is.null(msg$data$.clientdata_singletons)) {
-                shinysession$singletons <- strsplit(
-                  msg$data$.clientdata_singletons, ',')[[1]]
-              }
-
-              local({
-                args <- argsForServerFunc(serverFunc, shinysession)
-
-                withReactiveDomain(shinysession, {
-                  do.call(
-                    # No corresponding ..stacktraceoff; the server func is pure
-                    # user code
-                    wrapFunctionLabel(appvars$server, "server",
-                      ..stacktraceon = TRUE
-                    ),
-                    args
-                  )
-                })
-              })
-            },
-            update = {
-              shinysession$manageInputs(msg$data)
-            },
-            shinysession$dispatch(msg)
-          )
-          # The HTTP_GUID, if it exists, is for Shiny Server reporting purposes
-          shinysession$startTiming(ws$request$HTTP_GUID)
-          shinysession$requestFlush()
-
-          # Make httpuv return control to Shiny quickly, instead of waiting
-          # for the usual timeout
-          httpuv::interrupt()
-        })
-      }
-      ws$onMessage(function(binary, msg) {
-        # If unhandled errors occur, make sure they get properly logged
-        withLogErrors(messageHandler(binary, msg))
-      })
-
-      ws$onClose(function() {
-        shinysession$wsClosed()
-        appsByToken$remove(shinysession$token)
-        appsNeedingFlush$remove(shinysession$token)
-      })
-
-      return(TRUE)
-    }
-  )
-  return(appHandlers)
-}
-
-# Determine what arguments should be passed to this serverFunc. All server funcs
-# must take input and output, but clientData (obsolete) and session are
-# optional.
-argsForServerFunc <- function(serverFunc, session) {
-  args <- list(input = session$input, output = .createOutputWriter(session))
-
-  paramNames <- names(formals(serverFunc))
-
-  # The clientData and session arguments are optional; check if
-  # each exists
-
-  if ("clientData" %in% paramNames)
-    args$clientData <- session$clientData
-
-  if ("session" %in% paramNames)
-    args$session <- session
-
-  args
-}
-
-getEffectiveBody <- function(func) {
-  if (is.null(func))
-    NULL
-  else if (isS4(func) && class(func) == "functionWithTrace")
-    body(func@original)
-  else
-    body(func)
-}
-
-identicalFunctionBodies <- function(a, b) {
-  identical(getEffectiveBody(a), getEffectiveBody(b))
-}
-
-handlerManager <- HandlerManager$new()
-
-addSubApp <- function(appObj, autoRemove = TRUE) {
-  path <- createUniqueId(16, "/app")
-  appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource)
-
-  # remove the leading / from the path so a relative path is returned
-  # (needed for the case where the root URL for the Shiny app isn't /, such
-  # as portmapped URLs)
-  finalPath <- paste(
-    substr(path, 2, nchar(path)),
-    "/?w=", workerId(),
-    "&__subapp__=1",
-    sep="")
-  handlerManager$addHandler(routeHandler(path, appHandlers$http), finalPath)
-  handlerManager$addWSHandler(routeWSHandler(path, appHandlers$ws), finalPath)
-
-  if (autoRemove) {
-    # If a session is currently active, remove this subapp automatically when
-    # the current session ends
-    onReactiveDomainEnded(getDefaultReactiveDomain(), function() {
-      removeSubApp(finalPath)
-    })
-  }
-
-  return(finalPath)
-}
-
-removeSubApp <- function(path) {
-  handlerManager$removeHandler(path)
-  handlerManager$removeWSHandler(path)
-}
-
-startApp <- function(appObj, port, host, quiet) {
-  appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource)
-  handlerManager$addHandler(appHandlers$http, "/", tail = TRUE)
-  handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE)
-
-  httpuvApp <- handlerManager$createHttpuvApp()
-  httpuvApp$staticPaths <- c(
-    appObj$staticPaths,
-    list(
-      # Always handle /session URLs dynamically, even if / is a static path.
-      "session" = excludeStaticPath(),
-      "shared" = system.file(package = "shiny", "www", "shared")
-    ),
-    .globals$resourcePaths
-  )
-
-  # throw an informative warning if a subdirectory of the
-  # app's www dir conflicts with another resource prefix
-  wwwDir <- httpuvApp$staticPaths[["/"]]$path
-  if (length(wwwDir)) {
-    # although httpuv allows for resource prefixes like 'foo/bar',
-    # we won't worry about conflicts in sub-sub directories since
-    # addResourcePath() currently doesn't allow it
-    wwwSubDirs <- list.dirs(wwwDir, recursive = FALSE, full.names = FALSE)
-    resourceConflicts <- intersect(wwwSubDirs, names(httpuvApp$staticPaths))
-    if (length(resourceConflicts)) {
-      warning(
-        "Found subdirectories of your app's www/ directory that ",
-        "conflict with other resource URL prefixes. ",
-        "Consider renaming these directories: '",
-        paste0("www/", resourceConflicts, collapse = "', '"), "'",
-        call. = FALSE
-      )
-    }
-  }
-
-  # check for conflicts in each pairwise combinations of resource mappings
-  checkResourceConflict <- function(paths) {
-    if (length(paths) < 2) return(NULL)
-    # ensure paths is a named character vector: c(resource_path = local_path)
-    paths <- vapply(paths, function(x) if (inherits(x, "staticPath")) x$path else x, character(1))
-    # get all possible pairwise combinations of paths
-    pair_indices <- utils::combn(length(paths), 2, simplify = FALSE)
-    lapply(pair_indices, function(x) {
-      p1 <- paths[x[1]]
-      p2 <- paths[x[2]]
-      if (identical(names(p1), names(p2)) && (p1 != p2)) {
-        warning(
-          "Found multiple local file paths pointing the same resource prefix: ", names(p1), ". ",
-          "If you run into resource-related issues (e.g. 404 requests), consider ",
-          "using `addResourcePath()` and/or `removeResourcePath()` to manage resource mappings.",
-          call. = FALSE
-        )
-      }
-    })
-  }
-  checkResourceConflict(httpuvApp$staticPaths)
-
-  httpuvApp$staticPathOptions <- httpuv::staticPathOptions(
-    html_charset = "utf-8",
-    headers = list("X-UA-Compatible" = "IE=edge,chrome=1"),
-    validation =
-      if (!is.null(getOption("shiny.sharedSecret"))) {
-        sprintf('"Shiny-Shared-Secret" == "%s"', getOption("shiny.sharedSecret"))
-      } else {
-        character(0)
-      }
-  )
-
-  if (is.numeric(port) || is.integer(port)) {
-    if (!quiet) {
-      hostString <- host
-      if (httpuv::ipFamily(host) == 6L)
-        hostString <- paste0("[", hostString, "]")
-      message('\n', 'Listening on http://', hostString, ':', port)
-    }
-    return(startServer(host, port, httpuvApp))
-  } else if (is.character(port)) {
-    if (!quiet) {
-      message('\n', 'Listening on domain socket ', port)
-    }
-    mask <- attr(port, 'mask')
-    if (is.null(mask)) {
-      stop("`port` is not a valid domain socket (missing `mask` attribute). ",
-           "Note that if you're using the default `host` + `port` ",
-           "configuration (and not domain sockets), then `port` must ",
-           "be numeric, not a string.")
-    }
-    return(startPipeServer(port, mask, httpuvApp))
-  }
-}
-
-# Run an application that was created by \code{\link{startApp}}. This
-# function should normally be called in a \code{while(TRUE)} loop.
-serviceApp <- function() {
-  timerCallbacks$executeElapsed()
-
-  flushReact()
-  flushPendingSessions()
-
-  # If this R session is interactive, then call service() with a short timeout
-  # to keep the session responsive to user input
-  maxTimeout <- ifelse(interactive(), 100, 1000)
-
-  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs()))
-  service(timeout)
-
-  flushReact()
-  flushPendingSessions()
-}
-
-.shinyServerMinVersion <- '0.3.4'
-
-#' Check whether a Shiny application is running
-#'
-#' This function tests whether a Shiny application is currently running.
-#'
-#' @return `TRUE` if a Shiny application is currently running. Otherwise,
-#'   `FALSE`.
-#' @export
-isRunning <- function() {
-  !is.null(getCurrentAppState())
-}
-
-
-# Returns TRUE if we're running in Shiny Server or other hosting environment,
-# otherwise returns FALSE.
-inShinyServer <- function() {
-  nzchar(Sys.getenv('SHINY_PORT'))
-}
-
-# This check was moved out of the main function body because of an issue with
-# the RStudio debugger. (#1474)
-isEmptyMessage <- function(msg) {
-  identical(as.raw(c(0x03, 0xe9)), msg)
-}

R/shiny-options.R

@@ -1,263 +0,0 @@
-.globals$options <- list()
-
-#' @param name Name of an option to get.
-#' @param default Value to be returned if the option is not currently set.
-#' @rdname shinyOptions
-#' @export
-getShinyOption <- function(name, default = NULL) {
-  # Make sure to use named (not numeric) indexing
-  name <- as.character(name)
-
-  # Check if there's a current session
-  session <- getDefaultReactiveDomain()
-  if (!is.null(session)) {
-    if (name %in% names(session$options)) {
-      return(session$options[[name]])
-    } else {
-      return(default)
-    }
-  }
-
-  # Check if there's a current app
-  app_state <- getCurrentAppState()
-  if (!is.null(app_state)) {
-    if (name %in% names(app_state$options)) {
-      return(app_state$options[[name]])
-    } else {
-      return(default)
-    }
-  }
-
-  # If we got here, look in global options
-  if (name %in% names(.globals$options)) {
-    return(.globals$options[[name]])
-  } else {
-    return(default)
-  }
-}
-
-#' Get or set Shiny options
-#'
-#' @description
-#'
-#' There are two mechanisms for working with options for Shiny. One is the
-#' [options()] function, which is part of base R, and the other is the
-#' `shinyOptions()` function, which is in the Shiny package. The reason for
-#' these two mechanisms is has to do with legacy code and scoping.
-#'
-#' The [options()] function sets options globally, for the duration of the R
-#' process. The [getOption()] function retrieves the value of an option. All
-#' shiny related options of this type are prefixed with `"shiny."`.
-#'
-#' The `shinyOptions()` function sets the value of a shiny option, but unlike
-#' `options()`, it is not always global in scope; the options may be scoped
-#' globally, to an application, or to a user session in an application,
-#' depending on the context. The `getShinyOption()` function retrieves a value
-#' of a shiny option. Currently, the options set via `shinyOptions` are for
-#' internal use only.
-#'
-#' @section Options with `options()`:
-#'
-#' \describe{
-#' \item{shiny.autoreload (defaults to `FALSE`)}{If `TRUE` when a Shiny app is launched, the
-#'   app directory will be continually monitored for changes to files that
-#'   have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. If any
-#'   changes are detected, all connected Shiny sessions are reloaded. This
-#'   allows for fast feedback loops when tweaking Shiny UI.
-#'
-#'   Since monitoring for changes is expensive (we simply poll for last
-#'   modified times), this feature is intended only for development.
-#'
-#'   You can customize the file patterns Shiny will monitor by setting the
-#'   shiny.autoreload.pattern option. For example, to monitor only ui.R:
-#'   `options(shiny.autoreload.pattern = glob2rx("ui.R"))`
-#'
-#'   The default polling interval is 500 milliseconds. You can change this
-#'   by setting e.g. `options(shiny.autoreload.interval = 2000)` (every
-#'   two seconds).}
-#' \item{shiny.deprecation.messages (defaults to `TRUE`)}{This controls whether messages for
-#'   deprecated functions in Shiny will be printed. See
-#'   [shinyDeprecated()] for more information.}
-#' \item{shiny.error (defaults to `NULL`)}{This can be a function which is called when an error
-#'   occurs. For example, `options(shiny.error=recover)` will result a
-#'   the debugger prompt when an error occurs.}
-#' \item{shiny.fullstacktrace (defaults to `FALSE`)}{Controls whether "pretty" (`FALSE`) or full
-#'   stack traces (`TRUE`) are dumped to the console when errors occur during Shiny app execution.
-#'   Pretty stack traces attempt to only show user-supplied code, but this pruning can't always
-#'   be done 100% correctly.}
-#' \item{shiny.host (defaults to `"127.0.0.1"`)}{The IP address that Shiny should listen on. See
-#'   [runApp()] for more information.}
-#' \item{shiny.jquery.version (defaults to `3`)}{The major version of jQuery to use.
-#' Currently only values of `3` or `1` are supported. If `1`, then jQuery 1.12.4 is used. If `3`,
-#' then jQuery 3.5.1 is used.}
-#' \item{shiny.json.digits (defaults to `16`)}{The number of digits to use when converting
-#'   numbers to JSON format to send to the client web browser.}
-#' \item{shiny.launch.browser (defaults to `interactive()`)}{A boolean which controls the default behavior
-#'   when an app is run. See [runApp()] for more information.}
-#' \item{shiny.maxRequestSize (defaults to 5MB)}{This is a number which specifies the maximum
-#'   web request size, which serves as a size limit for file uploads.}
-#' \item{shiny.minified (defaults to `TRUE`)}{By default
-#'   Whether or not to include Shiny's JavaScript as a minified (`shiny.min.js`)
-#'   or un-minified (`shiny.js`) file. The un-minified version is larger,
-#'   but can be helpful for development and debugging.}
-#' \item{shiny.port (defaults to a random open port)}{A port number that Shiny will listen on. See
-#'   [runApp()] for more information.}
-#' \item{shiny.reactlog (defaults to `FALSE`)}{If `TRUE`, enable logging of reactive events,
-#'   which can be viewed later with the [reactlogShow()] function.
-#'   This incurs a substantial performance penalty and should not be used in
-#'   production.}
-#' \item{shiny.sanitize.errors (defaults to `FALSE`)}{If `TRUE`, then normal errors (i.e.
-#'   errors not wrapped in `safeError`) won't show up in the app; a simple
-#'   generic error message is printed instead (the error and strack trace printed
-#'   to the console remain unchanged). If you want to sanitize errors in general, but you DO want a
-#'   particular error `e` to get displayed to the user, then set this option
-#'   to `TRUE` and use `stop(safeError(e))` for errors you want the
-#'   user to see.}
-#' \item{shiny.stacktraceoffset (defaults to `TRUE`)}{If `TRUE`, then Shiny's printed stack
-#'   traces will display srcrefs one line above their usual location. This is
-#'   an arguably more intuitive arrangement for casual R users, as the name
-#'   of a function appears next to the srcref where it is defined, rather than
-#'   where it is currently being called from.}
-#' \item{shiny.suppressMissingContextError (defaults to `FALSE`)}{Normally, invoking a reactive
-#'   outside of a reactive context (or [isolate()]) results in
-#'   an error. If this is `TRUE`, don't error in these cases. This
-#'   should only be used for debugging or demonstrations of reactivity at the
-#'   console.}
-#' \item{shiny.testmode (defaults to `FALSE`)}{If `TRUE`, then various features for testing Shiny
-#'   applications are enabled.}
-#' \item{shiny.trace (defaults to `FALSE`)}{Print messages sent between the R server and the web
-#'   browser client to the R console. This is useful for debugging. Possible
-#'   values are `"send"` (only print messages sent to the client),
-#'   `"recv"` (only print messages received by the server), `TRUE`
-#'   (print all messages), or `FALSE` (default; don't print any of these
-#'   messages).}
-#' \item{shiny.autoload.r (defaults to `TRUE`)}{If `TRUE`, then the R/
-#'   of a shiny app will automatically be sourced.}
-#' \item{shiny.usecairo (defaults to `TRUE`)}{This is used to disable graphical rendering by the
-#'   Cairo package, if it is installed. See [plotPNG()] for more
-#'   information.}
-#' }
-#'
-#'
-#' @section Scoping for `shinyOptions()`:
-#'
-#'   There are three levels of scoping for `shinyOptions()`: global,
-#'   application, and session.
-#'
-#'   The global option set is available by default. Any calls to
-#'   `shinyOptions()` and `getShinyOption()` outside of an app will access the
-#'   global option set.
-#'
-#'   When a Shiny application is run with [runApp()], the global option set is
-#'   duplicated and the new option set is available at the application level. If
-#'   options are set from `global.R`, `app.R`, `ui.R`, or `server.R` (but
-#'   outside of the server function), then the application-level options will be
-#'   modified.
-#'
-#'   Each time a user session is started, the application-level option set is
-#'   duplicated, for that session. If the options are set from inside the server
-#'   function, then they will be scoped to the session.
-#'
-#' @section Options with `shinyOptions()`:
-#'
-#'   There are a number of global options that affect Shiny's behavior. These
-#'   can be set globally with `options()` or locally (for a single app) with
-#'   `shinyOptions()`.
-#'
-#'   \describe{ \item{cache}{A caching object that will be used by
-#'   [renderCachedPlot()]. If not specified, a [memoryCache()] will be used.} }
-#'
-#' @param ... Options to set, with the form `name = value`.
-#' @aliases shiny-options
-#' @export
-shinyOptions <- function(...) {
-  newOpts <- list(...)
-
-  if (length(newOpts) > 0) {
-    # If we're within a session, modify at the session level.
-    session <- getDefaultReactiveDomain()
-    if (!is.null(session)) {
-      # Modify session-level-options
-      session$options <- dropNulls(mergeVectors(session$options, newOpts))
-      return(invisible(session$options))
-    }
-
-    # If not in a session, but we have a currently running app, modify options
-    # at the app level.
-    app_state <- getCurrentAppState()
-    if (!is.null(app_state)) {
-      # Modify app-level options
-      app_state$options <- dropNulls(mergeVectors(app_state$options, newOpts))
-      return(invisible(app_state$options))
-    }
-
-    # If no currently running app, modify global options and return them.
-    .globals$options <- dropNulls(mergeVectors(.globals$options, newOpts))
-    return(invisible(.globals$options))
-  }
-
-  # If not setting any options, just return current option set, visibly.
-
-  session <- getDefaultReactiveDomain()
-  if (!is.null(session)) {
-    return(session$options)
-  }
-
-  app_state <- getCurrentAppState()
-  if (!is.null(app_state)) {
-    return(app_state$options)
-  }
-
-  return(.globals$options)
-}
-
-
-# Get specific shiny options and put them in a list, reset those shiny options,
-# and then return the options list. This should be during the creation of a
-# shiny app object. This function "consumes" the options when the shinyApp
-# object is created, so the options won't affect another app that is created
-# later.
-#
-# ==== Example ====
-# shinyOptions(bookmarkStore = 1234)
-# # This now returns 1234.
-# getShinyOption("bookmarkStore")
-#
-# # Creating the app captures the bookmarkStore option and clears it.
-# s <- shinyApp(
-#   fluidPage(verbatimTextOutput("txt")),
-#   function(input, output) {
-#     output$txt <- renderText(getShinyOption("bookmarkStore"))
-#   }
-# )
-#
-# # This now returns NULL.
-# getShinyOption("bookmarkStore")
-#
-# When running the app, the app will display "1234"
-# runApp(s)
-#
-# # After quitting the app, this still returns NULL.
-# getShinyOption("bookmarkStore")
-# ==================
-#
-# If another app had been created after s was created, but before s was run,
-# then it would capture the value of "bookmarkStore" at the time of creation.
-captureAppOptions <- function() {
-  options <- list(
-    appDir = getwd(),
-    bookmarkStore = getShinyOption("bookmarkStore")
-  )
-
-  shinyOptions(appDir = NULL, bookmarkStore = NULL)
-
-  options
-}
-
-# Do the inverse of captureAppOptions. This should be called once the app is
-# started.
-applyCapturedAppOptions <- function(options) {
-  if (!is.null(options)) {
-    do.call(shinyOptions, options)
-  }
-}

R/shinyapp.R

@@ -1,580 +0,0 @@
-# TODO: Subapp global.R
-
-#' Create a Shiny app object
-#'
-#' These functions create Shiny app objects from either an explicit UI/server
-#' pair (`shinyApp`), or by passing the path of a directory that contains a
-#' Shiny app (`shinyAppDir`).
-#'
-#' Normally when this function is used at the R console, the Shiny app object is
-#' automatically passed to the `print()` function, which runs the app. If
-#' this is called in the middle of a function, the value will not be passed to
-#' `print()` and the app will not be run. To make the app run, pass the app
-#' object to `print()` or [runApp()].
-#'
-#' @param ui The UI definition of the app (for example, a call to
-#'   `fluidPage()` with nested controls).
-#'
-#'    If bookmarking is enabled (see `enableBookmarking`), this must be
-#'    a single argument function that returns the UI definition.
-#' @param server A function with three parameters: `input`, `output`, and
-#'   `session`. The function is called once for each session ensuring that each
-#'   app is independent.
-#' @param onStart A function that will be called before the app is actually run.
-#'   This is only needed for `shinyAppObj`, since in the `shinyAppDir`
-#'   case, a `global.R` file can be used for this purpose.
-#' @param options Named options that should be passed to the `runApp` call
-#'   (these can be any of the following: "port", "launch.browser", "host", "quiet",
-#'   "display.mode" and "test.mode"). You can also specify `width` and
-#'   `height` parameters which provide a hint to the embedding environment
-#'   about the ideal height/width for the app.
-#' @param uiPattern A regular expression that will be applied to each `GET`
-#'   request to determine whether the `ui` should be used to handle the
-#'   request. Note that the entire request path must match the regular
-#'   expression in order for the match to be considered successful.
-#' @param enableBookmarking Can be one of `"url"`, `"server"`, or
-#'   `"disable"`. The default value, `NULL`, will respect the setting from
-#'   any previous calls to  [enableBookmarking()]. See [enableBookmarking()]
-#'   for more information on bookmarking your app.
-#' @return An object that represents the app. Printing the object or passing it
-#'   to [runApp()] will run the app.
-#'
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'   options(device.ask.default = FALSE)
-#'
-#'   shinyApp(
-#'     ui = fluidPage(
-#'       numericInput("n", "n", 1),
-#'       plotOutput("plot")
-#'     ),
-#'     server = function(input, output) {
-#'       output$plot <- renderPlot( plot(head(cars, input$n)) )
-#'     }
-#'   )
-#'
-#'   shinyAppDir(system.file("examples/01_hello", package="shiny"))
-#'
-#'
-#'   # The object can be passed to runApp()
-#'   app <- shinyApp(
-#'     ui = fluidPage(
-#'       numericInput("n", "n", 1),
-#'       plotOutput("plot")
-#'     ),
-#'     server = function(input, output) {
-#'       output$plot <- renderPlot( plot(head(cars, input$n)) )
-#'     }
-#'   )
-#'
-#'   runApp(app)
-#' }
-#' @export
-shinyApp <- function(ui, server, onStart=NULL, options=list(),
-                     uiPattern="/", enableBookmarking=NULL) {
-  if (!is.function(server)) {
-    stop("`server` must be a function", call. = FALSE)
-  }
-
-  # Ensure that the entire path is a match
-  uiPattern <- sprintf("^%s$", uiPattern)
-
-  httpHandler <- uiHttpHandler(ui, uiPattern)
-
-  serverFuncSource <- function() {
-    server
-  }
-
-  if (!is.null(enableBookmarking)) {
-    bookmarkStore <- match.arg(enableBookmarking, c("url", "server", "disable"))
-    enableBookmarking(bookmarkStore)
-  }
-
-  # Store the appDir and bookmarking-related options, so that we can read them
-  # from within the app.
-  appOptions <- captureAppOptions()
-
-  structure(
-    list(
-      httpHandler = httpHandler,
-      serverFuncSource = serverFuncSource,
-      onStart = onStart,
-      options = options,
-      appOptions = appOptions
-    ),
-    class = "shiny.appobj"
-  )
-}
-
-#' @rdname shinyApp
-#' @param appDir Path to directory that contains a Shiny app (i.e. a server.R
-#'   file and either ui.R or www/index.html)
-#' @export
-shinyAppDir <- function(appDir, options=list()) {
-  if (!utils::file_test('-d', appDir)) {
-    stop("No Shiny application exists at the path \"", appDir, "\"")
-  }
-
-  # In case it's a relative path, convert to absolute (so we're not adversely
-  # affected by future changes to the path)
-  appDir <- normalizePath(appDir, mustWork = TRUE)
-
-  if (file.exists.ci(appDir, "server.R")) {
-    shinyAppDir_serverR(appDir, options = options)
-  } else if (file.exists.ci(appDir, "app.R")) {
-    shinyAppDir_appR("app.R", appDir, options = options)
-  } else {
-    stop("App dir must contain either app.R or server.R.")
-  }
-}
-
-#' @rdname shinyApp
-#' @param appFile Path to a .R file containing a Shiny application
-#' @export
-shinyAppFile <- function(appFile, options=list()) {
-  appFile <- normalizePath(appFile, mustWork = TRUE)
-  appDir <- dirname(appFile)
-
-  shinyAppDir_appR(basename(appFile), appDir, options = options)
-}
-
-# This reads in an app dir in the case that there's a server.R (and ui.R/www)
-# present, and returns a shiny.appobj.
-# appDir must be a normalized (absolute) path, not a relative one
-shinyAppDir_serverR <- function(appDir, options=list()) {
-  # Most of the complexity here comes from needing to hot-reload if the .R files
-  # change on disk, or are created, or are removed.
-
-  # In an upcoming version of shiny, this option will go away.
-  if (getOption("shiny.autoload.r", TRUE)) {
-    # Create a child env which contains all the helpers and will be the shared parent
-    # of the ui.R and server.R load.
-    sharedEnv <- new.env(parent = globalenv())
-  } else {
-    # old behavior
-    sharedEnv <- globalenv()
-  }
-
-  # uiHandlerSource is a function that returns an HTTP handler for serving up
-  # ui.R as a webpage. The "cachedFuncWithFile" call makes sure that the closure
-  # we're creating here only gets executed when ui.R's contents change.
-  uiHandlerSource <- cachedFuncWithFile(appDir, "ui.R", case.sensitive = FALSE,
-    function(uiR) {
-      if (file.exists(uiR)) {
-        # If ui.R contains a call to shinyUI (which sets .globals$ui), use that.
-        # If not, then take the last expression that's returned from ui.R.
-        .globals$ui <- NULL
-        on.exit(.globals$ui <- NULL, add = FALSE)
-        ui <- sourceUTF8(uiR, envir = new.env(parent = sharedEnv))
-        if (!is.null(.globals$ui)) {
-          ui <- .globals$ui[[1]]
-        }
-        return(uiHttpHandler(ui))
-      } else {
-        return(function(req) NULL)
-      }
-    }
-  )
-  uiHandler <- function(req) {
-    uiHandlerSource()(req)
-  }
-
-  wwwDir <- file.path.ci(appDir, "www")
-  if (dirExists(wwwDir)) {
-    staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE))
-  } else {
-    staticPaths <- list()
-  }
-
-  fallbackWWWDir <- system.file("www-dir", package = "shiny")
-
-  serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE,
-    function(serverR) {
-      # If server.R contains a call to shinyServer (which sets .globals$server),
-      # use that. If not, then take the last expression that's returned from
-      # server.R.
-      .globals$server <- NULL
-      on.exit(.globals$server <- NULL, add = TRUE)
-      result <- sourceUTF8(serverR, envir = new.env(parent = sharedEnv))
-      if (!is.null(.globals$server)) {
-        result <- .globals$server[[1]]
-      }
-      return(result)
-    }
-  )
-
-  # This function stands in for the server function, and reloads the
-  # real server function as necessary whenever server.R changes
-  serverFuncSource <- function() {
-    serverFunction <- serverSource()
-    if (is.null(serverFunction)) {
-      return(function(input, output) NULL)
-    } else if (is.function(serverFunction)) {
-      # This is what we normally expect; run the server function
-      return(serverFunction)
-    } else {
-      stop("server.R returned an object of unexpected type: ",
-        typeof(serverFunction))
-    }
-  }
-
-  shinyOptions(appDir = appDir)
-
-  oldwd <- NULL
-  monitorHandle <- NULL
-  onStart <- function() {
-    oldwd <<- getwd()
-    setwd(appDir)
-    # TODO: we should support hot reloading on global.R and R/*.R changes.
-    if (getOption("shiny.autoload.r", TRUE)) {
-      loadSupport(appDir, renv=sharedEnv, globalrenv=globalenv())
-    }  else {
-      if (file.exists(file.path.ci(appDir, "global.R")))
-        sourceUTF8(file.path.ci(appDir, "global.R"))
-    }
-    monitorHandle <<- initAutoReloadMonitor(appDir)
-  }
-  onStop <- function() {
-    setwd(oldwd)
-    # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured
-    # This will cause `onStop` to be called.
-    #   The `oldwd` will exist, but `monitorHandle` is not a function yet.
-    if (is.function(monitorHandle)) {
-      monitorHandle()
-      monitorHandle <<- NULL
-    }
-  }
-
-  structure(
-    list(
-      staticPaths = staticPaths,
-      # Even though the wwwDir is handled as a static path, we need to include
-      # it here to be handled by R as well. This is because the special case
-      # of index.html: it is specifically not handled as a staticPath for
-      # reasons explained above, but if someone does want to serve up an
-      # index.html, we need to handle it, and we do it by using the
-      # staticHandler in the R code path. (#2380)
-      httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
-      serverFuncSource = serverFuncSource,
-      onStart = onStart,
-      onStop = onStop,
-      options = options
-    ),
-    class = "shiny.appobj"
-  )
-}
-
-# Start a reactive observer that continually monitors dir for changes to files
-# that have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. Case is
-# ignored when checking extensions. If any changes are detected, all connected
-# Shiny sessions are reloaded.
-#
-# Use options(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
-# for changes is expensive (we are polling for mtimes here, nothing fancy) this
-# feature is intended only for development.
-#
-# You can customize the file patterns Shiny will monitor by setting the
-# shiny.autoreload.pattern option. For example, to monitor only ui.R:
-# options(shiny.autoreload.pattern = glob2rx("ui.R"))
-#
-# The return value is a function that halts monitoring when called.
-initAutoReloadMonitor <- function(dir) {
-  if (!getOption("shiny.autoreload", FALSE)) {
-    return(function(){})
-  }
-
-  filePattern <- getOption("shiny.autoreload.pattern",
-    ".*\\.(r|html?|js|css|png|jpe?g|gif)$")
-
-  lastValue <- NULL
-  observeLabel <- paste0("File Auto-Reload - '", basename(dir), "'")
-  obs <- observe(label = observeLabel, {
-    files <- sort_c(
-      list.files(dir, pattern = filePattern, recursive = TRUE, ignore.case = TRUE)
-    )
-    times <- file.info(files)$mtime
-    names(times) <- files
-
-    if (is.null(lastValue)) {
-      # First run
-      lastValue <<- times
-    } else if (!identical(lastValue, times)) {
-      # We've changed!
-      lastValue <<- times
-      autoReloadCallbacks$invoke()
-    }
-
-    invalidateLater(getOption("shiny.autoreload.interval", 500))
-  })
-
-  onStop(obs$destroy)
-
-  obs$destroy
-}
-
-#' Load an app's supporting R files
-#'
-#' Loads all of the supporting R files of a Shiny application. Specifically,
-#' this function loads any top-level supporting `.R` files in the `R/` directory
-#' adjacent to the `app.R`/`server.R`/`ui.R` files.
-#'
-#' Since Shiny 1.5.0, this function is called by default when running an
-#' application. If it causes problems, there are two ways to opt out. You can
-#' either place a file named `_disable_autoload.R` in your R/ directory, or
-#' set `options(shiny.autoload.r=FALSE)`. If you set this option, it will
-#' affect any application that runs later in the same R session, potentially
-#' breaking it, so after running your application, you should unset option with
-#' `options(shiny.autoload.r=NULL)`
-#'
-#' @details The files are sourced in alphabetical order (as determined by
-#'   [list.files]). `global.R` is evaluated before the supporting R files in the
-#'   `R/` directory.
-#' @param appDir The application directory. If `appDir` is `NULL` or
-#'   not supplied, the nearest enclosing directory that is a Shiny app, starting
-#'   with the current directory, is used.
-#' @param renv The environmeny in which the files in the `R/` directory should
-#'   be evaluated.
-#' @param globalrenv The environment in which `global.R` should be evaluated. If
-#'   `NULL`, `global.R` will not be evaluated at all.
-#' @export
-loadSupport <- function(appDir=NULL, renv=new.env(parent=globalenv()), globalrenv=globalenv()){
-  require(shiny)
-
-  if (is.null(appDir)) {
-    appDir <- findEnclosingApp(".")
-  }
-
-  if (!is.null(globalrenv)){
-    # Evaluate global.R, if it exists.
-    globalPath <- file.path.ci(appDir, "global.R")
-    if (file.exists(globalPath)){
-      withr::with_dir(appDir, {
-        sourceUTF8(basename(globalPath), envir=globalrenv)
-      })
-    }
-  }
-
-
-  helpersDir <- file.path(appDir, "R")
-
-  disabled <- list.files(helpersDir, pattern="^_disable_autoload\\.r$", recursive=FALSE, ignore.case=TRUE)
-  if (length(disabled) > 0){
-    return(invisible(renv))
-  }
-
-  helpers <- list.files(helpersDir, pattern="\\.[rR]$", recursive=FALSE, full.names=TRUE)
-  # Ensure files in R/ are sorted according to the 'C' locale before sourcing.
-  # This convention is based on the default for packages. For details, see:
-  # https://cran.r-project.org/doc/manuals/r-release/R-exts.html#The-DESCRIPTION-file
-  helpers <- sort_c(helpers)
-  helpers <- normalizePath(helpers)
-
-  withr::with_dir(appDir, {
-    lapply(helpers, sourceUTF8, envir=renv)
-  })
-
-  invisible(renv)
-}
-
-# This reads in an app dir for a single-file application (e.g. app.R), and
-# returns a shiny.appobj.
-# appDir must be a normalized (absolute) path, not a relative one
-shinyAppDir_appR <- function(fileName, appDir, options=list())
-{
-  fullpath <- file.path.ci(appDir, fileName)
-
-  # This sources app.R and caches the content. When appObj() is called but
-  # app.R hasn't changed, it won't re-source the file. But if called and
-  # app.R has changed, it'll re-source the file and return the result.
-  appObj <- cachedFuncWithFile(appDir, fileName, case.sensitive = FALSE,
-    function(appR) {
-      wasDir <- setwd(appDir)
-      on.exit(setwd(wasDir))
-
-      # TODO: we should support hot reloading on R/*.R changes.
-      # In an upcoming version of shiny, this option will go away.
-      if (getOption("shiny.autoload.r", TRUE)) {
-        # Create a child env which contains all the helpers and will be the shared parent
-        # of the ui.R and server.R load.
-        sharedEnv <- new.env(parent = globalenv())
-        loadSupport(appDir, renv=sharedEnv, globalrenv=NULL)
-      } else {
-        sharedEnv <- globalenv()
-      }
-      result <- sourceUTF8(fullpath, envir = new.env(parent = sharedEnv))
-
-      if (!is.shiny.appobj(result))
-        stop("app.R did not return a shiny.appobj object.")
-
-      applyCapturedAppOptions(result$appOptions)
-
-      return(result)
-    }
-  )
-
-  # A function that invokes the http handler from the appObj in app.R, but
-  # since this uses appObj(), it only re-sources the file when it changes.
-  dynHttpHandler <- function(...) {
-    appObj()$httpHandler(...)
-  }
-
-  dynServerFuncSource <- function(...) {
-    appObj()$serverFuncSource(...)
-  }
-
-  wwwDir <- file.path.ci(appDir, "www")
-  if (dirExists(wwwDir)) {
-    # wwwDir is a static path served by httpuv. It does _not_ serve up
-    # index.html, for two reasons. (1) It's possible that the user's
-    # www/index.html file is not actually used as the index, but as a template
-    # that gets processed before being sent; and (2) the index content may be
-    # modified by the hosting environment (as in SockJSAdapter.R).
-    #
-    # The call to staticPath normalizes the path, so that if the working dir
-    # later changes, it will continue to point to the right place.
-    staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE))
-  } else {
-    staticPaths <- list()
-  }
-
-  fallbackWWWDir <- system.file("www-dir", package = "shiny")
-
-  oldwd <- NULL
-  monitorHandle <- NULL
-  onStart <- function() {
-    oldwd <<- getwd()
-    setwd(appDir)
-    if (!is.null(appObj()$onStart)) appObj()$onStart()
-    monitorHandle <<- initAutoReloadMonitor(appDir)
-    invisible()
-  }
-  onStop <- function() {
-    setwd(oldwd)
-    # It is possible that while calling appObj()$onStart() or loadingSupport, an error occured
-    # This will cause `onStop` to be called.
-    #   The `oldwd` will exist, but `monitorHandle` is not a function yet.
-    if (is.function(monitorHandle)) {
-      monitorHandle()
-      monitorHandle <<- NULL
-    }
-  }
-
-  appObjOptions <- appObj()$options
-
-  structure(
-    list(
-      # fallbackWWWDir is _not_ listed in staticPaths, because it needs to
-      # come after the uiHandler. It also does not need to be fast, since it
-      # should rarely be hit. The order is wwwDir (in staticPaths), then
-      # uiHandler, then falbackWWWDir (which is served up by the R
-      # staticHandler function).
-      staticPaths = staticPaths,
-      # Even though the wwwDir is handled as a static path, we need to include
-      # it here to be handled by R as well. This is because the special case
-      # of index.html: it is specifically not handled as a staticPath for
-      # reasons explained above, but if someone does want to serve up an
-      # index.html, we need to handle it, and we do it by using the
-      # staticHandler in the R code path. (#2380)
-      httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
-      serverFuncSource = dynServerFuncSource,
-      onStart = onStart,
-      onStop = onStop,
-      options = joinOptions(appObjOptions, options)
-    ),
-    class = "shiny.appobj"
-  )
-}
-
-
-#' Shiny App object
-#'
-#' Internal methods for the `shiny.appobj` S3 class.
-#'
-#' @keywords internal
-#' @name shiny.appobj
-NULL
-
-#' @rdname shiny.appobj
-#' @param x Object to convert to a Shiny app.
-#' @export
-as.shiny.appobj <- function(x) {
-  UseMethod("as.shiny.appobj", x)
-}
-
-#' @rdname shiny.appobj
-#' @export
-as.shiny.appobj.shiny.appobj <- function(x) {
-  x
-}
-
-#' @rdname shiny.appobj
-#' @export
-as.shiny.appobj.list <- function(x) {
-  shinyApp(ui = x$ui, server = x$server)
-}
-
-#' @rdname shiny.appobj
-#' @export
-as.shiny.appobj.character <- function(x) {
-  if (identical(tolower(tools::file_ext(x)), "r"))
-    shinyAppFile(x)
-  else
-    shinyAppDir(x)
-}
-
-#' @rdname shiny.appobj
-#' @export
-is.shiny.appobj <- function(x) {
-  inherits(x, "shiny.appobj")
-}
-
-#' @rdname shiny.appobj
-#' @param ... Ignored.
-#' @export
-print.shiny.appobj <- function(x, ...) {
-  runApp(x)
-}
-
-# Joins two options objects (i.e. the `options` argument to shinyApp(),
-# shinyAppDir(), etc.). The values in `b` should take precedence over the values
-# in `a`. Given the current options available, it is safe to throw away any
-# values in `a` that are provided in `b`. But in the future, if new options are
-# introduced that need to be combined in some way instead of simply overwritten,
-# then this will be the place to do it. See the implementations of
-# print.shiny.appobj() and runApp() (for the latter, look specifically for
-# "findVal()") to determine the set of possible options.
-joinOptions <- function(a, b) {
-  stopifnot(is.null(a) || is.list(a))
-  stopifnot(is.null(b) || is.list(b))
-
-  mergeVectors(a, b)
-}
-
-#' @rdname shiny.appobj
-#' @method as.tags shiny.appobj
-#' @export
-as.tags.shiny.appobj <- function(x, ...) {
-  # jcheng 06/06/2014: Unfortunate copy/paste between this function and
-  # knit_print.shiny.appobj, but I am trying to make the most conservative
-  # change possible due to upcoming release.
-  opts <- x$options %OR% list()
-  width <- if (is.null(opts$width)) "100%" else opts$width
-  height <- if (is.null(opts$height)) "400" else opts$height
-
-  path <- addSubApp(x)
-  deferredIFrame(path, width, height)
-}
-
-# Generate subapp iframes in such a way that they will not actually load right
-# away. Loading subapps immediately upon app load can result in a storm of
-# connections, all of which are contending for the few concurrent connections
-# that a browser will make to a specific origin. Instead, we load dummy iframes
-# and let the client load them when convenient. (See the initIframes function in
-# init_shiny.js.)
-deferredIFrame <- function(path, width, height) {
-  tags$iframe("data-deferred-src" = path,
-    width = width, height = height,
-    class = "shiny-frame shiny-frame-deferred"
-  )
-}

R/shinyui.R

@@ -1,202 +1,252 @@
-#' @include globals.R
-NULL
 
-#' Load the MathJax library and typeset math expressions
-#'
-#' This function adds MathJax to the page and typeset the math expressions (if
-#' found) in the content `...`. It only needs to be called once in an app
-#' unless the content is rendered *after* the page is loaded, e.g. via
-#' [renderUI()], in which case we have to call it explicitly every
-#' time we write math expressions to the output.
-#' @param ... any HTML elements to apply MathJax to
 #' @export
-#' @examples withMathJax(helpText("Some math here $$\\alpha+\\beta$$"))
-#' # 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'
-  tagList(
-    tags$head(
-      singleton(tags$script(src = path, type = 'text/javascript'))
-    ),
-    ...,
-    tags$script(HTML('if (window.MathJax) MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
-  )
+p <- function(...) tags$p(...)
+
+#' @export
+h1 <- function(...) tags$h1(...)
+
+#' @export
+h2 <- function(...) tags$h2(...)
+
+#' @export
+h3 <- function(...) tags$h3(...)
+
+#' @export
+h4 <- function(...) tags$h4(...)
+
+#' @export
+h5 <- function(...) tags$h5(...)
+
+#' @export
+h6 <- function(...) tags$h6(...)
+
+#' @export
+a <- function(...) tags$a(...)
+
+#' @export
+br <- function(...) tags$br(...)
+
+#' @export
+div <- function(...) tags$div(...)
+
+#' @export
+span <- function(...) tags$span(...)
+
+#' @export
+pre <- function(...) tags$pre(...)
+
+#' @export
+code <- function(...) tags$code(...)
+
+#' @export
+img <- function(...) tags$img(...)
+
+#' @export
+strong <- function(...) tags$strong(...)
+
+#' @export
+em <- function(...) tags$em(...)
+
+#' Include Content From a File
+#' 
+#' Include HTML, text, or rendered Markdown into a \link[=shinyUI]{Shiny UI}.
+#' 
+#' These functions provide a convenient way to include an extensive amount of 
+#' HTML, textual, Markdown, CSS, or JavaScript content, rather than using a
+#' large literal R string.
+#' 
+#' @note \code{includeText} escapes its contents, but does no other processing. 
+#'   This means that hard breaks and multiple spaces will be rendered as they 
+#'   usually are in HTML: as a single space character. If you are looking for 
+#'   preformatted text, wrap the call with \code{\link{pre}}, or consider using 
+#'   \code{includeMarkdown} instead.
+#'   
+#' @note The \code{includeMarkdown} function requires the \code{markdown} 
+#'   package.
+#'   
+#' @param path The path of the file to be included. It is highly recommended to 
+#'   use a relative path (the base path being the Shiny application directory), 
+#'   not an absolute path.
+#'   
+#' @rdname include
+#' @export
+includeHTML <- function(path) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(HTML(paste(lines, collapse='\r\n')))
 }
 
-renderPage <- function(ui, showcase=0, testMode=FALSE) {
-  lang <- getLang(ui)
+#' @rdname include
+#' @export
+includeText <- function(path) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(paste(lines, collapse='\r\n'))
+}
 
-  # If the ui is a NOT complete document (created by htmlTemplate()), then do some
-  # preprocessing and make sure it's a complete document.
-  if (!inherits(ui, "html_document")) {
-    if (showcase > 0)
-      ui <- showcaseUI(ui)
+#' @rdname include
+#' @export
+includeMarkdown <- function(path) {
+  if (!require(markdown))
+    stop("Markdown package is not installed")
+  
+  dependsOnFile(path)
+  html <- markdown::markdownToHTML(path, fragment.only=TRUE)
+  Encoding(html) <- 'UTF-8'
+  return(HTML(html))
+}
 
-    # Wrap ui in body tag if it doesn't already have a single top-level body tag.
-    if (!(inherits(ui, "shiny.tag") && ui$name == "body"))
-      ui <- tags$body(ui)
+#' @param ... Any additional attributes to be applied to the generated tag.
+#' @rdname include
+#' @export
+includeCSS <- function(path, ...) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  args <- list(...)
+  if (is.null(args$type))
+    args$type <- 'text/css'
+  return(do.call(tags$style,
+                 c(list(HTML(paste(lines, collapse='\r\n'))), args)))
+}
 
-    # Put the body into the default template
-    ui <- htmlTemplate(
-      system.file("template", "default.html", package = "shiny"),
-      lang = lang,
-      body = ui,
-      # this template is a complete HTML document
-      document_ = TRUE
-    )
-  }
+#' @rdname include
+#' @export
+includeScript <- function(path, ...) {
+  dependsOnFile(path)
+  lines <- readLines(path, warn=FALSE, encoding='UTF-8')
+  return(tags$script(HTML(paste(lines, collapse='\r\n')), ...))
+}
 
-  jquery <- function() {
-    version <- getOption("shiny.jquery.version", 3)
-    if (version == 3) {
-      return(htmlDependency(
-        "jquery", "3.5.1",
-        c(href = "shared"),
-        script = "jquery.min.js"
-      ))
+
+#' Include Content Only Once
+#' 
+#' Use \code{singleton} to wrap contents (tag, text, HTML, or lists) that should
+#' be included in the generated document only once, yet may appear in the 
+#' document-generating code more than once. Only the first appearance of the 
+#' content (in document order) will be used. Useful for custom components that 
+#' have JavaScript files or stylesheets.
+#' 
+#' @param x A \code{\link{tag}}, text, \code{\link{HTML}}, or list.
+#'
+#' @export
+singleton <- function(x) {
+  class(x) <- c(class(x), 'shiny.singleton')
+  return(x)
+}
+
+renderPage <- function(ui, connection) {
+  
+  # provide a filter so we can intercept head tag requests
+  context <- new.env()
+  context$head <- character()
+  context$singletons <- character()
+  context$filter <- function(content) {
+    if (inherits(content, 'shiny.singleton')) {
+      sig <- digest(content, algo='sha1')
+      if (sig %in% context$singletons)
+        return(FALSE)
+      context$singletons <- c(sig, context$singletons)
     }
-    if (version == 1) {
-      return(htmlDependency(
-        "jquery", "1.12.4",
-        c(href = "shared/legacy"),
-        script = "jquery.min.js"
-      ))
+    
+    if (isTag(content) && identical(content$name, "head")) {
+      textConn <- textConnection(NULL, "w") 
+      textConnWriter <- function(text) cat(text, file = textConn)
+      tagWrite(content$children, textConnWriter, 1, context)
+      context$head <- append(context$head, textConnectionValue(textConn))
+      close(textConn)
+      return (FALSE)
+    }
+    else {
+      return (TRUE)
     }
-    stop("Unsupported version of jQuery: ", version)
   }
-
-  shiny_deps <- c(
-    list(jquery()),
-    shinyDependencies()
-  )
-
-  if (testMode) {
-    # Add code injection listener if in test mode
-    shiny_deps[[length(shiny_deps) + 1]] <-
-      htmlDependency("shiny-testmode", utils::packageVersion("shiny"),
-                     c(href="shared"), script = "shiny-testmode.js")
-  }
-
-  html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
-  enc2utf8(paste(collapse = "\n", html))
-}
-
-shinyDependencies <- function() {
-  version <- utils::packageVersion("shiny")
-  list(
-    bootstraplib::bs_dependency_defer(shinyDependencyCSS),
-    htmlDependency(
-      name = "shiny-javascript",
-      version = version,
-      src = c(href = "shared"),
-      script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js"
-    )
-  )
-}
-
-shinyDependencyCSS <- function(theme) {
-  version <- utils::packageVersion("shiny")
-
-  if (!is_bs_theme(theme)) {
-    return(htmlDependency(
-      name = "shiny-css",
-      version = version,
-      src = c(href = "shared"),
-      stylesheet = "shiny.min.css"
-    ))
-  }
-
-  scss_home <- system.file("www/shared/shiny_scss", package = "shiny")
-  scss_files <- file.path(scss_home, c("bootstrap.scss", "shiny.scss"))
-  scss_files <- lapply(scss_files, sass::sass_file)
-
-  bootstraplib::bs_dependency(
-    input = scss_files,
-    theme = theme,
-    name = "shiny-sass",
-    version = version,
-    cache_key_extra = version
-  )
+  
+  # write ui HTML to a character vector
+  textConn <- textConnection(NULL, "w") 
+  tagWrite(ui, function(text) cat(text, file = textConn), 0, context)
+  uiHTML <- textConnectionValue(textConn)
+  close(textConn)
+ 
+  # write preamble
+  writeLines(c('<!DOCTYPE html>',
+               '<html>',
+               '<head>',
+               '  <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>',
+               '  <script src="shared/jquery.js" type="text/javascript"></script>',
+               '  <script src="shared/shiny.js" type="text/javascript"></script>',
+               '  <link rel="stylesheet" type="text/css" href="shared/shiny.css"/>',
+               context$head,
+               '</head>',
+               '<body>', 
+               recursive=TRUE),
+             con = connection)
+  
+  # write UI html to connection
+  writeLines(uiHTML, con = connection)
+  
+  # write end document
+  writeLines(c('</body>',
+               '</html>'),
+             con = connection)
 }
 
 #' Create a Shiny UI handler
+#' 
+#' Register a UI handler by providing a UI definition (created with e.g. 
+#' \link{pageWithSidebar}) and web server path (typically "/", the default
+#' value).
+#' 
+#' @param ui A user-interace definition
+#' @param path The web server path to server the UI from
+#' @return Called for its side-effect of registering a UI handler
+#' 
+#' @examples
+#' el <- div(HTML("I like <u>turtles</u>"))
+#' cat(as.character(el))
+#'   
+#' @examples
+#' # Define UI
+#' shinyUI(pageWithSidebar(
+#'   
+#'   # Application title
+#'   headerPanel("Hello Shiny!"),
+#'   
+#'   # Sidebar with a slider input
+#'   sidebarPanel(
+#'     sliderInput("obs", 
+#'                 "Number of observations:", 
+#'                 min = 0, 
+#'                 max = 1000, 
+#'                 value = 500)
+#'   ),
+#'   
+#'   # Show a plot of the generated distribution
+#'   mainPanel(
+#'     plotOutput("distPlot")
+#'   )
+#' ))
 #'
-#' Historically this function was used in ui.R files to register a user
-#' interface with Shiny. It is no longer required as of Shiny 0.10; simply
-#' ensure that the last expression to be returned from ui.R is a user interface.
-#' This function is kept for backwards compatibility with older applications. It
-#' returns the value that is passed to it.
-#'
-#' @param ui A user interace definition
-#' @return The user interface definition, without modifications or side effects.
-#' @keywords internal
 #' @export
-shinyUI <- function(ui) {
-  .globals$ui <- list(ui)
-  ui
-}
-
-uiHttpHandler <- function(ui, uiPattern = "^/$") {
-
+shinyUI <- function(ui, path='/') {
+  
   force(ui)
+  
+  registerClient({
+    
+    function(req) {
+      if (!identical(req$REQUEST_METHOD, 'GET'))
+        return(NULL)
 
-  allowed_methods <- "GET"
-  if (is.function(ui)) {
-    allowed_methods <- attr(ui, "http_methods_supported", exact = TRUE) %OR% allowed_methods
-  }
-
-  function(req) {
-    if (!isTRUE(req$REQUEST_METHOD %in% allowed_methods))
-      return(NULL)
-
-    if (!isTRUE(grepl(uiPattern, req$PATH_INFO)))
-      return(NULL)
-
-    showcaseMode <- .globals$showcaseDefault
-    if (.globals$showcaseOverride) {
-      mode <- showcaseModeOfReq(req)
-      if (!is.null(mode))
-        showcaseMode <- mode
-    }
-
-    testMode <- getShinyOption("testmode", default = FALSE)
-
-    # Create a restore context using query string
-    bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
-    if (bookmarkStore == "disable") {
-      # If bookmarking is disabled, use empty context
-      restoreContext <- RestoreContext$new()
-    } else {
-      restoreContext <- RestoreContext$new(req$QUERY_STRING)
-    }
-
-    withRestoreContext(restoreContext, {
-      uiValue <- NULL
-
-      if (is.function(ui)) {
-        if (length(formals(ui)) > 0) {
-          # No corresponding ..stacktraceoff.., this is pure user code
-          uiValue <- ..stacktraceon..(ui(req))
-        } else {
-          # No corresponding ..stacktraceoff.., this is pure user code
-          uiValue <- ..stacktraceon..(ui())
-        }
-      } else {
-        if (getCurrentRestoreContext()$active) {
-          warning("Trying to restore saved app state, but UI code must be a function for this to work! See ?enableBookmarking")
-        }
-        uiValue <- ui
-      }
-    })
-    if (is.null(uiValue))
-      return(NULL)
-
-    if (inherits(uiValue, "httpResponse")) {
-      return(uiValue)
-    } else {
-      html <- renderPage(uiValue, showcaseMode, testMode)
+      if (req$PATH_INFO != path)
+        return(NULL)
+      
+      textConn <- textConnection(NULL, "w") 
+      on.exit(close(textConn))
+      
+      renderPage(ui, textConn)
+      html <- paste(textConnectionValue(textConn), collapse='\n')
       return(httpResponse(200, content=html))
     }
-  }
+  })
 }
+

R/showcase.R

@@ -1,222 +0,0 @@
-#' @include globals.R
-NULL
-
-# Given the name of a license, return the appropriate link HTML for the
-# license, which may just be the name of the license if the name is
-# unrecognized.
-#
-# Recognizes the 'standard' set of licenses used for R packages
-# (see http://cran.r-project.org/doc/manuals/R-exts.html)
-licenseLink <- function(licenseName) {
-  licenses <- list(
-    "GPL-2" = "https://gnu.org/licenses/gpl-2.0.txt",
-    "GPL-3" = "https://gnu.org/licenses/gpl-3.0.txt",
-    "LGPL-3" = "https://www.gnu.org/licenses/lgpl-3.0.txt",
-    "LGPL-2" = "http://www.gnu.org/licenses/old-licenses/lgpl-2.0.txt",
-    "LGPL-2.1" = "http://www.gnu.org/licenses/lgpl-2.1.txt",
-    "AGPL-3" = "http://www.gnu.org/licenses/agpl-3.0.txt",
-    "Artistic-2.0" = "http://www.r-project.org/Licenses/Artistic-2.0",
-    "BSD_2_clause" = "http://www.r-project.org/Licenses/BSD_2_clause",
-    "BSD_3_clause" = "http://www.r-project.org/Licenses/BSD_3_clause",
-    "MIT" = "http://www.r-project.org/Licenses/MIT",
-    "CC-BY-SA-4.0" = "https://www.r-project.org/Licenses/CC-BY-SA-4.0")
-  if (exists(licenseName, where = licenses)) {
-    tags$a(href=licenses[[licenseName]], licenseName)
-  } else {
-    licenseName
-  }
-}
-
-# Returns tags containing showcase directives intended for the <HEAD> of the
-# document.
-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")
-  )
-
-  mdfile <- file.path.ci(getwd(), 'Readme.md')
-  html <- with(tags, tagList(
-    script(src="shared/shiny-showcase.js"),
-    link(rel="stylesheet", type="text/css",
-         href="shared/highlight/rstudio.css"),
-    link(rel="stylesheet", type="text/css",
-         href="shared/shiny-showcase.css"),
-    if (file.exists(mdfile))
-      script(type="text/markdown", id="showcase-markdown-content",
-        paste(readUTF8(mdfile), collapse="\n"))
-    else ""
-  ))
-
-  return(attachDependencies(html, deps))
-}
-
-# Returns tags containing the application metadata (title and author) in
-# showcase mode.
-appMetadata <- function(desc) {
-  cols <- colnames(desc)
-  if ("Title" %in% cols)
-    with(tags, h4(class="text-muted shiny-showcase-apptitle", desc[1,"Title"],
-      if ("Author" %in% cols) small(
-        br(), "by",
-        if ("AuthorUrl" %in% cols)
-          a(href=desc[1,"AuthorUrl"], class="shiny-showcase-appauthor",
-            desc[1,"Author"])
-        else
-          desc[1,"Author"],
-        if ("AuthorEmail" %in% cols)
-          a(href=paste("mailto:", desc[1,"AuthorEmail"], sep = ''),
-            class="shiny-showcase-appauthoreemail",
-            desc[1,"AuthorEmail"])
-        else "")
-      else ""))
-  else ""
-}
-
-navTabsHelper <- function(files, prefix = "") {
-  lapply(files, function(file) {
-    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)))
-    )
-  })
-}
-
-navTabsDropdown <- function(files) {
-  if (length(files) > 0) {
-    with(tags,
-      li(role="presentation", class="dropdown",
-        a(class="dropdown-toggle", `data-toggle`="dropdown", href="#",
-          role="button", `aria-haspopup`="true", `aria-expanded`="false",
-          "www", span(class="caret")
-        ),
-        ul(class="dropdown-menu", navTabsHelper(files))
-      )
-    )
-  }
-}
-
-tabContentHelper <- function(files, path, language) {
-  lapply(files, function(file) {
-      tags$div(class=paste("tab-pane",
-                      if (tolower(file) %in% c("app.r", "server.r")) " active"
-                      else "",
-                      sep=""),
-          id=paste(gsub(".", "_", file, fixed=TRUE),
-                   "_code", sep=""),
-          tags$pre(class="shiny-code",
-              # we need to prevent the indentation of <code> ... </code>
-              HTML(format(tags$code(
-                class=paste0("language-", language),
-                paste(readUTF8(file.path.ci(path, file)), collapse="\n")
-              ), indent = FALSE))))
-  })
-}
-
-# Returns tags containing the application's code in Bootstrap-style tabs in
-# showcase mode.
-showcaseCodeTabs <- function(codeLicense) {
-  rFiles <- list.files(pattern = "\\.[rR]$")
-  wwwFiles <- list()
-  if (isTRUE(.globals$IncludeWWW)) {
-    path <- file.path(getwd(), "www")
-    wwwFiles$jsFiles <- list.files(path, pattern = "\\.js$")
-    wwwFiles$cssFiles <- list.files(path, pattern = "\\.css$")
-    wwwFiles$htmlFiles <- list.files(path, pattern = "\\.html$")
-  }
-  with(tags, div(id="showcase-code-tabs",
-    a(id="showcase-code-position-toggle",
-      class="btn btn-default btn-sm",
-      onclick="toggleCodePosition()",
-      icon("level-up"),
-      "show with app"),
-    ul(class="nav nav-tabs",
-       navTabsHelper(rFiles),
-       navTabsDropdown(unlist(wwwFiles))
-    ),
-    div(class="tab-content", id="showcase-code-content",
-        tabContentHelper(rFiles, path = getwd(), language = "r"),
-        tabContentHelper(wwwFiles$jsFiles,
-                         path = paste0(getwd(), "/www"),
-                         language = "javascript"),
-        tabContentHelper(wwwFiles$cssFiles,
-                         path = paste0(getwd(), "/www"),
-                         language = "css"),
-        tabContentHelper(wwwFiles$htmlFiles,
-                         path = paste0(getwd(), "/www"),
-                         language = "xml")
-    ),
-    codeLicense))
-}
-
-# Returns tags containing the showcase application information (readme and
-# code).
-showcaseAppInfo <- function() {
-  descfile <- file.path.ci(getwd(), "DESCRIPTION")
-  hasDesc <- file.exists(descfile)
-  readmemd <- file.path.ci(getwd(), "Readme.md")
-  hasReadme <- file.exists(readmemd)
-  if (hasDesc) {
-    con <- textConnection(readUTF8(descfile))
-    on.exit(close(con), add = TRUE)
-    desc <- read.dcf(con)
-  }
-  with(tags,
-    div(class="container-fluid shiny-code-container well",
-        id="showcase-well",
-        div(class="row",
-          if (hasDesc || hasReadme) {
-            div(id="showcase-app-metadata", class="col-sm-4",
-                if (hasDesc) appMetadata(desc) else "",
-                if (hasReadme) div(id="readme-md"))
-          } else "",
-          div(id="showcase-code-inline",
-              class=if (hasReadme || hasDesc) "col-sm-8" else "col-sm-10 col-sm-offset-1",
-              showcaseCodeTabs(
-                if (hasDesc && "License" %in% colnames(desc)) {
-                  small(class="showcase-code-license text-muted",
-                        "Code license: ",
-                        licenseLink(desc[1,"License"]))
-                } else "")))))
-}
-
-
-# Returns the body of the showcase document, given the HTML it should wrap.
-showcaseBody <- function(htmlBody) {
-  with(tags, tagList(
-    table(id="showcase-app-code",
-          tr(td(id="showcase-app-container",
-                class="showcase-app-container-expanded",
-                htmlBody,
-             td(id="showcase-sxs-code",
-                class="showcase-sxs-code-collapsed")))),
-    showcaseAppInfo()))
-}
-
-# Sets the defaults for showcase mode (for app boot).
-setShowcaseDefault <- function(showcaseDefault) {
-  .globals$showcaseDefault <- showcaseDefault
-  .globals$showcaseOverride <- as.logical(showcaseDefault)
-}
-
-
-# Given a UI tag/tagList, wrap it in appropriate tags for showcase mode.
-showcaseUI <- function(ui) {
-  # If top-level tag is a body, replace its children with children wrapped in
-    # showcase stuff.
-  if (inherits(ui, "shiny.tag") && ui$name == "body") {
-    ui$children <- showcaseUI(ui$children)
-    return(ui)
-  }
-
-  tagList(
-    tags$head(showcaseHead()),
-    showcaseBody(ui)
-  )
-}

R/slider.R

@@ -0,0 +1,133 @@
+hasDecimals <- function(value) {
+  truncatedValue <- round(value)
+  return (!identical(value, truncatedValue))
+}
+
+#' Animation Options
+#' 
+#' Creates an options object for customizing animations for \link{sliderInput}.
+#' 
+#' @param interval The interval, in milliseconds, between each animation step.
+#' @param loop \code{TRUE} to automatically restart the animation when it 
+#'   reaches the end.
+#' @param playButton Specifies the appearance of the play button. Valid values 
+#'   are a one-element character vector (for a simple text label), an HTML tag 
+#'   or list of tags (using \code{\link{tag}} and friends), or raw HTML (using 
+#'   \code{\link{HTML}}).
+#' @param pauseButton Similar to \code{playButton}, but for the pause button.
+#'   
+#' @export
+animationOptions <- function(interval=1000,
+                             loop=FALSE,
+                             playButton=NULL,
+                             pauseButton=NULL) {
+  list(interval=interval,
+       loop=loop,
+       playButton=playButton,
+       pauseButton=pauseButton)
+}
+
+# Create a new slider control (list of slider input element and the script
+# tag used to configure it). This is a lower level control that should
+# be wrapped in an "input" construct (e.g. sliderInput in bootstrap.R)
+# 
+# this is a wrapper for: https://github.com/egorkhmelev/jslider
+# (www/shared/slider contains js, css, and img dependencies) 
+slider <- function(inputId, min, max, value, step = NULL, ...,
+                   round=FALSE, format='#,##0.#####', locale='us',
+                   ticks=TRUE, animate=FALSE) {
+  # validate inputId
+  inputId <- as.character(inputId)
+  if (!is.character(inputId))
+    stop("inputId not specified")
+    
+  # validate numeric inputs
+  if (!is.numeric(value) || !is.numeric(min) || !is.numeric(max)) 
+    stop("min, max, and value must all be numeric values")
+  else if (min(value) < min) 
+    stop(paste("slider initial value", value, 
+               "is less than the specified minimum"))
+  else if (max(value) > max) 
+    stop(paste("slider initial value", value, 
+               "is greater than the specified maximum"))
+  else if (min > max) 
+    stop(paste("slider maximum is greater than minimum"))
+  else if (!is.null(step)) {
+    if (!is.numeric(step)) 
+      stop("step is not a numeric value")
+    if (step > (max - min)) 
+      stop("step is greater than range")
+  }
+  
+  # step
+  range <- max - min
+  if (is.null(step)) {
+    # short range or decimals means continuous decimal
+    if (range < 2 || hasDecimals(min) || hasDecimals(max))
+      step <- range / 250 # ~ one step per pixel
+    else
+      step = 1
+  }
+  
+  # Default state is to not have ticks
+  if (identical(ticks, TRUE)) {
+    # Automatic ticks
+    tickCount <- (range / step) + 1
+    if (tickCount <= 26)
+      ticks <- paste(rep('|', floor(tickCount)), collapse=';')
+    else {
+      ticks <- NULL
+#       # This is a smarter auto-tick algorithm, but to be truly useful
+#       # we need jslider to be able to space ticks irregularly
+#       tickSize <- 10^(floor(log10(range/0.39)))
+#       if ((range / tickSize) == floor(range / tickSize)) {
+#         ticks <- paste(rep('|', (range / tickSize) + 1), collapse=';')
+#       }
+#       else {
+#         ticks <- NULL
+#       }
+    }
+  }
+  else if (is.numeric(ticks) && length(ticks) == 1) {
+    # Use n ticks
+    ticks <- paste(rep('|', ticks), collapse=';')
+  }
+  else if (length(ticks) > 1 && (is.numeric(ticks) || is.character(ticks))) {
+    # Explicit ticks
+    ticks <- paste(ticks, collapse=';')
+  }
+  else {
+    ticks <- NULL
+  }
+  
+  # build slider
+  sliderFragment <- list(tags$input(
+    id=inputId, type="slider", 
+    name=inputId, value=paste(value, collapse=';'), class="jslider",
+    'data-from'=min, 'data-to'=max, 'data-step'=step,
+    'data-skin'='plastic', 'data-round'=round, 'data-locale'=locale,
+    'data-format'=format, 'data-scale'=ticks,
+    'data-smooth'=FALSE))
+
+  if (identical(animate, TRUE))
+    animate <- animationOptions()
+  
+  if (!is.null(animate) && !identical(animate, FALSE)) {
+    if (is.null(animate$playButton))
+      animate$playButton <- 'Play'
+    if (is.null(animate$pauseButton))
+      animate$pauseButton <- 'Pause'
+    
+    sliderFragment[[length(sliderFragment)+1]] <-
+      tags$div(class='slider-animate-container',
+               tags$a(href='#',
+                      class='slider-animate-button',
+                      'data-target-id'=inputId,
+                      'data-interval'=animate$interval,
+                      'data-loop'=animate$loop,
+                      tags$span(class='play', animate$playButton),
+                      tags$span(class='pause', animate$pauseButton)))
+  }
+  
+  return(sliderFragment)
+}

R/snapshot.R

@@ -1,44 +0,0 @@
-#' Mark an output to be excluded from test snapshots
-#'
-#' @param x A reactive which will be assigned to an output.
-#'
-#' @export
-snapshotExclude <- function(x) {
-  markOutputAttrs(x, snapshotExclude = TRUE)
-}
-
-#' Add a function for preprocessing an output before taking a test snapshot
-#'
-#' @param x A reactive which will be assigned to an output.
-#' @param fun A function that takes the output value as an input and returns a
-#'   modified value. The returned value will be used for the test snapshot.
-#'
-#' @export
-snapshotPreprocessOutput <- function(x, fun) {
-  markOutputAttrs(x, snapshotPreprocess = fun)
-}
-
-
-#' Add a function for preprocessing an input before taking a test snapshot
-#'
-#' @param inputId Name of the input value.
-#' @param fun A function that takes the input value and returns a modified
-#'   value. The returned value will be used for the test snapshot.
-#' @param session A Shiny session object.
-#'
-#' @export
-snapshotPreprocessInput <- function(inputId, fun, session = getDefaultReactiveDomain()) {
-  if (is.null(session)) {
-    stop("snapshotPreprocessInput() needs a session object.")
-  }
-
-  input_impl <- .subset2(session$input, "impl")
-  input_impl$setMeta(inputId, "shiny.snapshot.preprocess", fun)
-}
-
-
-# Strip out file path from fileInput value
-snapshotPreprocessorFileInput <- function(value) {
-  value$datapath <- basename(value$datapath)
-  value
-}

R/stack.R

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

R/tags.R

@@ -0,0 +1,402 @@
+
+
+htmlEscape <- local({
+  .htmlSpecials <- list(
+    `&` = '&amp;',
+    `<` = '&lt;',
+    `>` = '&gt;'
+  )
+  .htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse='|')
+  .htmlSpecialsAttrib <- c(
+    .htmlSpecials,
+    `'` = '&#39;',
+    `"` = '&quot;',
+    `\r` = '&#13;',
+    `\n` = '&#10;'
+  )
+  .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|')
+  
+  function(text, attribute=TRUE) {
+    pattern <- if(attribute)
+      .htmlSpecialsPatternAttrib 
+    else
+      .htmlSpecialsPattern
+    
+    # Short circuit in the common case that there's nothing to escape
+    if (!grepl(pattern, text))
+      return(text)
+    
+    specials <- if(attribute)
+      .htmlSpecialsAttrib
+    else
+      .htmlSpecials
+    
+    for (chr in names(specials)) {
+      text <- gsub(chr, specials[[chr]], text, fixed=TRUE)
+    }
+    
+    return(text)
+  }
+})
+
+isTag <- function(x) {
+  inherits(x, "shiny.tag")
+}
+
+#' @S3method print shiny.tag
+print.shiny.tag <- function(x, ...) {
+  print(as.character(x), ...)
+}
+
+#' @S3method format shiny.tag
+format.shiny.tag <- function(x, ...) {
+  as.character.shiny.tag(x)
+}
+
+#' @S3method as.character shiny.tag
+as.character.shiny.tag <- function(x, ...) {
+  f = file()
+  on.exit(close(f))
+  textWriter <- function(text) {
+    cat(text, file=f)
+  }
+  tagWrite(x, textWriter)
+  return(HTML(paste(readLines(f, warn=FALSE), collapse='\n')))
+}
+
+#' @S3method print shiny.tag.list
+print.shiny.tag.list <- print.shiny.tag
+
+#' @S3method format shiny.tag.list
+format.shiny.tag.list <- format.shiny.tag
+
+#' @S3method as.character shiny.tag.list
+as.character.shiny.tag.list <- as.character.shiny.tag
+
+normalizeText <- function(text) {
+  if (!is.null(attr(text, "html")))
+    text
+  else
+    htmlEscape(text, attribute=FALSE)
+  
+}
+
+#' @export
+tagList <- function(...) {
+  lst <- list(...)
+  class(lst) <- c("shiny.tag.list", "list")
+  return(lst)
+}
+
+#' @export
+tagAppendChild <- function(tag, child) {
+  tag$children[[length(tag$children)+1]] <- child
+  tag
+}
+
+#' @export
+tagAppendChildren <- function(tag, ..., list = NULL) {
+  tag$children <- c(tag$children, c(list(...), list))
+  tag
+}
+
+#' @export
+tagSetChildren <- function(tag, ..., list = NULL) {
+  tag$children <- c(list(...), list)
+  tag
+}
+
+#' @export
+tag <- function(`_tag_name`, varArgs) {
+  # Get arg names; if not a named list, use vector of empty strings
+  varArgsNames <- names(varArgs)
+  if (is.null(varArgsNames))
+    varArgsNames <- character(length=length(varArgs))
+
+  # Named arguments become attribs, dropping NULL values
+  named_idx <- nzchar(varArgsNames)
+  attribs <- dropNulls(varArgs[named_idx])
+  
+  # Unnamed arguments are flattened and added as children.
+  # Use unname() to remove the names attribute from the list, which would
+  # consist of empty strings anyway.
+  children <- flattenTags(unname(varArgs[!named_idx]))
+
+  # Return tag data structure
+  structure(
+    list(name = `_tag_name`,
+         attribs = attribs,
+         children = children),
+    class = "shiny.tag"
+  )
+}
+
+tagWrite <- function(tag, textWriter, indent=0, context = NULL, eol = "\n") {
+  
+  # optionally process a list of tags
+  if (!isTag(tag) && is.list(tag)) {
+    sapply(tag, function(t) tagWrite(t, textWriter, indent, context))
+    return (NULL)
+  }
+  
+  # first call optional filter -- exit function if it returns false
+  if (!is.null(context) && !is.null(context$filter) && !context$filter(tag))
+    return (NULL)
+  
+  # compute indent text
+  indentText <- paste(rep(" ", indent*2), collapse="")
+  
+  # Check if it's just text (may either be plain-text or HTML)
+  if (is.character(tag)) {
+    textWriter(paste(indentText, normalizeText(tag), eol, sep=""))
+    return (NULL)
+  }
+  
+  # write tag name
+  textWriter(paste(indentText, "<", tag$name, sep=""))
+  
+  # write attributes
+  for (attrib in names(tag$attribs)) {
+    attribValue <- tag$attribs[[attrib]]
+    if (!is.na(attribValue)) {
+      if (is.logical(attribValue))
+        attribValue <- tolower(attribValue)
+      text <- htmlEscape(attribValue, attribute=TRUE) 
+      textWriter(paste(" ", attrib,"=\"", text, "\"", sep=""))
+    }
+    else {
+      textWriter(paste(" ", attrib, sep=""))
+    }
+  }
+  
+  # write any children
+  if (length(tag$children) > 0) {
+    textWriter(">")
+    
+    # special case for a single child text node (skip newlines and indentation)
+    if ((length(tag$children) == 1) && is.character(tag$children[[1]]) ) {
+      tagWrite(tag$children[[1]], textWriter, 0, context, "")
+      textWriter(paste("</", tag$name, ">", eol, sep=""))
+    }
+    else {
+      textWriter("\n")
+      for (child in tag$children)
+        tagWrite(child, textWriter, indent+1, context)
+      textWriter(paste(indentText, "</", tag$name, ">", eol, sep=""))
+    }
+  }
+  else {
+    # only self-close void elements 
+    # (see: http://dev.w3.org/html5/spec/single-page.html#void-elements)
+    if (tag$name %in% c("area", "base", "br", "col", "command", "embed", "hr", 
+                        "img", "input", "keygen", "link", "meta", "param",
+                        "source", "track", "wbr")) {
+      textWriter(paste("/>", eol, sep=""))
+    }
+    else {
+      textWriter(paste("></", tag$name, ">", eol, sep=""))
+    }
+  }
+}
+
+
+# environment used to store all available tags
+#' @export
+tags <- list(
+  a = function(...) tag("a", list(...)),
+  abbr = function(...) tag("abbr", list(...)),
+  address = function(...) tag("address", list(...)),
+  area = function(...) tag("area", list(...)),
+  article = function(...) tag("article", list(...)),
+  aside = function(...) tag("aside", list(...)),
+  audio = function(...) tag("audio", list(...)),
+  b = function(...) tag("b", list(...)),
+  base = function(...) tag("base", list(...)),
+  bdi = function(...) tag("bdi", list(...)),
+  bdo = function(...) tag("bdo", list(...)),
+  blockquote = function(...) tag("blockquote", list(...)),
+  body = function(...) tag("body", list(...)),
+  br = function(...) tag("br", list(...)),
+  button = function(...) tag("button", list(...)),
+  canvas = function(...) tag("canvas", list(...)),
+  caption = function(...) tag("caption", list(...)),
+  cite = function(...) tag("cite", list(...)),
+  code = function(...) tag("code", list(...)),
+  col = function(...) tag("col", list(...)),
+  colgroup = function(...) tag("colgroup", list(...)),
+  command = function(...) tag("command", list(...)),
+  data = function(...) tag("data", list(...)),
+  datalist = function(...) tag("datalist", list(...)),
+  dd = function(...) tag("dd", list(...)),
+  del = function(...) tag("del", list(...)),
+  details = function(...) tag("details", list(...)),
+  dfn = function(...) tag("dfn", list(...)),
+  div = function(...) tag("div", list(...)),
+  dl = function(...) tag("dl", list(...)),
+  dt = function(...) tag("dt", list(...)),
+  em = function(...) tag("em", list(...)),
+  embed = function(...) tag("embed", list(...)),
+  eventsource = function(...) tag("eventsource", list(...)),
+  fieldset = function(...) tag("fieldset", list(...)),
+  figcaption = function(...) tag("figcaption", list(...)),
+  figure = function(...) tag("figure", list(...)),
+  footer = function(...) tag("footer", list(...)),
+  form = function(...) tag("form", list(...)),
+  h1 = function(...) tag("h1", list(...)),
+  h2 = function(...) tag("h2", list(...)),
+  h3 = function(...) tag("h3", list(...)),
+  h4 = function(...) tag("h4", list(...)),
+  h5 = function(...) tag("h5", list(...)),
+  h6 = function(...) tag("h6", list(...)),
+  head = function(...) tag("head", list(...)),
+  header = function(...) tag("header", list(...)),
+  hgroup = function(...) tag("hgroup", list(...)),
+  hr = function(...) tag("hr", list(...)),
+  html = function(...) tag("html", list(...)),
+  i = function(...) tag("i", list(...)),
+  iframe = function(...) tag("iframe", list(...)),
+  img = function(...) tag("img", list(...)),
+  input = function(...) tag("input", list(...)),
+  ins = function(...) tag("ins", list(...)),
+  kbd = function(...) tag("kbd", list(...)),
+  keygen = function(...) tag("keygen", list(...)),
+  label = function(...) tag("label", list(...)),
+  legend = function(...) tag("legend", list(...)),
+  li = function(...) tag("li", list(...)),
+  link = function(...) tag("link", list(...)),
+  mark = function(...) tag("mark", list(...)),
+  map = function(...) tag("map", list(...)),
+  menu = function(...) tag("menu", list(...)),
+  meta = function(...) tag("meta", list(...)),
+  meter = function(...) tag("meter", list(...)),
+  nav = function(...) tag("nav", list(...)),
+  noscript = function(...) tag("noscript", list(...)),
+  object = function(...) tag("object", list(...)),
+  ol = function(...) tag("ol", list(...)),
+  optgroup = function(...) tag("optgroup", list(...)),
+  option = function(...) tag("option", list(...)),
+  output = function(...) tag("output", list(...)),
+  p = function(...) tag("p", list(...)),
+  param = function(...) tag("param", list(...)),
+  pre = function(...) tag("pre", list(...)),
+  progress = function(...) tag("progress", list(...)),
+  q = function(...) tag("q", list(...)),
+  ruby = function(...) tag("ruby", list(...)),
+  rp = function(...) tag("rp", list(...)),
+  rt = function(...) tag("rt", list(...)),
+  s = function(...) tag("s", list(...)),
+  samp = function(...) tag("samp", list(...)),
+  script = function(...) tag("script", list(...)),
+  section = function(...) tag("section", list(...)),
+  select = function(...) tag("select", list(...)),
+  small = function(...) tag("small", list(...)),
+  source = function(...) tag("source", list(...)),
+  span = function(...) tag("span", list(...)),
+  strong = function(...) tag("strong", list(...)),
+  style = function(...) tag("style", list(...)),
+  sub = function(...) tag("sub", list(...)),
+  summary = function(...) tag("summary", list(...)),
+  sup = function(...) tag("sup", list(...)),
+  table = function(...) tag("table", list(...)),
+  tbody = function(...) tag("tbody", list(...)),
+  td = function(...) tag("td", list(...)),
+  textarea = function(...) tag("textarea", list(...)),
+  tfoot = function(...) tag("tfoot", list(...)),
+  th = function(...) tag("th", list(...)),
+  thead = function(...) tag("thead", list(...)),
+  time = function(...) tag("time", list(...)),
+  title = function(...) tag("title", list(...)),
+  tr = function(...) tag("tr", list(...)),
+  track = function(...) tag("track", list(...)),
+  u = function(...) tag("u", list(...)),
+  ul = function(...) tag("ul", list(...)),
+  var = function(...) tag("var", list(...)),
+  video = function(...) tag("video", list(...)),
+  wbr = function(...) tag("wbr", list(...))
+)
+
+#' Mark Characters as HTML
+#' 
+#' Marks the given text as HTML, which means the \link{tag} functions will know
+#' not to perform HTML escaping on it.
+#' 
+#' @param text The text value to mark with HTML
+#' @param ... Any additional values to be converted to character and
+#'   concatenated together
+#' @return The same value, but marked as HTML.
+#' 
+#' @examples
+#' el <- div(HTML("I like <u>turtles</u>"))
+#' cat(as.character(el))
+#'   
+#' @export
+HTML <- function(text, ...) {
+  htmlText <- c(text, as.character(list(...)))
+  htmlText <- paste(htmlText, collapse=" ")
+  attr(htmlText, "html") <- TRUE
+  htmlText
+}
+
+#' Evaluate an expression using the \code{tags}
+#'
+#' This function makes it simpler to write HTML-generating code. Instead of
+#' needing to specify \code{tags} each time a tag function is used, as in
+#' \code{tags$div()} and \code{tags$p()}, code inside \code{withTags} is
+#' evaluated with \code{tags} searched first, so you can simply use
+#' \code{div()} and \code{p()}.
+#'
+#' If your code uses an object which happens to have the same name as an
+#' HTML tag function, such as \code{source()} or \code{summary()}, it will call
+#' the tag function. To call the intended (non-tags function), specify the
+#' namespace, as in \code{base::source()} or \code{base::summary()}.
+#'
+#' @param code A set of tags.
+#'
+#' @examples
+#' # Using tags$ each time
+#' tags$div(class = "myclass",
+#'   tags$h3("header"),
+#'   tags$p("text")
+#' )
+#'
+#' # Equivalent to above, but using withTags
+#' withTags(
+#'   div(class = "myclass",
+#'     h3("header"),
+#'     p("text")
+#'   )
+#' )
+#'
+#'
+#' @export
+withTags <- function(code) {
+  eval(substitute(code), envir = as.list(tags), enclos = parent.frame())
+}
+
+
+# Given a list of tags, lists, and other items, return a flat list, where the
+# items from the inner, nested lists are pulled to the top level, recursively.
+flattenTags <- function(x) {
+  if (isTag(x)) {
+    # For tags, wrap them into a list (which will be unwrapped by caller)
+    list(x)
+  } else if (is.list(x)) {
+    if (length(x) == 0) {
+      # Empty lists are simply returned
+      x
+    } else {
+      # For items that are lists (but not tags), recurse
+      unlist(lapply(x, flattenTags), recursive = FALSE)
+    }
+
+  } else if (is.character(x)){
+    # This will preserve attributes if x is a character with attribute,
+    # like what HTML() produces
+    list(x)
+
+  } else {
+    # For other items, coerce to character and wrap them into a list (which
+    # will be unwrapped by caller). Note that this will strip attributes.
+    list(as.character(x))
+  }
+}

R/tar.R

@@ -46,7 +46,7 @@ untar2 <- function(tarfile, files = NULL, list = FALSE, exdir = ".")
     mydir.create <- function(path, ...) {
         ## for Windows' sake
         path <- sub("[\\/]$", "", path)
-        if(utils::file_test("-d", path)) return()
+        if(file_test("-d", path)) return()
         if(!dir.create(path, showWarnings = TRUE, recursive = TRUE, ...))
            stop(gettextf("failed to create directory %s", sQuote(path)),
                 domain = NA)
@@ -141,7 +141,7 @@ untar2 <- function(tarfile, files = NULL, list = FALSE, exdir = ".")
                             warning(gettextf("failed to copy %s to %s", sQuote(name2), sQuote(name)), domain = NA)
                     }
                 } else {
-                    if(isWindows()) {
+                    if(.Platform$OS.type == "windows") {
                         ## this will not work for links to dirs
                         from <- file.path(dirname(name), name2)
                         if (!file.copy(from, name))

R/test-export.R

@@ -1,61 +0,0 @@
-#' Register expressions for export in test mode
-#'
-#' This function registers expressions that will be evaluated when a test export
-#' event occurs. These events are triggered by accessing a snapshot URL.
-#'
-#' This function only has an effect if the app is launched in test mode. This is
-#' done by calling `runApp()` with `test.mode=TRUE`, or by setting the
-#' global option `shiny.testmode` to `TRUE`.
-#'
-#' @param quoted_ Are the expression quoted? Default is `FALSE`.
-#' @param env_ The environment in which the expression should be evaluated.
-#' @param session_ A Shiny session object.
-#' @param ... Named arguments that are quoted or unquoted expressions that will
-#'   be captured and evaluated when snapshot URL is visited.
-#' @examples
-#' ## Only run this example in interactive R sessions
-#' if (interactive()) {
-#'
-#' options(shiny.testmode = TRUE)
-#'
-#' # This application shows the test snapshot URL; clicking on it will
-#' # fetch the input, output, and exported values in JSON format.
-#' shinyApp(
-#'   ui = basicPage(
-#'     h4("Snapshot URL: "),
-#'     uiOutput("url"),
-#'     h4("Current values:"),
-#'     verbatimTextOutput("values"),
-#'     actionButton("inc", "Increment x")
-#'   ),
-#'
-#'   server = function(input, output, session) {
-#'     vals <- reactiveValues(x = 1)
-#'     y <- reactive({ vals$x + 1 })
-#'
-#'     observeEvent(input$inc, {
-#'       vals$x <<- vals$x + 1
-#'     })
-#'
-#'     exportTestValues(
-#'       x = vals$x,
-#'       y = y()
-#'     )
-#'
-#'     output$url <- renderUI({
-#'       url <- session$getTestSnapshotUrl(format="json")
-#'       a(href = url, url)
-#'     })
-#'
-#'     output$values <- renderText({
-#'       paste0("vals$x: ", vals$x, "\ny: ", y())
-#'     })
-#'   }
-#' )
-#' }
-#' @export
-exportTestValues <- function(..., quoted_ = FALSE, env_ = parent.frame(),
-  session_ = getDefaultReactiveDomain())
-{
-  session_$exportTestValues(..., quoted_ = quoted_, env_ = env_)
-}

R/test-server.R

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

R/test.R

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

R/timer.R

@@ -1,21 +1,19 @@
-# Return the current time, in milliseconds from epoch.
-getTimeMs <- function() {
+# Return the current time, in milliseconds from epoch, with
+# unspecified time zone.
+now <- function() {
   as.numeric(Sys.time()) * 1000
 }
 
-TimerCallbacks <- R6Class(
+TimerCallbacks <- setRefClass(
   'TimerCallbacks',
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    .nextId = 0L,
+  fields = list(
+    .nextId = 'integer',
     .funcs = 'Map',
-    .times = data.frame(),
-    .now = 'Function',
-
-    initialize = function(nowFn = getTimeMs) {
-      .funcs <<- Map$new()
-      .now <<- nowFn
+    .times = 'data.frame'
+  ),
+  methods = list(
+    initialize = function() {
+      .nextId <<- 0L
     },
     clear = function() {
       .nextId <<- 0L
@@ -23,59 +21,43 @@ TimerCallbacks <- R6Class(
       .times <<- data.frame()
     },
     schedule = function(millis, func) {
-      # If args could fail to evaluate, let's make them do that before
-      # we change any state
-      force(millis)
-      force(func)
-
       id <- .nextId
       .nextId <<- .nextId + 1L
-
-      t <- .now()
-
+      
+      t <- now()
+      
       # TODO: Horribly inefficient, use a heap instead
       .times <<- rbind(.times, data.frame(time=t+millis,
                                           scheduled=t,
                                           id=id))
       .times <<- .times[order(.times$time),]
-
+      
       .funcs$set(as.character(id), func)
-
+      
       return(id)
     },
-    unschedule = function(id) {
-      toRemoveIndices <- .times$id %in% id
-      toRemoveIds <- .times[toRemoveIndices, "id", drop = TRUE]
-      if (length(toRemoveIds) > 0) {
-        .times <<- .times[!toRemoveIndices,]
-        for (toRemoveId in as.character(toRemoveIds)) {
-          .funcs$remove(toRemoveId)
-        }
-      }
-      return(id %in% toRemoveIds)
-    },
     timeToNextEvent = function() {
       if (dim(.times)[1] == 0)
         return(Inf)
-      return(.times[1, 'time'] - .now())
+      return(.times[1, 'time'] - now())
     },
     takeElapsed = function() {
-      t <- .now()
-      elapsed <- .times$time <= .now()
+      t <- now()
+      elapsed <- .times$time < now()
       result <- .times[elapsed,]
       .times <<- .times[!elapsed,]
-
+      
       # TODO: Examine scheduled column to check if any funny business
       #       has occurred with the system clock (e.g. if scheduled
-      #       is later than .now())
-
+      #       is later than now())
+      
       return(result)
     },
     executeElapsed = function() {
       elapsed <- takeElapsed()
-      if (nrow(elapsed) == 0)
+      if (length(elapsed) == 0)
         return(FALSE)
-
+      
       for (id in elapsed$id) {
         thisFunc <- .funcs$remove(as.character(id))
         # TODO: Catch exception, and...?
@@ -87,61 +69,4 @@ TimerCallbacks <- R6Class(
   )
 )
 
-MockableTimerCallbacks <- R6Class(
-  'MockableTimerCallbacks',
-  inherit = TimerCallbacks,
-  portable = FALSE,
-  class = FALSE,
-  public = list(
-    # Empty constructor defaults to the getNow implementation
-    initialize = function() {
-      super$initialize(self$mockNow)
-    },
-    mockNow = function() {
-      return(private$time)
-    },
-    elapse = function(millis) {
-      private$time <- private$time + millis
-    },
-    getElapsed = function() {
-      private$time
-    }
-  ), private = list(
-    time = 0L
-  )
-)
-
 timerCallbacks <- TimerCallbacks$new()
-
-scheduleTask <- function(millis, callback) {
-  cancelled <- FALSE
-  id <- timerCallbacks$schedule(millis, callback)
-
-  function() {
-    invisible(timerCallbacks$unschedule(id))
-  }
-}
-
-#' Get a scheduler function for scheduling tasks. Give priority to the
-#' session scheduler, but if it doesn't exist, use the global one.
-#' @noRd
-defineScheduler <- function(session){
-  if (!is.null(session) && !is.null(session$.scheduleTask)){
-    return(session$.scheduleTask)
-  }
-  scheduleTask
-}
-
-
-#' Get the current time using the current reactive domain. This will try to use
-#' the session's .now() method, but if that's not available, it will just return
-#' the real time (from getTimeMs()). The purpose of this function is to allow
-#' MockableTimerCallbacks to work.
-#' @noRd
-getDomainTimeMs <- function(session){
-  if (!is.null(session) && !is.null(session$.now)){
-    return(session$.now())
-  } else {
-    getTimeMs()
-  }
-}

R/viewer.R

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

README.md

@@ -1,71 +1,39 @@
-# shiny <img src="man/figures/logo.png" align="right" width=120 height=139 alt="" />
-
-<!-- badges: start -->
-[![CRAN](https://www.r-pkg.org/badges/version/shiny)](https://CRAN.R-project.org/package=shiny)
-[![R build status](https://github.com/rstudio/shiny/workflows/R-CMD-check/badge.svg)](https://github.com/rstudio/shiny/actions)
-[![RStudio community](https://img.shields.io/badge/community-shiny-blue?style=social&logo=rstudio&logoColor=75AADB)](https://community.rstudio.com/new-topic?category=shiny&tags=shiny)
-
-<!-- badges: end -->
+# Shiny 
 
 Shiny is a new package from RStudio that makes it incredibly easy to build interactive web applications with R.
 
-For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstudio.com/).
-
-If you have general questions about using Shiny, please use the [RStudio Community website](https://community.rstudio.com). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
+For an introduction and examples, visit the [Shiny homepage](http://www.rstudio.com/shiny/).
 
 ## Features
 
 * Build useful web applications with only a few lines of code&mdash;no JavaScript required.
 * Shiny applications are automatically "live" in the same way that spreadsheets are live. Outputs change instantly as users modify inputs, without requiring a reload of the browser.
 * Shiny user interfaces can be built entirely using R, or can be written directly in HTML, CSS, and JavaScript for more flexibility.
-* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.).
-* Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/).
+* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.)
+* Attractive default UI theme based on [Twitter Bootstrap](http://twitter.github.com/bootstrap).
 * A highly customizable slider widget with built-in support for animation.
-* Prebuilt output widgets for displaying plots, tables, and printed output of R objects.
-* Fast bidirectional communication between the web browser and R using the [httpuv](https://github.com/rstudio/httpuv) package.
+* Pre-built output widgets for displaying plots, tables, and printed output of R objects.
+* Fast bidirectional communication between the web browser and R using the [websockets](http://illposed.net/websockets.html) package.
 * Uses a [reactive](http://en.wikipedia.org/wiki/Reactive_programming) programming model that eliminates messy event handling code, so you can focus on the code that really matters.
 * Develop and redistribute your own Shiny widgets that other developers can easily drop into their own applications (coming soon!).
 
 ## Installation
 
-To install the stable version from CRAN, simply run the following from an R console:
+From an R console:
 
 ```r
 install.packages("shiny")
 ```
 
-To install the latest development builds directly from GitHub, run this instead:
-
-```r
-if (!require("remotes"))
-  install.packages("remotes")
-remotes::install_github("rstudio/shiny")
-```
-
 ## Getting Started
 
-To learn more we highly recommend you check out the [Shiny Tutorial](http://shiny.rstudio.com/tutorial/). The tutorial explains the framework in-depth, walks you through building a simple application, and includes extensive annotated examples.
+To learn more we highly recommend you check out the [Shiny Tutorial](http://rstudio.github.com/shiny/tutorial). The tutorial explains the framework in-depth, walks you through building a simple application, and includes extensive annotated examples.
 
-## Bootstrap 3 migration
-
-Shiny versions 0.10.2.2 and below used the Bootstrap 2 web framework. After 0.10.2.2, Shiny switched to Bootstrap 3. For most users, the upgrade should be seamless. However, if you have have customized your HTML-generating code to use features specific to Bootstrap 2, you may need to update your code to work with Bootstrap 3.
-
-If you do not wish to update your code at this time, you can use the [shinybootstrap2](https://github.com/rstudio/shinybootstrap2) package for backward compatibility.
-
-If you prefer to install an older version of Shiny, you can do it using the devtools package:
-
-```R
-devtools::install_version("shiny", version = "0.10.2.2")
-```
-
-## Development notes
-
-The Javascript code in Shiny is minified using tools that run on Node.js. See the tools/ directory for more information.
-
-## Guidelines for 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 hope you enjoy using Shiny. As you learn more and work with the package please [let us know](https://github.com/rstudio/shiny/issues) what problems you encounter and how you'd like to see Shiny evolve.
 
 ## License
 
-The shiny package as a whole is licensed under the GPLv3. See the [LICENSE](LICENSE) file for more details.
+The shiny package is licensed under the GPLv3. See these files in the inst directory for additional details:
+
+- COPYING - shiny package license (GPLv3)
+- NOTICE  - Copyright notices for additional included software

TODO-promises.md

@@ -1,54 +0,0 @@
-# Promises TODO
-
-## Documentation
-
-- [x] Motivation -- why should I care about async? Why shouldn't I (what are the limitations)?
-- [x] High level technical overview
-- [ ] Cookbook-style examples
-- [ ] Top-down porting of a sync app to async
-
-## Core API
-- [x] Should as.promise() convert regular values to promises? Or throw?
-  - [x] If as.promise() doesn't convert regular values to promises, add promise_resolved(value) and promise_rejected(err) functions?
-
-## later
-- [ ] Add support for multiple event loops
-- [x] Add timeout to run_now
-
-## Error handling/debugging
-- [ ] ..stacktraceon../..stacktraceoff.. and stack traces in general
-- [x] long stack traces
-  - [x] require opt-in
-- [ ] options(shiny.error) should work in promise handlers
-- [x] Detect when reactives are used across process boundaries, and error
-
-## Render functions
-- [x] Non-async render functions should have their code all execute on the current tick. Otherwise order of execution will be surprising if they have side effects and explicit priorities.
-- [x] Promise domains should maybe have an onExecute, for the "sync" part that kicks off async operations to also have wrapping behavior (like capturing output). Right now, I have to start off renderPrint with promise(~resolve(TRUE)) and then execute the user code in a then(), just to get the promise behavior. Same will be true when we tackle error handling (stack trace capture).
-- [x] invisible() doesn't seem to be working correctly with renderPrint. .visible doesn't survive promise chaining, e.g. promise(~resolve(promise(~resolve(invisible("Hi"))))) %>% then(function(x, .visible) { cat(.visible) }) will print TRUE, not FALSE.
-- [x] renderDataTable should support async
-- [x] Support downloadHandler
-  - [ ] Support async filename?
-  - [x] Should prevent session from continuing until download completes (ref count)
-
-## Flush lifecycle
-- [x] While async operations are running in a session, hold off on any further processing of inputs and scheduled task items until all operations are complete.
-- [x] Hold all outputs/errors until async operations are complete.
-- [ ] Allow both sync and async outputs to be displayed before all outputs are done. (opt-in)
-
-## Testing
-- [x] App that tests that all built-in render functions support async
-- [x] Apps that test flush lifecycle, including onFlushed(once = FALSE)
-- [x] Apps that test invisible() behavior for renderPrint, both sync and async
-- [x] Apps that ensure all render functions execute synchronous code before tick is over
-- [x] App that tests async downloadHandler
-- [x] App that verifies inputs/timers don't fire for a session while it has async operations pending
-- [x] App that verifies req(FALSE), req(FALSE, cancelOutput = TRUE), validate/need, etc. all work in async
-
-## External packages
-- [x] DT
-- [x] htmlwidgets: Don't require async-aware version of Shiny if not using async
-- [x] Plotly
-
-## Bugs
-- [x] req(FALSE, cancelOutput = TRUE) shows grey (even without async)