Manually bump the version numbers in shiny.js and shiny.min.js

Normally this would be where we grunt, but for this hotfix we
need to avoid the changes that went in at the end of 1.3.0 that
were accidentally left out of the built JS.

.Rbuildignore

@@ -18,3 +18,5 @@
 ^.*\.o$
 ^appveyor\.yml$
 ^revdep$
+^TODO-promises.md$
+^manualtests$

.gitignore

@@ -9,3 +9,4 @@
 shinyapps/
 README.html
 .*.Rnb.cached
+tools/yarn-error.log

CONTRIBUTING.md

@@ -2,7 +2,7 @@ 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. If the change is non-trivial, ensure that you have signed the [individual](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioIndividualContributorAgreement.pdf) or [corporate](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioCorporateContributorAgreement.pdf) contributor agreement as appropriate. You can send the signed copy to jj@rstudio.com. For trivial changes (like typo fixes), a contributor agreement is not needed.
+2. Ensure that you have signed the [individual](https://rstudioblog.files.wordpress.com/2017/05/rstudio_individual_contributor_agreement.pdf) or [corporate](https://rstudioblog.files.wordpress.com/2017/05/rstudio_corporate_contributor_agreement.pdf) contributor agreement as appropriate. You can send the signed copy to jj@rstudio.com.
 
 3. Submit a [pull request](https://help.github.com/articles/using-pull-requests).
 

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.0.2
+Version: 1.3.1
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -56,22 +56,28 @@ Authors@R: c(
     )
 Description: Makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
-    outputs and extensive pre-built widgets make it possible to build
+    outputs and extensive prebuilt widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
 License: GPL-3 | file LICENSE
 Depends:
-    R (>= 3.0.0),
+    R (>= 3.0.2),
     methods
 Imports:
     utils,
-    httpuv (>= 1.3.3),
+    grDevices,
+    httpuv (>= 1.5.0),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.3.5),
+    htmltools (>= 0.3.6),
     R6 (>= 2.0),
-    sourcetools
+    sourcetools,
+    later (>= 0.7.2),
+    promises (>= 1.0.1),
+    tools,
+    crayon,
+    rlang
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -80,6 +86,7 @@ Suggests:
     markdown,
     rmarkdown,
     ggplot2,
+    reactlog (>= 1.0.0),
     magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
@@ -89,14 +96,18 @@ Collate:
     'stack.R'
     'bookmark-state.R'
     'bootstrap-layout.R'
+    'globals.R'
     'conditions.R'
     'map.R'
-    'globals.R'
     'utils.R'
     'bootstrap.R'
-    'cache.R'
+    'cache-context.R'
+    'cache-disk.R'
+    'cache-memory.R'
+    'cache-utils.R'
     'diagnose.R'
     'fileupload.R'
+    'font-awesome.R'
     'graph.R'
     'reactives.R'
     'reactive-domains.R'
@@ -122,6 +133,7 @@ Collate:
     'input-text.R'
     'input-textarea.R'
     'input-utils.R'
+    'insert-tab.R'
     'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
@@ -132,6 +144,7 @@ Collate:
     'priorityqueue.R'
     'progress.R'
     'react.R'
+    'render-cached-plot.R'
     'render-plot.R'
     'render-table.R'
     'run-url.R'
@@ -143,8 +156,10 @@ Collate:
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
+    'snapshot.R'
     'tar.R'
     'test-export.R'
     'timer.R'
     'update-input.R'
-RoxygenNote: 6.0.1
+RoxygenNote: 6.1.1
+Encoding: UTF-8

LICENSE

@@ -673,7 +673,7 @@ bootstrap-datepicker
    limitations under the License.
 
 
-Font-Awesome (CSS file is MIT licensed; font has SIL Open Font License 1.1)
+Font Awesome (CSS files are MIT licensed; fonts have SIL Open Font License 1.1, svgs have CC BY 4.0 License)
 ----------------------------------------------------------------------
 
 The MIT License (MIT)
@@ -795,6 +795,326 @@ DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
 FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
 OTHER DEALINGS IN THE FONT SOFTWARE.
 
+=======================================================================
+
+Creative Commons Attribution 4.0 International Public License
+
+By exercising the Licensed Rights (defined below), You accept and agree
+to be bound by the terms and conditions of this Creative Commons
+Attribution 4.0 International Public License ("Public License"). To the
+extent this Public License may be interpreted as a contract, You are
+granted the Licensed Rights in consideration of Your acceptance of
+these terms and conditions, and the Licensor grants You such rights in
+consideration of benefits the Licensor receives from making the
+Licensed Material available under these terms and conditions.
+
+
+Section 1 -- Definitions.
+
+  a. Adapted Material means material subject to Copyright and Similar
+     Rights that is derived from or based upon the Licensed Material
+     and in which the Licensed Material is translated, altered,
+     arranged, transformed, or otherwise modified in a manner requiring
+     permission under the Copyright and Similar Rights held by the
+     Licensor. For purposes of this Public License, where the Licensed
+     Material is a musical work, performance, or sound recording,
+     Adapted Material is always produced where the Licensed Material is
+     synched in timed relation with a moving image.
+
+  b. Adapter's License means the license You apply to Your Copyright
+     and Similar Rights in Your contributions to Adapted Material in
+     accordance with the terms and conditions of this Public License.
+
+  c. Copyright and Similar Rights means copyright and/or similar rights
+     closely related to copyright including, without limitation,
+     performance, broadcast, sound recording, and Sui Generis Database
+     Rights, without regard to how the rights are labeled or
+     categorized. For purposes of this Public License, the rights
+     specified in Section 2(b)(1)-(2) are not Copyright and Similar
+     Rights.
+
+  d. Effective Technological Measures means those measures that, in the
+     absence of proper authority, may not be circumvented under laws
+     fulfilling obligations under Article 11 of the WIPO Copyright
+     Treaty adopted on December 20, 1996, and/or similar international
+     agreements.
+
+  e. Exceptions and Limitations means fair use, fair dealing, and/or
+     any other exception or limitation to Copyright and Similar Rights
+     that applies to Your use of the Licensed Material.
+
+  f. Licensed Material means the artistic or literary work, database,
+     or other material to which the Licensor applied this Public
+     License.
+
+  g. Licensed Rights means the rights granted to You subject to the
+     terms and conditions of this Public License, which are limited to
+     all Copyright and Similar Rights that apply to Your use of the
+     Licensed Material and that the Licensor has authority to license.
+
+  h. Licensor means the individual(s) or entity(ies) granting rights
+     under this Public License.
+
+  i. Share means to provide material to the public by any means or
+     process that requires permission under the Licensed Rights, such
+     as reproduction, public display, public performance, distribution,
+     dissemination, communication, or importation, and to make material
+     available to the public including in ways that members of the
+     public may access the material from a place and at a time
+     individually chosen by them.
+
+  j. Sui Generis Database Rights means rights other than copyright
+     resulting from Directive 96/9/EC of the European Parliament and of
+     the Council of 11 March 1996 on the legal protection of databases,
+     as amended and/or succeeded, as well as other essentially
+     equivalent rights anywhere in the world.
+
+  k. You means the individual or entity exercising the Licensed Rights
+     under this Public License. Your has a corresponding meaning.
+
+
+Section 2 -- Scope.
+
+  a. License grant.
+
+       1. Subject to the terms and conditions of this Public License,
+          the Licensor hereby grants You a worldwide, royalty-free,
+          non-sublicensable, non-exclusive, irrevocable license to
+          exercise the Licensed Rights in the Licensed Material to:
+
+            a. reproduce and Share the Licensed Material, in whole or
+               in part; and
+
+            b. produce, reproduce, and Share Adapted Material.
+
+       2. Exceptions and Limitations. For the avoidance of doubt, where
+          Exceptions and Limitations apply to Your use, this Public
+          License does not apply, and You do not need to comply with
+          its terms and conditions.
+
+       3. Term. The term of this Public License is specified in Section
+          6(a).
+
+       4. Media and formats; technical modifications allowed. The
+          Licensor authorizes You to exercise the Licensed Rights in
+          all media and formats whether now known or hereafter created,
+          and to make technical modifications necessary to do so. The
+          Licensor waives and/or agrees not to assert any right or
+          authority to forbid You from making technical modifications
+          necessary to exercise the Licensed Rights, including
+          technical modifications necessary to circumvent Effective
+          Technological Measures. For purposes of this Public License,
+          simply making modifications authorized by this Section 2(a)
+          (4) never produces Adapted Material.
+
+       5. Downstream recipients.
+
+            a. Offer from the Licensor -- Licensed Material. Every
+               recipient of the Licensed Material automatically
+               receives an offer from the Licensor to exercise the
+               Licensed Rights under the terms and conditions of this
+               Public License.
+
+            b. No downstream restrictions. You may not offer or impose
+               any additional or different terms or conditions on, or
+               apply any Effective Technological Measures to, the
+               Licensed Material if doing so restricts exercise of the
+               Licensed Rights by any recipient of the Licensed
+               Material.
+
+       6. No endorsement. Nothing in this Public License constitutes or
+          may be construed as permission to assert or imply that You
+          are, or that Your use of the Licensed Material is, connected
+          with, or sponsored, endorsed, or granted official status by,
+          the Licensor or others designated to receive attribution as
+          provided in Section 3(a)(1)(A)(i).
+
+  b. Other rights.
+
+       1. Moral rights, such as the right of integrity, are not
+          licensed under this Public License, nor are publicity,
+          privacy, and/or other similar personality rights; however, to
+          the extent possible, the Licensor waives and/or agrees not to
+          assert any such rights held by the Licensor to the limited
+          extent necessary to allow You to exercise the Licensed
+          Rights, but not otherwise.
+
+       2. Patent and trademark rights are not licensed under this
+          Public License.
+
+       3. To the extent possible, the Licensor waives any right to
+          collect royalties from You for the exercise of the Licensed
+          Rights, whether directly or through a collecting society
+          under any voluntary or waivable statutory or compulsory
+          licensing scheme. In all other cases the Licensor expressly
+          reserves any right to collect such royalties.
+
+
+Section 3 -- License Conditions.
+
+Your exercise of the Licensed Rights is expressly made subject to the
+following conditions.
+
+  a. Attribution.
+
+       1. If You Share the Licensed Material (including in modified
+          form), You must:
+
+            a. retain the following if it is supplied by the Licensor
+               with the Licensed Material:
+
+                 i. identification of the creator(s) of the Licensed
+                    Material and any others designated to receive
+                    attribution, in any reasonable manner requested by
+                    the Licensor (including by pseudonym if
+                    designated);
+
+                ii. a copyright notice;
+
+               iii. a notice that refers to this Public License;
+
+                iv. a notice that refers to the disclaimer of
+                    warranties;
+
+                 v. a URI or hyperlink to the Licensed Material to the
+                    extent reasonably practicable;
+
+            b. indicate if You modified the Licensed Material and
+               retain an indication of any previous modifications; and
+
+            c. indicate the Licensed Material is licensed under this
+               Public License, and include the text of, or the URI or
+               hyperlink to, this Public License.
+
+       2. You may satisfy the conditions in Section 3(a)(1) in any
+          reasonable manner based on the medium, means, and context in
+          which You Share the Licensed Material. For example, it may be
+          reasonable to satisfy the conditions by providing a URI or
+          hyperlink to a resource that includes the required
+          information.
+
+       3. If requested by the Licensor, You must remove any of the
+          information required by Section 3(a)(1)(A) to the extent
+          reasonably practicable.
+
+       4. If You Share Adapted Material You produce, the Adapter's
+          License You apply must not prevent recipients of the Adapted
+          Material from complying with this Public License.
+
+
+Section 4 -- Sui Generis Database Rights.
+
+Where the Licensed Rights include Sui Generis Database Rights that
+apply to Your use of the Licensed Material:
+
+  a. for the avoidance of doubt, Section 2(a)(1) grants You the right
+     to extract, reuse, reproduce, and Share all or a substantial
+     portion of the contents of the database;
+
+  b. if You include all or a substantial portion of the database
+     contents in a database in which You have Sui Generis Database
+     Rights, then the database in which You have Sui Generis Database
+     Rights (but not its individual contents) is Adapted Material; and
+
+  c. You must comply with the conditions in Section 3(a) if You Share
+     all or a substantial portion of the contents of the database.
+
+For the avoidance of doubt, this Section 4 supplements and does not
+replace Your obligations under this Public License where the Licensed
+Rights include other Copyright and Similar Rights.
+
+
+Section 5 -- Disclaimer of Warranties and Limitation of Liability.
+
+  a. UNLESS OTHERWISE SEPARATELY UNDERTAKEN BY THE LICENSOR, TO THE
+     EXTENT POSSIBLE, THE LICENSOR OFFERS THE LICENSED MATERIAL AS-IS
+     AND AS-AVAILABLE, AND MAKES NO REPRESENTATIONS OR WARRANTIES OF
+     ANY KIND CONCERNING THE LICENSED MATERIAL, WHETHER EXPRESS,
+     IMPLIED, STATUTORY, OR OTHER. THIS INCLUDES, WITHOUT LIMITATION,
+     WARRANTIES OF TITLE, MERCHANTABILITY, FITNESS FOR A PARTICULAR
+     PURPOSE, NON-INFRINGEMENT, ABSENCE OF LATENT OR OTHER DEFECTS,
+     ACCURACY, OR THE PRESENCE OR ABSENCE OF ERRORS, WHETHER OR NOT
+     KNOWN OR DISCOVERABLE. WHERE DISCLAIMERS OF WARRANTIES ARE NOT
+     ALLOWED IN FULL OR IN PART, THIS DISCLAIMER MAY NOT APPLY TO YOU.
+
+  b. TO THE EXTENT POSSIBLE, IN NO EVENT WILL THE LICENSOR BE LIABLE
+     TO YOU ON ANY LEGAL THEORY (INCLUDING, WITHOUT LIMITATION,
+     NEGLIGENCE) OR OTHERWISE FOR ANY DIRECT, SPECIAL, INDIRECT,
+     INCIDENTAL, CONSEQUENTIAL, PUNITIVE, EXEMPLARY, OR OTHER LOSSES,
+     COSTS, EXPENSES, OR DAMAGES ARISING OUT OF THIS PUBLIC LICENSE OR
+     USE OF THE LICENSED MATERIAL, EVEN IF THE LICENSOR HAS BEEN
+     ADVISED OF THE POSSIBILITY OF SUCH LOSSES, COSTS, EXPENSES, OR
+     DAMAGES. WHERE A LIMITATION OF LIABILITY IS NOT ALLOWED IN FULL OR
+     IN PART, THIS LIMITATION MAY NOT APPLY TO YOU.
+
+  c. The disclaimer of warranties and limitation of liability provided
+     above shall be interpreted in a manner that, to the extent
+     possible, most closely approximates an absolute disclaimer and
+     waiver of all liability.
+
+
+Section 6 -- Term and Termination.
+
+  a. This Public License applies for the term of the Copyright and
+     Similar Rights licensed here. However, if You fail to comply with
+     this Public License, then Your rights under this Public License
+     terminate automatically.
+
+  b. Where Your right to use the Licensed Material has terminated under
+     Section 6(a), it reinstates:
+
+       1. automatically as of the date the violation is cured, provided
+          it is cured within 30 days of Your discovery of the
+          violation; or
+
+       2. upon express reinstatement by the Licensor.
+
+     For the avoidance of doubt, this Section 6(b) does not affect any
+     right the Licensor may have to seek remedies for Your violations
+     of this Public License.
+
+  c. For the avoidance of doubt, the Licensor may also offer the
+     Licensed Material under separate terms or conditions or stop
+     distributing the Licensed Material at any time; however, doing so
+     will not terminate this Public License.
+
+  d. Sections 1, 5, 6, 7, and 8 survive termination of this Public
+     License.
+
+
+Section 7 -- Other Terms and Conditions.
+
+  a. The Licensor shall not be bound by any additional or different
+     terms or conditions communicated by You unless expressly agreed.
+
+  b. Any arrangements, understandings, or agreements regarding the
+     Licensed Material not stated herein are separate from and
+     independent of the terms and conditions of this Public License.
+
+
+Section 8 -- Interpretation.
+
+  a. For the avoidance of doubt, this Public License does not, and
+     shall not be interpreted to, reduce, limit, restrict, or impose
+     conditions on any use of the Licensed Material that could lawfully
+     be made without permission under this Public License.
+
+  b. To the extent possible, if any provision of this Public License is
+     deemed unenforceable, it shall be automatically reformed to the
+     minimum extent necessary to make it enforceable. If the provision
+     cannot be reformed, it shall be severed from this Public License
+     without affecting the enforceability of the remaining terms and
+     conditions.
+
+  c. No term or condition of this Public License will be waived and no
+     failure to comply consented to unless expressly agreed to by the
+     Licensor.
+
+  d. Nothing in this Public License constitutes or may be interpreted
+     as a limitation upon, or waiver of, any privileges and immunities
+     that apply to the Licensor or You, including from the legal
+     processes of any jurisdiction or authority.
+
 
 selectize.js
 ----------------------------------------------------------------------

NAMESPACE

@@ -25,6 +25,7 @@ S3method(as.tags,shiny.render.function)
 S3method(format,reactiveExpr)
 S3method(format,reactiveVal)
 S3method(names,reactivevalues)
+S3method(print,key_missing)
 S3method(print,reactive)
 S3method(print,shiny.appobj)
 S3method(str,reactivevalues)
@@ -40,6 +41,7 @@ export(actionButton)
 export(actionLink)
 export(addResourcePath)
 export(animationOptions)
+export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
 export(bookmarkButton)
@@ -58,6 +60,7 @@ export(code)
 export(column)
 export(conditionStackTrace)
 export(conditionalPanel)
+export(createRenderFunction)
 export(createWebDependency)
 export(dataTableOutput)
 export(dateInput)
@@ -65,6 +68,7 @@ export(dateRangeInput)
 export(dblclickOpts)
 export(debounce)
 export(dialogViewer)
+export(diskCache)
 export(div)
 export(downloadButton)
 export(downloadHandler)
@@ -88,6 +92,7 @@ export(fluidRow)
 export(formatStackTrace)
 export(freezeReactiveVal)
 export(freezeReactiveValue)
+export(getCurrentOutputInfo)
 export(getDefaultReactiveDomain)
 export(getQueryString)
 export(getShinyOption)
@@ -100,6 +105,7 @@ export(h5)
 export(h6)
 export(headerPanel)
 export(helpText)
+export(hideTab)
 export(hoverOpts)
 export(hr)
 export(htmlOutput)
@@ -114,15 +120,19 @@ 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(knit_print.html)
 export(knit_print.reactive)
 export(knit_print.shiny.appobj)
@@ -133,6 +143,7 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
+export(memoryCache)
 export(modalButton)
 export(modalDialog)
 export(navbarMenu)
@@ -152,6 +163,7 @@ export(onReactiveDomainEnded)
 export(onRestore)
 export(onRestored)
 export(onSessionEnded)
+export(onStop)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -161,6 +173,7 @@ export(passwordInput)
 export(plotOutput)
 export(plotPNG)
 export(pre)
+export(prependTab)
 export(printError)
 export(printStackTrace)
 export(radioButtons)
@@ -176,11 +189,16 @@ export(reactiveUI)
 export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
+export(reactlog)
+export(reactlogReset)
+export(reactlogShow)
 export(registerInputHandler)
 export(removeInputHandler)
 export(removeModal)
 export(removeNotification)
+export(removeTab)
 export(removeUI)
+export(renderCachedPlot)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -203,6 +221,7 @@ export(selectizeInput)
 export(serverInfo)
 export(setBookmarkExclude)
 export(setProgress)
+export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
@@ -213,11 +232,15 @@ 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)
@@ -256,9 +279,13 @@ 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)
@@ -274,3 +301,5 @@ import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
+importFrom(grDevices,dev.cur)
+importFrom(grDevices,dev.set)

NEWS.md

@@ -1,3 +1,280 @@
+shiny 1.3.1
+===========
+
+## Full changelog
+
+### Breaking changes
+
+### New features
+
+### Minor new features and improvements
+
+### Bug fixes
+
+* Fixed a performance issue introduced in v1.3.0 when using large nested lists within Shiny. ([#2377](https://github.com/rstudio/shiny/pull/2377))
+
+### Documentation Updates
+
+
+shiny 1.3.0
+===========
+
+## Full changelog
+
+### Breaking changes
+
+### New features
+
+* Revamped Shiny's [reactlog](https://github.com/rstudio/reactlog) viewer which debugs reactivity within a shiny application.  This allows users to traverse the reactivity history of a shiny application, filter to the dependency tree of a selected reactive object, and search for matching reactive objects.  See `?reactlogShow` for more details and how to enable this feature. ([#2107](https://github.com/rstudio/shiny/pull/2107))
+
+* Shiny now serves static files on a background thread. This means that things like JavaScript and CSS assets can be served without blocking or being blocked by the main R thread, and should result in significantly better performance for heavily loaded servers. ([#2280](https://github.com/rstudio/shiny/pull/2280))
+
+### Minor new features and improvements
+
+* The `Shiny-Shared-Secret` security header is now checked using constant-time comparison to prevent timing attacks (thanks @dirkschumacher!). ([#2319](https://github.com/rstudio/shiny/pull/2319))
+
+### Bug fixes
+
+* Fixed [#2245](https://github.com/rstudio/shiny/issues/2245): `updateSelectizeInput()` did not update labels. ([#2248](https://github.com/rstudio/shiny/pull/2248))
+
+* Fixed [#2308](https://github.com/rstudio/shiny/issues/2308): When restoring a bookmarked application, inputs with a leading `.` would not be restored. ([#2311](https://github.com/rstudio/shiny/pull/2311))
+
+* Fixed [#2305](https://github.com/rstudio/shiny/issues/2305), [#2322](https://github.com/rstudio/shiny/issues/2322), [#2351](https://github.com/rstudio/shiny/issues/2351): When an input in dynamic UI is restored from bookmarks, it would keep getting set to the same value. ([#2360](https://github.com/rstudio/shiny/pull/2360))
+
+* Fixed [#2349](https://github.com/rstudio/shiny/issues/2349), [#2329](https://github.com/rstudio/shiny/issues/2329), [#1817](https://github.com/rstudio/shiny/issues/1817): These were various bugs triggered by the presence of the [networkD3](https://christophergandrud.github.io/networkD3/) package's Sankey plot in an app. Impacted features included `dateRangeInput`, `withProgressBar`, and bookmarking ([#2359](https://github.com/rstudio/shiny/pull/2359))
+
+### Documentation Updates
+
+* Fixed [#2247](https://github.com/rstudio/shiny/issues/2247): `renderCachedPlot` now supports using promises for either `expr` or `cacheKeyExpr`. (Shiny v1.2.0 supported async `expr`, but only if `cacheKeyExpr` was async as well; now you can use any combination of sync/async for `expr` and `cacheKeyExpr`.) [#2261](https://github.com/rstudio/shiny/pull/2261)
+
+
+shiny 1.2.0
+===========
+
+This release features plot caching, an important new tool for improving performance and scalability. Using `renderCachedPlot` in place of `renderPlot` can greatly improve responsiveness for apps that show the same plot many times (for example, a dashboard or report where all users view the same data). Shiny gives you a fair amount of control in where the cache is stored and how cached plots are invalidated, so be sure to read [this article](http://shiny.rstudio.com/articles/plot-caching.html) to get the most out of this feature.
+
+## Full changelog
+
+### Breaking changes
+
+* The URL paths for FontAwesome CSS/JS/font assets have changed, due to our upgrade from FontAwesome 4 to 5. This shouldn't affect you unless you're using `www/index.html` to provide your UI and have hardcoded the old FontAwesome paths into your HTML. If that's you, consider switching to [HTML templates](https://shiny.rstudio.com/articles/templates.html), which give you the syntax of raw HTML while still taking advantage of Shiny's automatic management of web dependencies.
+
+### New features
+
+* Added `renderCachedPlot()`, which stores plots in a cache so that they can be served up almost instantly. ([#1997](https://github.com/rstudio/shiny/pull/1997))
+
+### Minor new features and improvements
+
+* Upgrade FontAwesome from 4.7.0 to 5.3.1 and made `icon` tags browsable, which means they will display in a web browser or RStudio viewer by default ([#2186](https://github.com/rstudio/shiny/issues/2186)). Note that if your application or library depends on FontAwesome directly using custom CSS, you may need to make some or all of the changes recommended in [Upgrade from Version 4](https://fontawesome.com/how-to-use/on-the-web/setup/upgrading-from-version-4). Font Awesome icons can also now be used in static R Markdown documents.
+
+* Address [#174](https://github.com/rstudio/shiny/issues/174): Added `datesdisabled` and `daysofweekdisabled` as new parameters to `dateInput()`. This resolves [#174](https://github.com/rstudio/shiny/issues/174) and exposes the underlying arguments of [Bootstrap Datepicker](http://bootstrap-datepicker.readthedocs.io/en/latest/options.html#datesdisabled). `datesdisabled` expects a character vector with values in `yyyy/mm/dd` format and `daysofweekdisabled` expects an integer vector with day interger ids (Sunday=0, Saturday=6). The default value for both is `NULL`, which leaves all days selectable. Thanks, @nathancday! ([#2147](https://github.com/rstudio/shiny/pull/2147))
+
+* Support for selecting variables of a data frame with the output values to be used within tidy evaluation.  Added functions: `varSelectInput`, `varSelectizeInput`, `updateVarSelectInput`, `updateVarSelectizeInput`. ([#2091](https://github.com/rstudio/shiny/pull/2091))
+
+* Addressed [#2042](https://github.com/rstudio/shiny/issues/2042): dates outside of `min`/`max` date range are now a lighter shade of grey to highlight the allowed range. ([#2087](https://github.com/rstudio/shiny/pull/2087))
+
+* Added support for plot interaction when the plot is scaled. ([#2125](https://github.com/rstudio/shiny/pull/2125))
+
+* Fixed [#1933](https://github.com/rstudio/shiny/issues/1933): extended server-side selectize to lists and optgroups. ([#2102](https://github.com/rstudio/shiny/pull/2102))
+
+* Added namespace support when freezing reactiveValue keys. [#2080](https://github.com/rstudio/shiny/pull/2080)
+
+* Upgrade selectize.js from 0.12.1 to 0.12.4 [#2028](https://github.com/rstudio/shiny/issues/2028)
+
+* Addressed [#2079](https://github.com/rstudio/shiny/issues/2079): Added `coords_img`, `coords_css`, and `img_css_ratio` fields containing x and y location information for plot brush, hover, and click events. [#2183](https://github.com/rstudio/shiny/pull/2183)
+
+### Bug fixes
+
+* Fixed [#2033](https://github.com/rstudio/shiny/issues/2033): RStudio Viewer window not closed on `shiny::stopApp()`. Thanks, @vnijs! [#2047](https://github.com/rstudio/shiny/pull/2047)
+
+* Fixed [#1935](https://github.com/rstudio/shiny/issues/1935): correctly returns plot coordinates when using outer margins. ([#2108](https://github.com/rstudio/shiny/pull/2108))
+
+* Resolved [#2019](https://github.com/rstudio/shiny/issues/2019): `updateSliderInput` now changes the slider formatting if the input type changes. ([#2099](https://github.com/rstudio/shiny/pull/2099))
+
+* Fixed [#2138](https://github.com/rstudio/shiny/issues/2138): Inputs that are part of a `renderUI` were no longer restoring correctly from bookmarked state. [#2139](https://github.com/rstudio/shiny/pull/2139)
+
+* Fixed [#2093](https://github.com/rstudio/shiny/issues/2093): Make sure bookmark scope directory does not exist before trying to create it. [#2168](https://github.com/rstudio/shiny/pull/2168)
+
+* Fixed [#2177](https://github.com/rstudio/shiny/issues/2177): The session name is now being recorded when exiting a context.  Multiple sessions can now view their respective reactlogs. [#2180](https://github.com/rstudio/shiny/pull/2180)
+
+* Fixed [#2162](https://github.com/rstudio/shiny/issues/2162): `selectInput` was sending spurious duplicate values to the server when using backspace. Thanks, @sada1993! [#2187](https://github.com/rstudio/shiny/pull/2187)
+
+* Fixed [#2142](https://github.com/rstudio/shiny/issues/2142): Dropping files on `fileInput`s stopped working on recent releases of Firefox. Thanks @dmenne for reporting! [#2203](https://github.com/rstudio/shiny/pull/2203)
+
+* Fixed [#2204](https://github.com/rstudio/shiny/issues/2204): `updateDateInput` could set the wrong date on days where DST begins. (Thanks @GaGaMan1101!) [#2212](https://github.com/rstudio/shiny/pull/2212)
+
+* Fixed [#2225](https://github.com/rstudio/shiny/issues/2225): Input event queue can stall in apps that use async. [#2226](https://github.com/rstudio/shiny/pull/2226)
+
+* Fixed [#2228](https://github.com/rstudio/shiny/issues/2228): `reactiveTimer` fails when not owned by a session. Thanks, @P-Bettega! [#2229](https://github.com/rstudio/shiny/pull/2229)
+
+### Documentation Updates
+
+* Addressed [#1864](https://github.com/rstudio/shiny/issues/1864) by changing `optgroup` documentation to use `list` instead of `c`. ([#2084](https://github.com/rstudio/shiny/pull/2084))
+
+
+shiny 1.1.0
+===========
+
+This is a significant release for Shiny, with a major new feature that was nearly a year in the making: support for asynchronous operations! Until now, R's single-threaded nature meant that performing long-running calculations or tasks from Shiny would bring your app to a halt for other users of that process. This release of Shiny deeply integrates the [promises](https://rstudio.github.io/promises/) package to allow you to execute some tasks asynchronously, including as part of reactive expressions and outputs. See the [promises](https://rstudio.github.io/promises/) documentation to learn more.
+
+## Full changelog
+
+### Breaking changes
+
+* `extractStackTrace` and `formatStackTrace` are deprecated and will be removed in a future version of Shiny. As far as we can tell, nobody has been using these functions, and a refactor has made them vestigial; if you need this functionality, please file an issue.
+
+### New features
+
+* Support for asynchronous operations! Built-in render functions that expected a certain kind of object to be yielded from their `expr`, now generally can handle a promise for that kind of object. Reactive expressions and observers are now promise-aware as well. ([#1932](https://github.com/rstudio/shiny/pull/1932))
+
+* Introduced two changes to the (undocumented but widely used) JavaScript function `Shiny.onInputChange(name, value)`. First, we changed the function name to `Shiny.setInputValue` (but don't worry--the old function name will continue to work). Second, until now, all calls to `Shiny.onInputChange(inputId, value)` have been "deduplicated"; that is, anytime an input is set to the same value it already has, the set is ignored. With Shiny v1.1, you can now add an options object as the third parameter: `Shiny.setInputValue("name", value, {priority: "event"})`. When the priority option is set to `"event"`, Shiny will always send the value and trigger reactivity, whether it is a duplicate or not. This closes [#928](https://github.com/rstudio/shiny/issues/928), which was the most upvoted open issue by far! Thanks, @daattali. ([#2018](https://github.com/rstudio/shiny/pull/2018))
+
+### Minor new features and improvements
+
+* Addressed [#1978](https://github.com/rstudio/shiny/issues/1978): `shiny:value` is now triggered when duplicate output data is received from the server. (Thanks, @andrewsali! [#1999](https://github.com/rstudio/shiny/pull/1999))
+
+* If a shiny output contains a css class of `shiny-report-size`, its container height and width are now reported in `session$clientData`. So, for an output with an id with `"myID"`, the height/width can be accessed via `session$clientData[['output_myID_height']]`/`session$clientData[['output_myID_width']]`. Addresses [#1980](https://github.com/rstudio/shiny/issues/1980). (Thanks, @cpsievert! [#1981](https://github.com/rstudio/shiny/pull/1981))
+
+* Added a new `autoclose = TRUE` parameter to `dateInput()` and `dateRangeInput()`. This closed [#1969](https://github.com/rstudio/shiny/issues/1969) which was a duplicate of much older issue, [#173](https://github.com/rstudio/shiny/issues/173). The default value is `TRUE` since that seems to be the common use case. However, this will cause existing apps with date inputs (that update to this version of Shiny) to have the datepicker be immediately closed once a date is selected. For most apps, this is actually desired behavior; if you wish to keep the datepicker open until the user clicks out of it use `autoclose = FALSE`. ([#1987](https://github.com/rstudio/shiny/pull/1987))
+
+* The version of Shiny is now accessible from Javascript, with `Shiny.version`. There is also a new function for comparing version strings, `Shiny.compareVersion()`. ([#1826](https://github.com/rstudio/shiny/pull/1826), [#1830](https://github.com/rstudio/shiny/pull/1830))
+
+* Addressed [#1851](https://github.com/rstudio/shiny/issues/1851): Stack traces are now smaller in some places `do.call()` is used. ([#1856](https://github.com/rstudio/shiny/pull/1856))
+
+* Stack traces have been improved, with more aggressive de-noising and support for deep stack traces (stitching together multiple stack traces that are conceptually part of the same async operation).
+
+* Addressed [#1859](https://github.com/rstudio/shiny/issues/1859): Server-side selectize is now significantly faster. (Thanks to @dselivanov [#1861](https://github.com/rstudio/shiny/pull/1861))
+
+* [#1989](https://github.com/rstudio/shiny/issues/1989): The server side of outputs can now be removed (e.g. `output$plot <- NULL`). This is not usually necessary but it does allow some objects to be garbage collected, which might matter if you are dynamically creating and destroying many outputs. (Thanks, @mmuurr! [#2011](https://github.com/rstudio/shiny/pull/2011))
+
+* Removed the (ridiculously outdated) "experimental feature" tag from the reference documentation for `renderUI`. ([#2036](https://github.com/rstudio/shiny/pull/2036))
+
+* Addressed [#1907](https://github.com/rstudio/shiny/issues/1907): the `ignoreInit` argument was first added only to `observeEvent`. Later, we also added it to `eventReactive`, but forgot to update the documentation. Now done, thanks [@flo12392](https://github.com/flo12392)! ([#2036](https://github.com/rstudio/shiny/pull/2036))
+
+### Bug fixes
+
+* Fixed [#1006](https://github.com/rstudio/shiny/issues/1006): Slider inputs sometimes showed too many digits. ([#1956](https://github.com/rstudio/shiny/pull/1956))
+
+* Fixed [#1958](https://github.com/rstudio/shiny/issues/1958): Slider inputs previously displayed commas after a decimal point. ([#1960](https://github.com/rstudio/shiny/pull/1960))
+
+* The internal `URLdecode()` function previously was a copy of `httpuv::decodeURIComponent()`, assigned at build time; now it invokes the httpuv function at run time.
+
+* Fixed [#1840](https://github.com/rstudio/shiny/issues/1840): with the release of Shiny 1.0.5, we accidently changed the relative positioning of the icon and the title text in `navbarMenu`s and `tabPanel`s. This fix reverts this behavior back (i.e. the icon should be to the left of the text and/or the downward arrow in case of `navbarMenu`s). ([#1848](https://github.com/rstudio/shiny/pull/1848))
+
+* Fixed [#1600](https://github.com/rstudio/shiny/issues/1600): URL-encoded bookmarking did not work with sliders that had dates or date-times. ([#1961](https://github.com/rstudio/shiny/pull/1961))
+
+* Fixed [#1962](https://github.com/rstudio/shiny/issues/1962): [File dragging and dropping](https://blog.rstudio.com/2017/08/15/shiny-1-0-4/) broke in the presence of jQuery version 3.0 as introduced by the [rhandsontable](https://jrowen.github.io/rhandsontable/) [htmlwidget](https://www.htmlwidgets.org/). ([#2005](https://github.com/rstudio/shiny/pull/2005))
+
+* Improved the error handling inside the `addResourcePath()` function, to give end users more informative error messages when the `directoryPath` argument cannot be normalized. This is especially useful for `runtime: shiny_prerendered` Rmd documents, like `learnr` tutorials. ([#1968](https://github.com/rstudio/shiny/pull/1968))
+
+* Changed script tags in reactlog ([inst/www/reactive-graph.html](https://github.com/rstudio/shiny/blob/v1.1.0/inst/www/reactive-graph.html)) from HTTP to HTTPS in order to avoid mixed content blocking by most browsers. (Thanks, @jekriske-lilly! [#1844](https://github.com/rstudio/shiny/pull/1844))
+
+* Addressed [#1784](https://github.com/rstudio/shiny/issues/1784): `runApp()` will avoid port 6697, which is considered unsafe by Chrome.
+
+* Fixed [#2000](https://github.com/rstudio/shiny/issues/2000): Implicit calls to `xxxOutput` not working inside modules. (Thanks, @GregorDeCillia! [#2010](https://github.com/rstudio/shiny/pull/2010))
+
+* Fixed [#2021](https://github.com/rstudio/shiny/issues/2021): Memory leak with `reactiveTimer` and `invalidateLater`. ([#2022](https://github.com/rstudio/shiny/pull/2022))
+
+### Library updates
+
+* Updated to ion.rangeSlider 2.2.0. ([#1955](https://github.com/rstudio/shiny/pull/1955))
+
+
+## Known issues
+
+In some rare cases, interrupting an application (by pressing Ctrl-C or Esc) may result in the message `Error in execCallbacks(timeoutSecs) : c++ exception (unknown reason)`. Although this message sounds alarming, it is harmless, and will go away in a future version of the later package (more information [here](https://github.com/r-lib/later/issues/55)).
+
+
+shiny 1.0.5
+===========
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed [#1818](https://github.com/rstudio/shiny/issues/1818): `conditionalPanel()` expressions that have a newline character in them caused the application to not work. ([#1820](https://github.com/rstudio/shiny/pull/1820))
+
+* Added a safe wrapper function for internal calls to `jsonlite::fromJSON()`. ([#1822](https://github.com/rstudio/shiny/pull/1822))
+
+* Fixed [#1824](https://github.com/rstudio/shiny/issues/1824): HTTP HEAD requests on static files caused the application to stop. ([#1825](https://github.com/rstudio/shiny/pull/1825))
+
+
+shiny 1.0.4
+===========
+
+There are three headlining features in this release of Shiny. It is now possible to add and remove tabs from a `tabPanel`; there is a new function, `onStop()`, which registers callbacks that execute when an application exits; and `fileInput`s now can have files dragged and dropped on them. In addition to these features, this release has a number of minor features and bug fixes. See the full changelog below for more details.
+
+## Full changelog
+
+### New features
+
+* Implemented [#1668](https://github.com/rstudio/shiny/issues/1668): dynamic tabs: added functions (`insertTab`, `appendTab`, `prependTab`, `removeTab`, `showTab` and `hideTab`) that allow you to do those actions for an existing `tabsetPanel`. ([#1794](https://github.com/rstudio/shiny/pull/1794))
+
+* Implemented [#1213](https://github.com/rstudio/shiny/issues/1213): Added a new function, `onStop()`, which can be used to register callback functions that are invoked when an application exits, or when a user session ends. (Multiple sessions can be connected to a single running Shiny application.) This is useful if you have finalization/clean-up code that should be run after the application exits. ([#1770](https://github.com/rstudio/shiny/pull/1770)
+
+* Implemented [#1155](https://github.com/rstudio/shiny/issues/1155): Files can now be drag-and-dropped on `fileInput` controls. The appearance of `fileInput` controls while files are being dragged can be modified by overriding the `shiny-file-input-active` and `shiny-file-input-over` classes. ([#1782](https://github.com/rstudio/shiny/pull/1782))
+
+### Minor new features and improvements
+
+* Addressed [#1688](https://github.com/rstudio/shiny/issues/1688): trigger a new `shiny:outputinvalidated` event when an output gets invalidated, at the same time that the `recalculating` CSS class is added. ([#1758](https://github.com/rstudio/shiny/pull/1758), thanks [@andrewsali](https://github.com/andrewsali)!)
+
+* Addressed [#1508](https://github.com/rstudio/shiny/issues/1508): `fileInput` now permits the same file to be uploaded multiple times. ([#1719](https://github.com/rstudio/shiny/pull/1719))
+
+* Addressed [#1501](https://github.com/rstudio/shiny/issues/1501): The `fileInput` control now retains uploaded file extensions on the server. This fixes [readxl](https://github.com/tidyverse/readxl)'s `readxl::read_excel` and other functions that must recognize a file's extension in order to work. ([#1706](https://github.com/rstudio/shiny/pull/1706))
+
+* For `conditionalPanel`s, Shiny now gives more informative messages if there are errors evaluating or parsing the JavaScript conditional expression. ([#1727](https://github.com/rstudio/shiny/pull/1727))
+
+* Addressed [#1586](https://github.com/rstudio/shiny/issues/1586): The `conditionalPanel` function now accepts an `ns` argument. The `ns` argument can be used in a [module](https://shiny.rstudio.com/articles/modules.html) UI function to scope the `condition` expression to the module's own input and output IDs. ([#1735](https://github.com/rstudio/shiny/pull/1735))
+
+* With `options(shiny.testmode=TRUE)`, the Shiny process will send a message to the client in response to a changed input, even if no outputs have changed. This helps to streamline testing using the shinytest package. ([#1747](https://github.com/rstudio/shiny/pull/1747))
+
+* Addressed [#1738](https://github.com/rstudio/shiny/issues/1738): The `updateTextInput` and `updateTextAreaInput` functions can now update the placeholder. ([#1742](https://github.com/rstudio/shiny/pull/1742))
+
+* Converted examples to single file apps, and made updates and enhancements to comments in the example app scripts. ([#1685](https://github.com/rstudio/shiny/pull/1685))
+
+* Added new `snapshotPreprocessInput()` and `snapshotPreprocessOutput()` functions, which is used for preprocessing and input and output values before taking a test snapshot. ([#1760](https://github.com/rstudio/shiny/pull/1760), [#1789](https://github.com/rstudio/shiny/pull/1789))
+
+* The HTML generated by `renderTable()` no longer includes comments with the R version, xtable version, and timestamp. ([#1771](https://github.com/rstudio/shiny/pull/1771))
+
+* Added a function `isRunning` to test whether a Shiny app is currently running. ([#1785](https://github.com/rstudio/shiny/pull/1785))
+
+* Added a function `setSerializer`, which allows authors to specify a function for serializing the value of a custom input. ([#1791](https://github.com/rstudio/shiny/pull/1791))
+
+### Bug fixes
+
+* Fixed [#1546](https://github.com/rstudio/shiny/issues/1546): make it possible (without any hacks) to write arbitrary data into a module's `session$userData` (which is exactly the same environment as the parent's `session$userData`). To be clear, it allows something like `session$userData$x <- TRUE`, but not something like `session$userData <- TRUE` (that is not allowed in any context, whether you're in the main app, or in a module) ([#1732](https://github.com/rstudio/shiny/pull/1732)).
+
+* Fixed [#1701](https://github.com/rstudio/shiny/issues/1701): There was a partial argument match in the `generateOptions` function. ([#1702](https://github.com/rstudio/shiny/pull/1702))
+
+* Fixed [#1710](https://github.com/rstudio/shiny/issues/1710): `ReactiveVal` objects did not have separate dependents. ([#1712](https://github.com/rstudio/shiny/pull/1712))
+
+* Fixed [#1438](https://github.com/rstudio/shiny/issues/1438): `unbindAll()` should not be called when inserting content with `insertUI()`. A previous fix ([#1449](https://github.com/rstudio/shiny/pull/1449)) did not work correctly. ([#1736](https://github.com/rstudio/shiny/pull/1736))
+
+* Fixed [#1755](https://github.com/rstudio/shiny/issues/1755): dynamic htmlwidgets sent the path of the package on the server to the client. ([#1756](https://github.com/rstudio/shiny/pull/1756))
+
+* Fixed [#1763](https://github.com/rstudio/shiny/issues/1763): Shiny's private random stream leaked out into the main random stream. ([#1768](https://github.com/rstudio/shiny/pull/1768))
+
+* Fixed [#1680](https://github.com/rstudio/shiny/issues/1680): `options(warn=2)` was not respected when running an app. ([#1790](https://github.com/rstudio/shiny/pull/1790))
+
+* Fixed [#1772](https://github.com/rstudio/shiny/issues/1772): ensure that `runApp()` respects the `shinyApp(onStart = function())` argument. ([#1770](https://github.com/rstudio/shiny/pull/1770))
+
+* Fixed [#1474](https://github.com/rstudio/shiny/issues/1474): A `browser()` call in an observer could cause an error in the RStudio IDE on Windows. ([#1802](https://github.com/rstudio/shiny/pull/1802))
+
+
+shiny 1.0.3
+================
+
+This is a hotfix release of Shiny. With previous versions of Shiny, when running an application on the newly-released version of R, 3.4.0, it would print a message: `Warning in body(fun) : argument is not a function`. This has no effect on the application, but because the message could be alarming to users, we are releasing a new version of Shiny that fixes this issue.
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed [#1672](https://github.com/rstudio/shiny/issues/1672): When an error occurred while uploading a file, the progress bar did not change colors. ([#1673](https://github.com/rstudio/shiny/pull/1673))
+
+* Fixed [#1676](https://github.com/rstudio/shiny/issues/1676): On R 3.4.0, running a Shiny application gave a warning: `Warning in body(fun) : argument is not a function`. ([#1677](https://github.com/rstudio/shiny/pull/1677))
+
+
 shiny 1.0.2
 ================
 
@@ -119,7 +396,7 @@ Now there's an official way to slow down reactive values and expressions that in
 ### Minor new features and improvements
 
 * Addressed [#1486](https://github.com/rstudio/shiny/issues/1486) by adding a new argument to `observeEvent` and `eventReactive`, called `ignoreInit` (defaults to `FALSE` for backwards compatibility). When set to `TRUE`, the action (i.e. the second argument: `handlerExpr` and `valueExpr`, respectively) will not be triggered when the observer/reactive is first created/initialized. In other words, `ignoreInit = TRUE` ensures that the `observeEvent` (or `eventReactive`) is *never* run right away. For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
-    
+
 * Added a new argument to `observeEvent` called `once`. When set to `TRUE`, it results in the observer being destroyed (stop observing) after the first time that `handlerExpr` is run (i.e. `once = TRUE` guarantees that the observer only runs, at most, once). For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
 
 * Addressed [#1358](https://github.com/rstudio/shiny/issues/1358): more informative error message when calling `runApp()` inside of an app's app.R (or inside ui.R or server.R). ([#1482](https://github.com/rstudio/shiny/pull/1482))
@@ -518,7 +795,7 @@ shiny 0.12.1
 shiny 0.12.0
 ============
 
-In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps. 
+In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps.
 
 ### JSON serialization
 
@@ -609,13 +886,13 @@ Shiny 0.11 switches away from the Bootstrap 2 web framework to the next version,
 ### Known issues for migration
 
 *    In Bootstrap 3, images in `<img>` tags are no longer automatically scaled to the width of their container. If you use `img()` in your UI code, or `<img>` tags in your raw HTML source, it's possible that they will be too large in the new version of Shiny. To address this you can add the `img-responsive` class:
-    
+
     ```r
     img(src = "picture.png", class = "img-responsive")
     ```
-    
+
     The R code above will generate the following HTML:
-    
+
     ```html
     <img src="picture.png" class="img-responsive">
     ```

R/app.R

@@ -71,7 +71,7 @@
 #' }
 #' @export
 shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
-                     uiPattern="/", enableBookmarking = NULL) {
+                     uiPattern="/", enableBookmarking=NULL) {
   if (is.null(server)) {
     stop("`server` missing from shinyApp")
   }
@@ -170,7 +170,14 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
   }
 
   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),
@@ -212,7 +219,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     if (file.exists(file.path.ci(appDir, "global.R")))
       sourceUTF8(file.path.ci(appDir, "global.R"))
   }
-  onEnd <- function() {
+  onStop <- function() {
     setwd(oldwd)
     monitorHandle()
     monitorHandle <<- NULL
@@ -220,10 +227,11 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 
   structure(
     list(
-      httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
+      staticPaths = staticPaths,
+      httpHandler = joinHandlers(c(uiHandler, fallbackWWWDir)),
       serverFuncSource = serverFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
+      onStop = onStop,
       options = options
     ),
     class = "shiny.appobj"
@@ -309,6 +317,20 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
   }
 
   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
@@ -317,8 +339,9 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
     oldwd <<- getwd()
     setwd(appDir)
     monitorHandle <<- initAutoReloadMonitor(appDir)
+    if (!is.null(appObj()$onStart)) appObj()$onStart()
   }
-  onEnd <- function() {
+  onStop <- function() {
     setwd(oldwd)
     monitorHandle()
     monitorHandle <<- NULL
@@ -326,10 +349,16 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
 
   structure(
     list(
-      httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
+      # 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,
+      httpHandler = joinHandlers(c(dynHttpHandler, fallbackWWWDir)),
       serverFuncSource = dynServerFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
+      onStop = onStop,
       options = options
     ),
     class = "shiny.appobj"
@@ -380,9 +409,10 @@ print.shiny.appobj <- function(x, ...) {
       c("port", "launch.browser", "host", "quiet",
         "display.mode", "test.mode")]
 
-  args <- c(list(x), opts)
+  # Quote x and put runApp in quotes so that there's a nicer stack trace (#1851)
+  args <- c(list(quote(x)), opts)
 
-  do.call(runApp, args)
+  do.call("runApp", args)
 }
 
 #' @rdname shinyApp

R/bookmark-state.R

@@ -349,7 +349,7 @@ RestoreContext <- R6Class("RestoreContext",
         mapply(names(vals), vals, SIMPLIFY = FALSE,
           FUN = function(name, value) {
             tryCatch(
-              jsonlite::fromJSON(value),
+              safeFromJSON(value),
               error = function(e) {
                 stop("Failed to parse URL parameter \"", name, "\"")
               }
@@ -426,7 +426,7 @@ RestoreInputSet <- R6Class("RestoreInputSet",
     },
 
     asList = function() {
-      as.list.environment(private$values)
+      as.list.environment(private$values, all.names = TRUE)
     }
   )
 )
@@ -448,14 +448,30 @@ withRestoreContext <- function(ctx, expr) {
 
 # Is there a current restore context?
 hasCurrentRestoreContext <- function() {
-  restoreCtxStack$size() > 0
+  if (restoreCtxStack$size() > 0)
+    return(TRUE)
+  domain <- getDefaultReactiveDomain()
+  if (!is.null(domain) && !is.null(domain$restoreContext))
+    return(TRUE)
+  
+  return(FALSE)
 }
 
-# Call to access the current restore context
+# Call to access the current restore context. First look on the restore
+# context stack, and if not found, then see if there's one on the current
+# reactive domain. In practice, the only time there will be a restore context
+# on the stack is when executing the UI function; when executing server code,
+# the restore context will be attached to the domain/session.
 getCurrentRestoreContext <- function() {
   ctx <- restoreCtxStack$peek()
   if (is.null(ctx)) {
-    stop("No restore context found")
+    domain <- getDefaultReactiveDomain()
+
+    if (is.null(domain) || is.null(domain$restoreContext)) {
+      stop("No restore context found")
+    }
+
+    ctx <- domain$restoreContext
   }
   ctx
 }

R/bootstrap-layout.R

@@ -588,7 +588,7 @@ flexfill <- function(..., direction, flex, width = width, height = height) {
   }
 
   if (length(flex) > length(children)) {
-    flex <- flex[1:length(children)]
+    flex <- flex[seq_along(children)]
   }
 
   # The dimension along the main axis

R/bootstrap.R

@@ -285,7 +285,8 @@ pageWithSidebar <- function(headerPanel,
 #'   example below).
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{tabsetPanel}},
-#'   \code{\link{updateNavbarPage}}
+#'   \code{\link{updateNavbarPage}}, \code{\link{insertTab}},
+#'   \code{\link{showTab}}
 #'
 #' @examples
 #' navbarPage("App Title",
@@ -393,10 +394,15 @@ navbarPage <- function(title,
   )
 }
 
+#' @param menuName A name that identifies this \code{navbarMenu}. This
+#'   is needed if you want to insert/remove or show/hide an entire
+#'   \code{navbarMenu}.
+#'
 #' @rdname navbarPage
 #' @export
-navbarMenu <- function(title, ..., icon = NULL) {
+navbarMenu <- function(title, ..., menuName = title, icon = NULL) {
   structure(list(title = title,
+                 menuName = menuName,
                  tabs = list(...),
                  iconClass = iconClass(icon)),
             class = "shiny.navbarmenu")
@@ -502,6 +508,8 @@ mainPanel <- function(..., width = 8) {
 #'
 #' @param condition A JavaScript expression that will be evaluated repeatedly to
 #'   determine whether the panel should be displayed.
+#' @param ns The \code{\link[=NS]{namespace}} object of the current module, if
+#'   any.
 #' @param ... Elements to include in the panel.
 #'
 #' @note You are not recommended to use special JavaScript characters such as a
@@ -510,32 +518,55 @@ mainPanel <- function(..., width = 8) {
 #'   \code{input["foo.bar"]} instead of \code{input.foo.bar} to read the input
 #'   value.
 #' @examples
-#' sidebarPanel(
-#'    selectInput(
-#'       "plotType", "Plot Type",
-#'       c(Scatter = "scatter",
-#'         Histogram = "hist")),
-#'
-#'    # Only show this panel if the plot type is a histogram
-#'    conditionalPanel(
-#'       condition = "input.plotType == 'hist'",
-#'       selectInput(
-#'          "breaks", "Breaks",
-#'          c("Sturges",
-#'            "Scott",
-#'            "Freedman-Diaconis",
-#'            "[Custom]" = "custom")),
-#'
-#'       # Only show this panel if Custom is selected
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   ui <- fluidPage(
+#'     sidebarPanel(
+#'       selectInput("plotType", "Plot Type",
+#'         c(Scatter = "scatter", Histogram = "hist")
+#'       ),
+#'       # Only show this panel if the plot type is a histogram
 #'       conditionalPanel(
-#'          condition = "input.breaks == 'custom'",
-#'          sliderInput("breakCount", "Break Count", min=1, max=1000, value=10)
+#'         condition = "input.plotType == 'hist'",
+#'         selectInput(
+#'           "breaks", "Breaks",
+#'           c("Sturges", "Scott", "Freedman-Diaconis", "[Custom]" = "custom")
+#'         ),
+#'         # Only show this panel if Custom is selected
+#'         conditionalPanel(
+#'           condition = "input.breaks == 'custom'",
+#'           sliderInput("breakCount", "Break Count", min = 1, max = 50, value = 10)
+#'         )
 #'       )
-#'    )
-#' )
+#'     ),
+#'     mainPanel(
+#'       plotOutput("plot")
+#'     )
+#'   )
+#'
+#'   server <- function(input, output) {
+#'     x <- rnorm(100)
+#'     y <- rnorm(100)
+#'
+#'     output$plot <- renderPlot({
+#'       if (input$plotType == "scatter") {
+#'         plot(x, y)
+#'       } else {
+#'         breaks <- input$breaks
+#'         if (breaks == "custom") {
+#'           breaks <- input$breakCount
+#'         }
+#'
+#'         hist(x, breaks = breaks)
+#'       }
+#'     })
+#'   }
+#'
+#'   shinyApp(ui, server)
+#' }
 #' @export
-conditionalPanel <- function(condition, ...) {
-  div('data-display-if'=condition, ...)
+conditionalPanel <- function(condition, ..., ns = NS(NULL)) {
+  div(`data-display-if`=condition, `data-ns-prefix`=ns(""), ...)
 }
 
 #' Create a help text element
@@ -609,7 +640,8 @@ tabPanel <- function(title, ..., value = title, icon = NULL) {
 #'   Bootstrap 3.
 #' @return A tabset that can be passed to \code{\link{mainPanel}}
 #'
-#' @seealso \code{\link{tabPanel}}, \code{\link{updateTabsetPanel}}
+#' @seealso \code{\link{tabPanel}}, \code{\link{updateTabsetPanel}},
+#'   \code{\link{insertTab}}, \code{\link{showTab}}
 #'
 #' @examples
 #' # Show a tabset that includes a plot, summary, and
@@ -676,7 +708,9 @@ tabsetPanel <- function(...,
 #'   supported. This is because version 0.11 switched to Bootstrap 3, which
 #'   doesn't support separators.
 #'
-#' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
+#' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}},
+#'    \code{\link{insertTab}}, \code{\link{showTab}}
+#'
 #' @examples
 #' fluidPage(
 #'
@@ -726,189 +760,158 @@ navlistPanel <- function(...,
     fixedRow(columns)
 }
 
+# Helpers to build tabsetPanels (& Co.) and their elements
+markTabAsSelected <- function(x) {
+  attr(x, "selected") <- TRUE
+  x
+}
 
-buildTabset <- function(tabs, ulClass, textFilter = NULL,
-                        id = NULL, selected = NULL) {
+isTabSelected <- function(x) {
+  isTRUE(attr(x, "selected", exact = TRUE))
+}
 
-  # This function proceeds in two phases. First, it scans over all the items
-  # to find and mark which tab should start selected. Then it actually builds
-  # the tab nav and tab content lists.
+containsSelectedTab <- function(tabs) {
+  any(vapply(tabs, isTabSelected, logical(1)))
+}
 
-  # Mark an item as selected
-  markSelected <- function(x) {
-    attr(x, "selected") <- TRUE
-    x
-  }
+findAndMarkSelectedTab <- function(tabs, selected, foundSelected) {
+  tabs <- lapply(tabs, function(div) {
+    if (foundSelected || is.character(div)) {
+      # Strings are not selectable items
 
-  # Returns TRUE if an item is selected
-  isSelected <- function(x) {
-    isTRUE(attr(x, "selected", exact = TRUE))
-  }
-
-  # Returns TRUE if a list of tab items contains a selected tab, FALSE
-  # otherwise.
-  containsSelected <- function(tabs) {
-    any(vapply(tabs, isSelected, logical(1)))
-  }
-
-  # Take a pass over all tabs, and mark the selected tab.
-  foundSelectedItem <- FALSE
-  findAndMarkSelected <- function(tabs, selected) {
-    lapply(tabs, function(divTag) {
-      if (foundSelectedItem) {
-        # If we already found the selected tab, no need to keep looking
-
-      } else if (is.character(divTag)) {
-        # Strings don't represent selectable items
-
-      } else if (inherits(divTag, "shiny.navbarmenu")) {
-        # Navbar menu
-        divTag$tabs <- findAndMarkSelected(divTag$tabs, selected)
+    } else if (inherits(div, "shiny.navbarmenu")) {
+      # Recur for navbarMenus
+      res <- findAndMarkSelectedTab(div$tabs, selected, foundSelected)
+      div$tabs <- res$tabs
+      foundSelected <<- res$foundSelected
 
+    } else {
+      # Base case: regular tab item. If the `selected` argument is
+      # provided, check for a match in the existing tabs; else,
+      # mark first available item as selected
+      if (is.null(selected)) {
+        foundSelected <<- TRUE
+        div <- markTabAsSelected(div)
       } else {
-        # Regular tab item
-        if (is.null(selected)) {
-          # If selected tab isn't specified, mark first available item
-          # as selected.
-          foundSelectedItem <<- TRUE
-          divTag <- markSelected(divTag)
-
-        } else {
-          # If selected tab is specified, check for a match
-          tabValue <- divTag$attribs$`data-value` %OR% divTag$attribs$title
-          if (identical(selected, tabValue)) {
-            foundSelectedItem <<- TRUE
-            divTag <- markSelected(divTag)
-          }
+        tabValue <- div$attribs$`data-value` %OR% div$attribs$title
+        if (identical(selected, tabValue)) {
+          foundSelected <<- TRUE
+          div <- markTabAsSelected(div)
         }
       }
+    }
+    return(div)
+  })
+  return(list(tabs = tabs, foundSelected = foundSelected))
+}
 
-      return(divTag)
-    })
-  }
-
-
-  # Append an optional icon to an aTag
-  appendIcon <- function(aTag, iconClass) {
-    if (!is.null(iconClass)) {
+# Returns the icon object (or NULL if none), provided either a
+# tabPanel, OR the icon class
+getIcon <- function(tab = NULL, iconClass = NULL) {
+  if (!is.null(tab)) iconClass <- tab$attribs$`data-icon-class`
+  if (!is.null(iconClass)) {
+    if (grepl("fa-", iconClass, fixed = TRUE)) {
       # for font-awesome we specify fixed-width
-      if (grepl("fa-", iconClass, fixed = TRUE))
-        iconClass <- paste(iconClass, "fa-fw")
-      aTag <- tagAppendChild(aTag, icon(name = NULL, class = iconClass))
+      iconClass <- paste(iconClass, "fa-fw")
     }
-    aTag
+    icon(name = NULL, class = iconClass)
+  } else NULL
+}
+
+# Text filter for navbarMenu's (plain text) separators
+navbarMenuTextFilter <- function(text) {
+  if (grepl("^\\-+$", text)) tags$li(class = "divider")
+  else tags$li(class = "dropdown-header", text)
+}
+
+# This function is called internally by navbarPage, tabsetPanel
+# and navlistPanel
+buildTabset <- function(tabs, ulClass, textFilter = NULL, id = NULL,
+                        selected = NULL, foundSelected = FALSE) {
+
+  res <- findAndMarkSelectedTab(tabs, selected, foundSelected)
+  tabs <- res$tabs
+  foundSelected <- res$foundSelected
+
+  # add input class if we have an id
+  if (!is.null(id)) ulClass <- paste(ulClass, "shiny-tab-input")
+
+  if (anyNamed(tabs)) {
+    nms <- names(tabs)
+    nms <- nms[nzchar(nms)]
+    stop("Tabs should all be unnamed arguments, but some are named: ",
+      paste(nms, collapse = ", "))
   }
 
-  # Build the tabset
-  build <- function(tabs, ulClass, textFilter = NULL, id = NULL) {
-    # add tab input sentinel class if we have an id
-    if (!is.null(id))
-      ulClass <- paste(ulClass, "shiny-tab-input")
+  tabsetId <- p_randomInt(1000, 10000)
+  tabs <- lapply(seq_len(length(tabs)), buildTabItem,
+            tabsetId = tabsetId, foundSelected = foundSelected,
+            tabs = tabs, textFilter = textFilter)
 
-    if (anyNamed(tabs)) {
-      nms <- names(tabs)
-      nms <- nms[nzchar(nms)]
-      stop("Tabs should all be unnamed arguments, but some are named: ",
-           paste(nms, collapse = ", "))
+  tabNavList <- tags$ul(class = ulClass, id = id,
+                  `data-tabsetid` = tabsetId, lapply(tabs, "[[", 1))
+
+  tabContent <- tags$div(class = "tab-content",
+                  `data-tabsetid` = tabsetId, lapply(tabs, "[[", 2))
+
+  list(navList = tabNavList, content = tabContent)
+}
+
+# Builds tabPanel/navbarMenu items (this function used to be
+# declared inside the buildTabset() function and it's been
+# refactored for clarity and reusability). Called internally
+# by buildTabset.
+buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
+                         divTag = NULL, textFilter = NULL) {
+
+  divTag <- if (!is.null(divTag)) divTag else tabs[[index]]
+
+  if (is.character(divTag) && !is.null(textFilter)) {
+    # text item: pass it to the textFilter if it exists
+    liTag <- textFilter(divTag)
+    divTag <- NULL
+
+  } else if (inherits(divTag, "shiny.navbarmenu")) {
+    # navbarMenu item: build the child tabset
+    tabset <- buildTabset(divTag$tabs, "dropdown-menu",
+      navbarMenuTextFilter, foundSelected = foundSelected)
+
+    # if this navbarMenu contains a selected item, mark it active
+    containsSelected <- containsSelectedTab(divTag$tabs)
+    liTag <- tags$li(
+      class = paste0("dropdown", if (containsSelected) " active"),
+      tags$a(href = "#",
+        class = "dropdown-toggle", `data-toggle` = "dropdown",
+        `data-value` = divTag$menuName,
+        getIcon(iconClass = divTag$iconClass),
+        divTag$title, tags$b(class = "caret")
+      ),
+      tabset$navList   # inner tabPanels items
+    )
+    # list of tab content divs from the child tabset
+    divTag <- tabset$content$children
+
+  } else {
+    # tabPanel item: create the tab's liTag and divTag
+    tabId <- paste("tab", tabsetId, index, sep = "-")
+    liTag <- tags$li(
+               tags$a(
+                 href = paste("#", tabId, sep = ""),
+                 `data-toggle` = "tab",
+                 `data-value` = divTag$attribs$`data-value`,
+                 getIcon(iconClass = divTag$attribs$`data-icon-class`),
+                 divTag$attribs$title
+               )
+    )
+    # if this tabPanel is selected item, mark it active
+    if (isTabSelected(divTag)) {
+      liTag$attribs$class <- "active"
+      divTag$attribs$class <- "tab-pane active"
     }
-
-    tabNavList <- tags$ul(class = ulClass, id = id)
-    tabContent <- tags$div(class = "tab-content")
-    tabsetId <- p_randomInt(1000, 10000)
-    tabId <- 1
-
-    buildItem <- function(divTag) {
-      # check for text; pass it to the textFilter or skip it if there is none
-      if (is.character(divTag)) {
-        if (!is.null(textFilter)) {
-          tabNavList <<- tagAppendChild(tabNavList, textFilter(divTag))
-        }
-
-      } else if (inherits(divTag, "shiny.navbarmenu")) {
-
-        # create the a tag
-        aTag <- tags$a(href="#",
-                       class="dropdown-toggle",
-                       `data-toggle`="dropdown")
-
-        # add optional icon
-        aTag <- appendIcon(aTag, divTag$iconClass)
-
-        # add the title and caret
-        aTag <- tagAppendChild(aTag, divTag$title)
-        aTag <- tagAppendChild(aTag, tags$b(class="caret"))
-
-        # build the dropdown list element
-        liTag <- tags$li(class = "dropdown", aTag)
-
-        # text filter for separators
-        textFilter <- function(text) {
-          if (grepl("^\\-+$", text))
-            tags$li(class="divider")
-          else
-            tags$li(class="dropdown-header", text)
-        }
-
-        # build the child tabset
-        tabset <- build(divTag$tabs, "dropdown-menu", textFilter)
-        liTag <- tagAppendChild(liTag, tabset$navList)
-
-        # If this navbar menu contains a selected item, mark it as active
-        if (containsSelected(divTag$tabs)) {
-          liTag$attribs$class <- paste(liTag$attribs$class, "active")
-        }
-
-        tabNavList <<- tagAppendChild(tabNavList, liTag)
-        # don't add a standard tab content div, rather add the list of tab
-        # content divs that are contained within the tabset
-        tabContent <<- tagAppendChildren(tabContent,
-                                        list = tabset$content$children)
-
-      } else {
-        # Standard navbar item
-        # compute id and assign it to the div
-        thisId <- paste("tab", tabsetId, tabId, sep="-")
-        divTag$attribs$id <- thisId
-        tabId <<- tabId + 1
-
-        tabValue <- divTag$attribs$`data-value`
-
-        # create the a tag
-        aTag <- tags$a(href=paste("#", thisId, sep=""),
-                       `data-toggle` = "tab",
-                       `data-value` = tabValue)
-
-        # append optional icon
-        aTag <- appendIcon(aTag, divTag$attribs$`data-icon-class`)
-
-        # add the title
-        aTag <- tagAppendChild(aTag, divTag$attribs$title)
-
-        # create the li tag
-        liTag <- tags$li(aTag)
-
-        # If selected, set appropriate classes on li tag and div tag.
-        if (isSelected(divTag)) {
-          liTag$attribs$class <- "active"
-          divTag$attribs$class <- "tab-pane active"
-        }
-
-        divTag$attribs$title <- NULL
-
-        # append the elements to our lists
-        tabNavList <<- tagAppendChild(tabNavList, liTag)
-        tabContent <<- tagAppendChild(tabContent, divTag)
-      }
-    }
-
-    lapply(tabs, buildItem)
-    list(navList = tabNavList, content = tabContent)
+    divTag$attribs$id <- tabId
+    divTag$attribs$title <- NULL
   }
-
-
-  # Finally, actually invoke the functions to do the processing.
-  tabs <- findAndMarkSelected(tabs, selected)
-  build(tabs, ulClass, textFilter, id)
+  return(list(liTag = liTag, divTag = divTag))
 }
 
 
@@ -1486,8 +1489,9 @@ downloadLink <- function(outputId, label="Download", class=NULL, ...) {
 #' \code{\link{navbarPage}}.
 #'
 #' @param name Name of icon. Icons are drawn from the
-#'   \href{http://fontawesome.io/icons/}{Font Awesome} and
-#'   \href{http://getbootstrap.com/components/#glyphicons}{Glyphicons"}
+#'   \href{https://fontawesome.com/}{Font Awesome Free} (currently icons from
+#'   the v5.3.1 set are supported with the v4 naming convention) and
+#'   \href{http://getbootstrap.com/components/#glyphicons}{Glyphicons}
 #'   libraries. Note that the "fa-" and "glyphicon-" prefixes should not be used
 #'   in icon names (i.e. the "fa-calendar" icon should be referred to as
 #'   "calendar")
@@ -1504,10 +1508,6 @@ downloadLink <- function(outputId, label="Download", class=NULL, ...) {
 #'
 #'
 #' @examples
-#' icon("calendar")               # standard icon
-#' icon("calendar", "fa-3x")      # 3x normal size
-#' icon("cog", lib = "glyphicon") # From glyphicon library
-#'
 #' # add an icon to a submit button
 #' submitButton("Update View", icon = icon("refresh"))
 #'
@@ -1533,8 +1533,13 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
   # build the icon class (allow name to be null so that other functions
   # e.g. buildTabset can pass an explicit class value)
   iconClass <- ""
-  if (!is.null(name))
-    iconClass <- paste0(prefix, " ", prefix, "-", name)
+  if (!is.null(name)) {
+    prefix_class <- prefix
+    if (prefix_class == "fa" && name %in% font_awesome_brands) {
+      prefix_class <- "fab"
+    }
+    iconClass <- paste0(prefix_class, " ", prefix, "-", name)
+  }
   if (!is.null(class))
     iconClass <- paste(iconClass, class)
 
@@ -1543,12 +1548,15 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
   # font-awesome needs an additional dependency (glyphicon is in bootstrap)
   if (lib == "font-awesome") {
     htmlDependencies(iconTag) <- htmlDependency(
-      "font-awesome", "4.7.0", c(href="shared/font-awesome"),
-      stylesheet = "css/font-awesome.min.css"
+      "font-awesome", "5.3.1", "www/shared/fontawesome", package = "shiny",
+      stylesheet = c(
+        "css/all.min.css",
+        "css/v4-shims.min.css"
+      )
     )
   }
 
-  iconTag
+  htmltools::browsable(iconTag)
 }
 
 # Helper funtion to extract the class from an icon

R/cache-disk.R

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

R/cache-memory.R

@@ -0,0 +1,366 @@
+#' 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 \code{get()} and
+#' \code{set()} methods. Objects are automatically pruned from the cache
+#' according to the parameters \code{max_size}, \code{max_age}, \code{max_n},
+#' and \code{evict}.
+#'
+#' In a \code{MemoryCache}, R objects are stored directly in the cache; they are
+#' not \emph{not} serialized before being stored in the cache. This contrasts
+#' with other cache types, like \code{\link{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 \code{missing} and \code{exec_missing} parameters controls what happens
+#'   when \code{get()} is called with a key that is not in the cache (a cache
+#'   miss). The default behavior is to return a \code{\link{key_missing}}
+#'   object. This is a \emph{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 \code{\link{is.key_missing}} function. You can
+#'   also have \code{get()} return a different sentinel value, like \code{NULL}.
+#'   If you want to throw an error on a cache miss, you can do so by providing a
+#'   function for \code{missing} that takes one argument, the key, and also use
+#'   \code{exec_missing=TRUE}.
+#'
+#'   When the cache is created, you can supply a value for \code{missing}, which
+#'   sets the default value to be returned for missing values. It can also be
+#'   overridden when \code{get()} is called, by supplying a \code{missing}
+#'   argument. For example, if you use \code{cache$get("mykey", missing =
+#'   NULL)}, it will return \code{NULL} if the key is not in the cache.
+#'
+#'   If your cache is configured so that \code{get()} returns a sentinel value
+#'   to represent a cache miss, then \code{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 \code{get()} encounters missing
+#'   key. If the function returns a value, then \code{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 \code{get()} will not return a value.
+#'
+#'   To do this, pass a one-argument function to \code{missing}, and use
+#'   \code{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 \code{get()} should be wrapped with
+#'   \code{\link{tryCatch}()} to gracefully handle missing keys.
+#'
+#' @section Cache pruning:
+#'
+#'   Cache pruning occurs when \code{set()} is called, or it can be invoked
+#'   manually by calling \code{prune()}.
+#'
+#'   When a pruning occurs, if there are any objects that are older than
+#'   \code{max_age}, they will be removed.
+#'
+#'   The \code{max_size} and \code{max_n} parameters are applied to the cache as
+#'   a whole, in contrast to \code{max_age}, which is applied to each object
+#'   individually.
+#'
+#'   If the number of objects in the cache exceeds \code{max_n}, then objects
+#'   will be removed from the cache according to the eviction policy, which is
+#'   set with the \code{evict} parameter. Objects will be removed so that the
+#'   number of items is \code{max_n}.
+#'
+#'   If the size of the objects in the cache exceeds \code{max_size}, then
+#'   objects will be removed from the cache. Objects will be removed from the
+#'   cache so that the total size remains under \code{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
+#'   \code{get()} is called. If the target object is older than \code{max_age},
+#'   it will be removed and the cache will report it as a missing value.
+#'
+#' @section Eviction policies:
+#'
+#' If \code{max_n} or \code{max_size} are used, then objects will be removed
+#' from the cache according to an eviction policy. The available eviction
+#' policies are:
+#'
+#'   \describe{
+#'     \item{\code{"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{\code{"fifo"}}{
+#'       First-in-first-out. The oldest objects will be removed.
+#'     }
+#'   }
+#'
+#' @section Methods:
+#'
+#'  A disk cache object has the following methods:
+#'
+#'   \describe{
+#'     \item{\code{get(key, missing, exec_missing)}}{
+#'       Returns the value associated with \code{key}. If the key is not in the
+#'       cache, then it returns the value specified by \code{missing} or,
+#'       \code{missing} is a function and \code{exec_missing=TRUE}, then
+#'       executes \code{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{\code{set(key, value)}}{
+#'       Stores the \code{key}-\code{value} pair in the cache.
+#'     }
+#'     \item{\code{exists(key)}}{
+#'       Returns \code{TRUE} if the cache contains the key, otherwise
+#'       \code{FALSE}.
+#'     }
+#'     \item{\code{size()}}{
+#'       Returns the number of items currently in the cache.
+#'     }
+#'     \item{\code{keys()}}{
+#'       Returns a character vector of all keys currently in the cache.
+#'     }
+#'     \item{\code{reset()}}{
+#'       Clears all objects from the cache.
+#'     }
+#'     \item{\code{destroy()}}{
+#'       Clears all objects in the cache, and removes the cache directory from
+#'       disk.
+#'     }
+#'     \item{\code{prune()}}{
+#'       Prunes the cache, using the parameters specified by \code{max_size},
+#'       \code{max_age}, \code{max_n}, and \code{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        <- new.env(parent = emptyenv())
+      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[[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[[key]] <- list(
+        key = key,
+        value = value,
+        size = size,
+        mtime = time,
+        atime = time
+      )
+      self$prune()
+      invisible(self)
+    },
+
+    exists = function(key) {
+      validate_key(key)
+      # Faster than `exists(key, envir = private$cache, inherits = FALSE)
+      !is.null(private$cache[[key]])
+    },
+
+    keys = function() {
+      ls(private$cache, sorted = FALSE)  # Faster with sorted=FALSE
+    },
+
+    remove = function(key) {
+      private$log(paste0('remove: key "', key, '"'))
+      validate_key(key)
+      rm(list = key, envir = private$cache)
+      invisible(self)
+    },
+
+    reset = function() {
+      private$log(paste0('reset'))
+      rm(list = self$keys(), envir = private$cache)
+      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 = ", ")))
+          rm(list = info$key[rm_idx], envir = private$cache)
+          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 = ", ")))
+        rm(list = info$key[rm_idx], envir = private$cache)
+        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 = ", ")))
+        rm(list = info$key[rm_idx], envir = private$cache)
+        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[[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)
+      }
+    },
+
+    object_info = function() {
+      keys <- ls(private$cache, sorted = FALSE)
+      data.frame(
+        key   = keys,
+        size  = vapply(keys, function(key) private$cache[[key]]$size,  0),
+        mtime = vapply(keys, function(key) private$cache[[key]]$mtime, 0),
+        atime = vapply(keys, function(key) private$cache[[key]]$atime, 0),
+        stringsAsFactors = FALSE
+      )
+    },
+
+    log = function(text) {
+      if (is.null(private$logfile)) return()
+
+      text <- paste0(format(Sys.time(), "[%Y-%m-%d %H:%M:%OS3] MemoryCache "), text)
+      writeLines(text, private$logfile)
+    }
+  )
+)

R/cache-utils.R

@@ -0,0 +1,33 @@
+#' A Key Missing object
+#'
+#' A \code{key_missing} object represents a cache miss.
+#'
+#' @param x An object to test.
+#'
+#' @seealso \code{\link{diskCache}}, \code{\link{memoryCache}}.
+#'
+#' @export
+key_missing <- function() {
+  structure(list(), class = "key_missing")
+}
+
+#' @rdname key_missing
+#' @export
+is.key_missing <- function(x) {
+  inherits(x, "key_missing")
+}
+
+#' @export
+print.key_missing <- function(x, ...) {
+  cat("<Key Missing>\n")
+}
+
+
+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/conditions.R

@@ -89,6 +89,23 @@ getLocs <- function(calls) {
   }, 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 \code{captureStackTraces} runs the given \code{expr} and if any
 #'   \emph{uncaught} errors occur, annotates them with stack trace info for use
 #'   by \code{printError} and \code{printStackTrace}. It is not necessary to use
@@ -105,17 +122,93 @@ getLocs <- function(calls) {
 #' @rdname stacktrace
 #' @export
 captureStackTraces <- function(expr) {
-  withCallingHandlers(expr,
-    error = function(e) {
-      if (is.null(attr(e, "stack.trace", exact = TRUE))) {
-        calls <- sys.calls()
-        attr(e, "stack.trace") <- calls
-        stop(e)
-      }
-    }
+  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 \code{withLogErrors} captures stack traces and logs errors that
 #'   occur in \code{expr}, but does allow errors to propagate beyond this point
 #'   (i.e. it doesn't catch the error). The same caveats that apply to
@@ -128,7 +221,22 @@ withLogErrors <- function(expr,
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   withCallingHandlers(
-    captureStackTraces(expr),
+    {
+      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()
@@ -158,11 +266,11 @@ withLogErrors <- function(expr,
 printError <- function(cond,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s",
+  
+  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s", 
     getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
+  
   printStackTrace(cond, full = full, offset = offset)
-  invisible()
 }
 
 #' @rdname stacktrace
@@ -171,24 +279,85 @@ printStackTrace <- function(cond,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
-  stackTrace <- attr(cond, "stack.trace", exact = TRUE)
-  tryCatch(
-    if (!is.null(stackTrace)) {
-      message(paste0(
-        "Stack trace (innermost first):\n",
-        paste0(collapse = "\n",
-          formatStackTrace(stackTrace, full = full, offset = offset,
-            indent = "    ")
-        )
-      ))
-    } else {
-      message("No stack trace available")
-    },
-
-    error = function(cond) {
-      warning("Failed to write stack trace: ", cond)
-    }
+  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()
 }
 
@@ -196,12 +365,17 @@ printStackTrace <- function(cond,
 #'   from \code{conditionStackTrace(cond)}) and returns a data frame with one
 #'   row for each stack frame and the columns \code{num} (stack frame number),
 #'   \code{call} (a function name or similar), and \code{loc} (source file path
-#'   and line number, if available).
+#'   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) {
@@ -241,7 +415,11 @@ extractStackTrace <- function(calls,
     score <- rep.int(0, length(callnames))
     score[callnames == "..stacktraceoff.."] <- -1
     score[callnames == "..stacktraceon.."] <- 1
-    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff.."))
+    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]
 
@@ -253,12 +431,115 @@ extractStackTrace <- function(calls,
     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 \code{formatStackTrace} is similar to \code{extractStackTrace}, but
-#'   it returns a preformatted character vector instead of a data frame.
+#'   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
@@ -266,6 +547,10 @@ 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))
@@ -276,8 +561,14 @@ formatStackTrace <- function(calls, indent = "    ",
     indent,
     formatC(st$num, width = width),
     ": ",
-    st$call,
-    st$loc
+    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)
+    })
   )
 }
 
@@ -332,3 +623,5 @@ conditionStackTrace <- function(cond) {
 #' @rdname stacktrace
 #' @export
 ..stacktraceoff.. <- function(expr) expr
+
+..stacktracefloor.. <- function(expr) expr

R/fileupload.R

@@ -20,6 +20,18 @@
 # 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',
   portable = FALSE,
@@ -52,8 +64,9 @@ FileUploadOperation <- R6Class(
       .currentFileInfo <<- file
       .pendingFileInfos <<- tail(.pendingFileInfos, -1)
 
-      filename <- file.path(.dir, as.character(length(.files$name)))
-      row <- data.frame(name=file$name, size=file$size, type=file$type,
+      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,
                         datapath=filename, stringsAsFactors=FALSE)
 
       if (length(.files$name) == 0)

R/font-awesome.R

@@ -0,0 +1,75 @@
+font_awesome_brands <- c(
+  "500px", "accessible-icon", "accusoft", "adn", "adversal",
+  "affiliatetheme", "algolia", "alipay", "amazon", "amazon-pay",
+  "amilia", "android", "angellist", "angrycreative", "angular",
+  "app-store", "app-store-ios", "apper", "apple", "apple-pay",
+  "asymmetrik", "audible", "autoprefixer", "avianex", "aviato",
+  "aws", "bandcamp", "behance", "behance-square", "bimobject",
+  "bitbucket", "bitcoin", "bity", "black-tie", "blackberry", "blogger",
+  "blogger-b", "bluetooth", "bluetooth-b", "btc", "buromobelexperte",
+  "buysellads", "cc-amazon-pay", "cc-amex", "cc-apple-pay", "cc-diners-club",
+  "cc-discover", "cc-jcb", "cc-mastercard", "cc-paypal", "cc-stripe",
+  "cc-visa", "centercode", "chrome", "cloudscale", "cloudsmith",
+  "cloudversify", "codepen", "codiepie", "connectdevelop", "contao",
+  "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", "css3", "css3-alt", "cuttlefish", "d-and-d",
+  "dashcube", "delicious", "deploydog", "deskpro", "deviantart",
+  "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", "expeditedssl",
+  "facebook", "facebook-f", "facebook-messenger", "facebook-square",
+  "firefox", "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-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", "imdb", "instagram", "internet-explorer",
+  "ioxhost", "itunes", "itunes-note", "java", "jedi-order", "jenkins",
+  "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", "medapps", "medium",
+  "medium-m", "medrt", "meetup", "megaport", "microsoft", "mix",
+  "mixcloud", "mizuni", "modx", "monero", "napster", "neos", "nimblr",
+  "nintendo-switch", "node", "node-js", "npm", "ns8", "nutritionix",
+  "odnoklassniki", "odnoklassniki-square", "old-republic", "opencart",
+  "openid", "opera", "optin-monster", "osi", "page4", "pagelines",
+  "palfed", "patreon", "paypal", "periscope", "phabricator", "phoenix-framework",
+  "phoenix-squadron", "php", "pied-piper", "pied-piper-alt", "pied-piper-hat",
+  "pied-piper-pp", "pinterest", "pinterest-p", "pinterest-square",
+  "playstation", "product-hunt", "pushed", "python", "qq", "quinscape",
+  "quora", "r-project", "ravelry", "react", "readme", "rebel",
+  "red-river", "reddit", "reddit-alien", "reddit-square", "rendact",
+  "renren", "replyd", "researchgate", "resolving", "rev", "rocketchat",
+  "rockrms", "safari", "sass", "schlix", "scribd", "searchengin",
+  "sellcast", "sellsy", "servicestack", "shirtsinbulk", "shopware",
+  "simplybuilt", "sistrix", "sith", "skyatlas", "skype", "slack",
+  "slack-hash", "slideshare", "snapchat", "snapchat-ghost", "snapchat-square",
+  "soundcloud", "speakap", "spotify", "squarespace", "stack-exchange",
+  "stack-overflow", "staylinked", "steam", "steam-square", "steam-symbol",
+  "sticker-mule", "strava", "stripe", "stripe-s", "studiovinari",
+  "stumbleupon", "stumbleupon-circle", "superpowers", "supple",
+  "teamspeak", "telegram", "telegram-plane", "tencent-weibo", "the-red-yeti",
+  "themeco", "themeisle", "trade-federation", "trello", "tripadvisor",
+  "tumblr", "tumblr-square", "twitch", "twitter", "twitter-square",
+  "typo3", "uber", "uikit", "uniregistry", "untappd", "usb", "ussunnah",
+  "vaadin", "viacoin", "viadeo", "viadeo-square", "viber", "vimeo",
+  "vimeo-square", "vimeo-v", "vine", "vk", "vnv", "vuejs", "weebly",
+  "weibo", "weixin", "whatsapp", "whatsapp-square", "whmcs", "wikipedia-w",
+  "windows", "wix", "wolf-pack-battalion", "wordpress", "wordpress-simple",
+  "wpbeginner", "wpexplorer", "wpforms", "xbox", "xing", "xing-square",
+  "y-combinator", "yahoo", "yandex", "yandex-international", "yelp",
+  "yoast", "youtube", "youtube-square", "zhihu"
+)

R/globals.R

@@ -5,7 +5,7 @@
   # 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(reinitializeSeed())
+  withPrivateSeed(set.seed(NULL))
 }
 
 .onAttach <- function(libname, pkgname) {

R/graph.R

@@ -1,13 +1,58 @@
-writeReactLog <- function(file=stdout(), sessionToken = NULL) {
-  log <- .graphStack$as_list()
-  if (!is.null(sessionToken)) {
-    log <- Filter(function(x) {
-      is.null(x$session) || identical(x$session, sessionToken)
-    }, log)
-  }
-  cat(toJSON(log, pretty=TRUE), file=file)
+is_installed <- function(package, version) {
+  installedVersion <- tryCatch(utils::packageVersion(package), error = function(e) NA)
+  !is.na(installedVersion) && installedVersion >= version
 }
 
+# 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, location) {
+
+  if (is_installed(package, version)) {
+    return()
+  }
+
+  missing_location <- missing(location)
+  msg <- paste0(
+    sQuote(package),
+    if (is.na(version)) "" else paste0("(>= ", version, ")"),
+    " must be installed for this functionality.",
+    if (!missing_location)
+      paste0(
+        "\nPlease install the missing package: \n",
+        "  source(\"https://install-github.me/", location, "\")"
+      )
+  )
+
+  if (interactive() && missing_location) {
+    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)
+}
+
+
 #' Reactive Log Visualizer
 #'
 #' Provides an interactive browser-based tool for visualizing reactive
@@ -30,88 +75,499 @@ writeReactLog <- function(file=stdout(), sessionToken = NULL) {
 #'
 #' 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 \code{showReactLog} function, which will
+#' application--you can run the \code{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 \code{showReactLog()} explicitly.
+#' call \code{reactlogShow()} explicitly.
 #'
 #' For security and performance reasons, do not enable
 #' \code{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.
 #'
-#' @param time A boolean that specifies whether or not to display the
-#' time that each reactive.
+#' @name reactlog
+NULL
+
+
+#' @describeIn reactlog Return a list of reactive information.  Can be used in conjunction with
+#'   \code{reactlog::\link[reactlog]{reactlog_show}} to later display the reactlog graph.
 #' @export
+reactlog <- function() {
+  rLog$asList()
+}
+
+#' @describeIn reactlog Display a full reactlog graph for all sessions.
+#' @inheritParams reactlog::reactlog_show
+#' @export
+reactlogShow <- function(time = TRUE) {
+  check_reactlog()
+  reactlog::reactlog_show(reactlog(), time = time)
+}
+#' @describeIn reactlog This function is deprecated. You should use \code{\link{reactlogShow}}
+#' @export
+# legacy purposes
 showReactLog <- function(time = TRUE) {
-  utils::browseURL(renderReactLog(time = as.logical(time)))
+  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()
 }
 
-renderReactLog <- function(sessionToken = NULL, time = TRUE) {
-  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, sessionToken)
-  cat('\n', file=tc)
-  flush(tc)
-  html <- sub('__DATA__', paste(textConnectionValue(tc), collapse='\r\n'), html, fixed=TRUE)
-  html <- sub('__TIME__', paste0('"', time, '"'), html, fixed=TRUE)
-  file <- tempfile(fileext = '.html')
-  writeLines(html, file)
-  return(file)
+# 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]]
 
-.graphAppend <- function(logEntry, domain = getDefaultReactiveDomain()) {
-  if (isTRUE(getOption('shiny.reactlog'))) {
-    sessionToken <- if (is.null(domain)) NULL else domain$token
-    .graphStack$push(c(logEntry, list(
-      session = sessionToken,
-      time = as.numeric(Sys.time())
-    )))
+  reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
+  if (length(reactlog_info) == 0) {
+    stop("reactlog can not be found in shiny DESCRIPTION file")
   }
 
-  if (!is.null(domain)) {
-    domain$reactlog(logEntry)
-  }
+  reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
+  reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
+  reactlog_info <- sub("^[>= ]*", "", reactlog_info)
+
+  package_version(reactlog_info)
 }
 
-.graphDependsOn <- function(id, label) {
-  .graphAppend(list(action='dep', id=id, dependsOn=label))
-}
 
-.graphDependsOnId <- function(id, dependee) {
-  .graphAppend(list(action='depId', id=id, dependsOn=dependee))
-}
+RLog <- R6Class(
+  "RLog",
+  portable = FALSE,
+  private = list(
+    option = "shiny.reactlog",
+    msgOption = "shiny.reactlog.console",
 
-.graphCreateContext <- function(id, label, type, prevId, domain) {
-  .graphAppend(list(
-    action='ctx', id=id, label=paste(label, collapse='\n'),
-    srcref=as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile"),
-    type=type, prevId=prevId
-  ), domain = domain)
-}
+    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>",
 
-.graphEnterContext <- function(id) {
-  .graphAppend(list(action='enter', id=id))
-}
+    noReactIdLabel = "NoCtxReactId",
+    noReactId = reactIdStr("NoCtxReactId"),
+    dummyReactIdLabel = "DummyReactId",
+    dummyReactId = reactIdStr("DummyReactId"),
 
-.graphExitContext <- function(id) {
-  .graphAppend(list(action='exit', id=id))
-}
+    asList = function() {
+      ret <- self$logStack$as_list()
+      attr(ret, "version") <- "1"
+      ret
+    },
 
-.graphValueChange <- function(label, value) {
-  .graphAppend(list(
-    action = 'valueChange',
-    id = label,
-    value = paste(utils::capture.output(utils::str(value)), collapse='\n')
-  ))
-}
+    ctxIdStr = function(ctxId) {
+      if (is.null(ctxId) || identical(ctxId, "")) return(NULL)
+      paste0("ctx", ctxId)
+    },
+    namesIdStr = function(reactId) {
+      paste0("names(", reactId, ")")
+    },
+    asListIdStr = function(reactId) {
+      paste0("as.list(", reactId, ")")
+    },
+    asListAllIdStr = function(reactId) {
+      paste0("as.list(", reactId, ", all.names = TRUE)")
+    },
+    keyIdStr = function(reactId, key) {
+      paste0(reactId, "$", key)
+    },
 
-.graphInvalidate <- function(id, domain) {
-  .graphAppend(list(action='invalidate', id=id), domain)
-}
+    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
-.graphStack <- Stack$new()
+rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")

R/html-deps.R

@@ -6,13 +6,18 @@
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named, then
-#'   \code{href} and/or \code{file} names must be present.
+#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named,
+#'   then \code{href} and/or \code{file} names must be present.
+#' @param scrubFile If TRUE (the default), remove \code{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
+#'   \code{src$file}. Setting it to FALSE should be needed only in very unusual
+#'   cases.
 #'
 #' @return A single HTML dependency object that has an \code{href}-named element
 #'   in its \code{src}.
 #' @export
-createWebDependency <- function(dependency) {
+createWebDependency <- function(dependency, scrubFile = TRUE) {
   if (is.null(dependency))
     return(NULL)
 
@@ -25,6 +30,10 @@ createWebDependency <- function(dependency) {
     dependency$src$href <- prefix
   }
 
+  # Don't leak local file path to client
+  if (scrubFile)
+    dependency$src$file <- NULL
+
   return(dependency)
 }
 

R/image-interact.R

@@ -86,6 +86,8 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
   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")
     # Extract data values from the data frame
     x <- asNumber(df[[xvar]])
     keep_rows <- keep_rows & (x >= brush$xmin & x <= brush$xmax)
@@ -93,6 +95,8 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
   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")
     y <- asNumber(df[[yvar]])
     keep_rows <- keep_rows & (y >= brush$ymin & y <= brush$ymax)
   }
@@ -118,6 +122,19 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ 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
@@ -143,6 +160,19 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
 #  $ 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"
@@ -245,18 +275,29 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
   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]])
   y <- asNumber(df[[yvar]])
 
-  # Get the pixel coordinates of the point
-  coordPx <- scaleCoords(coordinfo$x, coordinfo$y, coordinfo)
+  # Get the coordinates of the point (in img pixel coordinates)
+  point_img <- coordinfo$coords_img
 
-  # Get pixel coordinates of data points
-  dataPx <- scaleCoords(x, y, coordinfo)
+  # Get coordinates of data points (in img pixel coordinates)
+  data_img <- scaleCoords(x, y, coordinfo)
 
-  # Distances of data points to coordPx
-  dists <- sqrt((dataPx$x - coordPx$x) ^ 2 + (dataPx$y - coordPx$y) ^ 2)
+  # 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
@@ -298,50 +339,68 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 # 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
-#  $ mapping: Named list()
-#  $ domain :List of 4
+#  $ 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
+#  $ range     :List of 4
 #   ..$ left  : num 58
 #   ..$ right : num 429
 #   ..$ bottom: num 226
 #   ..$ top   : num 58
-#  $ log    :List of 2
+#  $ log       :List of 2
 #   ..$ x: NULL
 #   ..$ y: NULL
-#  $ .nonce : num 0.343
+#  $ .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
-#  $ panelvar1: int 6
-#  $ panelvar2: int 0
-#  $ mapping  :List of 4
+#  $ 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
+#  $ domain    :List of 4
 #   ..$ left  : num 1.32
 #   ..$ right : num 5.62
 #   ..$ bottom: num 9.22
 #   ..$ top   : num 35.1
-#  $ range    :List of 4
+#  $ range     :List of 4
 #   ..$ left  : num 172
 #   ..$ right : num 300
 #   ..$ bottom: num 144
 #   ..$ top   : num 28.5
-#  $ log      :List of 2
+#  $ log       :List of 2
 #   ..$ x: NULL
 #   ..$ y: NULL
-#  $ .nonce   : num 0.603
+#  $ .nonce    : num 0.603
 
 
 

R/imageutils.R

@@ -1,3 +1,33 @@
+startPNG <- function(filename, width, height, res, ...) {
+  # 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 <- grDevices::png
+  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
+      nchar(system.file(package = "Cairo"))) {
+    pngfun <- Cairo::CairoPNG
+  } else {
+    pngfun <- grDevices::png
+  }
+
+  pngfun(filename=filename, width=width, height=height, res=res, ...)
+  # 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
@@ -28,35 +58,44 @@
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
-  # 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 <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
-             nchar(system.file(package = "Cairo"))) {
-    pngfun <- Cairo::CairoPNG
-  } else {
-    pngfun <- grDevices::png
-  }
-
-  pngfun(filename=filename, width=width, height=height, res=res, ...)
-  # 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)
-  )
-
-  dv <- grDevices::dev.cur()
+  dv <- startPNG(filename, width, height, res, ...)
   on.exit(grDevices::dev.off(dv), add = TRUE)
   func()
 
   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-checkboxgroup.R

@@ -8,7 +8,8 @@
 #' @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 \code{choiceNames} and \code{choiceValues}
-#'   must not be provided, and vice-versa.
+#'   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 \code{TRUE}, render the choices inline (i.e. horizontally)
 #' @param choiceNames,choiceValues List of names and values, respectively,

R/input-date.R

@@ -41,6 +41,12 @@
 #'   "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 \code{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 \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}
@@ -68,21 +74,32 @@
 #'
 #'   # Start with decade view instead of default month view
 #'   dateInput("date6", "Date:",
-#'             startview = "decade")
+#'             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) { })
 #' }
 #' @export
 dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
-  format = "yyyy-mm-dd", startview = "month", weekstart = 0, language = "en",
-  width = NULL) {
+  format = "yyyy-mm-dd", startview = "month", weekstart = 0,
+  language = "en", width = NULL, autoclose = TRUE,
+  datesdisabled = NULL, daysofweekdisabled = NULL) {
 
   # If value is a date object, convert it to a string with yyyy-mm-dd format
   # Same for min and max
   if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
+  if (inherits(datesdisabled, "Date")) {
+      datesdisabled <- format(datesdisabled,   "%Y-%m-%d")
+  }
 
   value <- restoreInput(id = inputId, default = value)
 
@@ -99,7 +116,13 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
                `data-date-start-view` = startview,
                `data-min-date` = min,
                `data-max-date` = max,
-               `data-initial-date` = value
+               `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
   )

R/input-daterange.R

@@ -73,7 +73,8 @@
 #' @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) {
+    weekstart = 0, language = "en", separator = " to ", width = NULL,
+    autoclose = TRUE) {
 
   # If start and end are date objects, convert to a string with yyyy-mm-dd format
   # Same for min and max
@@ -103,7 +104,8 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           `data-date-start-view` = startview,
           `data-min-date` = min,
           `data-max-date` = max,
-          `data-initial-date` = start
+          `data-initial-date` = start,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
         ),
         span(class = "input-group-addon", separator),
         tags$input(
@@ -115,7 +117,8 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           `data-date-start-view` = startview,
           `data-min-date` = min,
           `data-max-date` = max,
-          `data-initial-date` = end
+          `data-initial-date` = end,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
         )
       )
     ),

R/input-radiobuttons.R

@@ -3,30 +3,30 @@
 #' 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
-#' \code{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 \code{c("None selected"
-#' = "")}.
+#' the radio buttons to have no options selected by using \code{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 \code{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 \code{choiceNames} and \code{choiceValues}
-#'   must not be provided, and vice-versa.
-#' @param selected The initially selected value (if not specified then
-#'   defaults to the first value)
+#'   must not be provided, and vice-versa. The values should be strings; other
+#'   types (such as logicals and numbers) will be coerced to strings.
+#' @param selected The initially selected value (if not specified then defaults
+#'   to the first value)
 #' @param inline If \code{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, \code{choiceNames} and \code{choiceValues}
-#'   must have the same length). If either of these arguments is
-#'   provided, then the other \emph{must} be provided and \code{choices}
-#'   \emph{must not} be provided. The advantage of using both of these over
-#'   a named list for \code{choices} is that \code{choiceNames} allows any
-#'   type of UI object to be passed through (tag objects, icons, HTML code,
-#'   ...), instead of just simple text. See Examples.
+#' @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, \code{choiceNames} and \code{choiceValues} must have the same
+#'   length). If either of these arguments is provided, then the other
+#'   \emph{must} be provided and \code{choices} \emph{must not} be provided. The
+#'   advantage of using both of these over a named list for \code{choices} is
+#'   that \code{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 \code{\link{updateRadioButtons}}

R/input-select.R

@@ -5,7 +5,7 @@
 #'
 #' By default, \code{selectInput()} and \code{selectizeInput()} use the
 #' JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
+#' (\url{https://github.com/selectize/selectize.js}) instead of the basic
 #' select input element. To use the standard HTML select input element, use
 #' \code{selectInput()} with \code{selectize=FALSE}.
 #'
@@ -33,7 +33,7 @@
 #' @return A select list control that can be added to a UI definition.
 #'
 #' @family input elements
-#' @seealso \code{\link{updateSelectInput}}
+#' @seealso \code{\link{updateSelectInput}} \code{\link{varSelectInput}}
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -59,9 +59,9 @@
 #' shinyApp(
 #'   ui = fluidPage(
 #'     selectInput("state", "Choose a state:",
-#'       list(`East Coast` = c("NY", "NJ", "CT"),
-#'            `West Coast` = c("WA", "OR", "CA"),
-#'            `Midwest` = c("MN", "WI", "IA"))
+#'       list(`East Coast` = list("NY", "NJ", "CT"),
+#'            `West Coast` = list("WA", "OR", "CA"),
+#'            `Midwest` = list("MN", "WI", "IA"))
 #'     ),
 #'     textOutput("result")
 #'   ),
@@ -212,3 +212,135 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   attachDependencies(select, selectizeDep)
 }
+
+
+
+
+
+
+
+
+#' 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.
+#'
+#' The resulting server \code{input} value will be returned as:
+#' \itemize{
+#'   \item a symbol if \code{multiple = FALSE}.  The \code{input} value should be
+#'         used with rlang's \code{\link[rlang]{!!}}. For example,
+#'         \code{ggplot2::aes(!!input$variable)}.
+#'   \item a list of symbols if \code{multiple = TRUE}. The \code{input} value
+#'         should be used with rlang's \code{\link[rlang]{!!!}} to expand
+#'         the symbol list as individual arguments. For example,
+#'         \code{dplyr::select(mtcars, !!!input$variabls)} which is
+#'         equivalent to \code{dplyr::select(mtcars, !!input$variabls[[1]], !!input$variabls[[2]], ..., !!input$variabls[[length(input$variabls)]])}.
+#' }
+#'
+#' By default, \code{varSelectInput()} and \code{selectizeInput()} use the
+#' JavaScript library \pkg{selectize.js}
+#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
+#' select input element. To use the standard HTML select input element, use
+#' \code{selectInput()} with \code{selectize=FALSE}.
+#'
+#' @inheritParams selectInput
+#' @param data A data frame. Used to retrieve the column names as choices for a \code{\link{selectInput}}
+#' @return A variable select list control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateSelectInput}}
+#' @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 \code{varSelectInput()}.
+#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#'   for possible options (character option values inside \code{\link[base]{I}()} will
+#'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
+#'   for details).
+#' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @note The variable selectize input created from \code{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
+#'   \code{selectInput(..., selectize = TRUE)} will ignore the empty string
+#'   value when it is a single choice input and the empty string is not in the
+#'   \code{choices} argument. This is to keep compatibility with
+#'   \code{selectInput(..., selectize = FALSE)}.
+#' @export
+varSelectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
+  selectizeIt(
+    inputId,
+    varSelectInput(inputId, ..., selectize = FALSE, width = width),
+    options
+  )
+}

R/input-slider.R

@@ -86,40 +86,25 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
-  value <- restoreInput(id = inputId, default = value)
+  dataType <- getSliderType(min, max, value)
 
-  # 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)) {
-      step <- pretty(c(min, max), n = 100)
-      step[2] - step[1]
-    } else {
-      1
-    }
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if (inherits(min, "Date")) {
-    if (!inherits(max, "Date") || !inherits(value, "Date"))
-      stop("`min`, `max`, and `value must all be Date or non-Date objects")
-    dataType <- "date"
+  # 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.null(timeFormat))
-      timeFormat <- "%F"
-
-  } else if (inherits(min, "POSIXt")) {
-    if (!inherits(max, "POSIXt") || !inherits(value, "POSIXt"))
-      stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
-    dataType <- "datetime"
-
-    if (is.null(timeFormat))
-      timeFormat <- "%F %T"
-
-  } else {
-    dataType <- "number"
+  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)
@@ -169,7 +154,6 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
-    `data-keyboard-step` = step / (max - min) * 100,
     # 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,
@@ -238,6 +222,34 @@ hasDecimals <- function(value) {
   return (!identical(value, truncatedValue))
 }
 
+
+# If step is NULL, use heuristic to set the step size.
+findStepSize <- function(min, max, step) {
+  if (!is.null(step)) return(step)
+
+  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.

R/input-utils.R

@@ -73,10 +73,10 @@ generateOptions <- function(inputId, selected, inline, type = 'checkbox',
       # checkbox-inline.
       if (inline) {
         tags$label(class = paste0(type, "-inline"), inputTag,
-                   tags$span(pd$html, pd$dep))
+                   tags$span(pd$html, pd$deps))
       } else {
         tags$div(class = type, tags$label(inputTag,
-                 tags$span(pd$html, pd$dep)))
+                 tags$span(pd$html, pd$deps)))
       }
     },
     SIMPLIFY = FALSE, USE.NAMES = FALSE

R/insert-tab.R

@@ -0,0 +1,325 @@
+#' Dynamically insert/remove a tabPanel
+#'
+#' Dynamically insert or remove a \code{\link{tabPanel}} (or a
+#' \code{\link{navbarMenu}}) from an existing \code{\link{tabsetPanel}},
+#' \code{\link{navlistPanel}} or \code{\link{navbarPage}}.
+#'
+#' When you want to insert a new tab before or after an existing tab, you
+#' should use \code{insertTab}. When you want to prepend a tab (i.e. add a
+#' tab to the beginning of the \code{tabsetPanel}), use \code{prependTab}.
+#' When you want to append a tab (i.e. add a tab to the end of the
+#' \code{tabsetPanel}), use \code{appendTab}.
+#'
+#' For \code{navbarPage}, you can insert/remove conventional
+#' \code{tabPanel}s (whether at the top level or nested inside a
+#' \code{navbarMenu}), as well as an entire \code{\link{navbarMenu}}.
+#' For the latter case, \code{target} should be the \code{menuName} that
+#' you gave your \code{navbarMenu} when you first created it (by default,
+#' this is equal to the value of the \code{title} argument).
+#'
+#' @param inputId The \code{id} of the \code{tabsetPanel} (or
+#'   \code{navlistPanel} or \code{navbarPage}) into which \code{tab} will
+#'   be inserted/removed.
+#'
+#' @param tab The item to be added (must be created with \code{tabPanel},
+#'   or with \code{navbarMenu}).
+#'
+#' @param target If inserting: the \code{value} of an existing
+#'   \code{tabPanel}, next to which \code{tab} will be added.
+#'   If removing: the \code{value} of the \code{tabPanel} that
+#'   you want to remove. See Details if you want to insert next to/remove
+#'   an entire \code{navbarMenu} instead.
+#'
+#' @param position Should \code{tab} be added before or after the
+#'   \code{target} tab?
+#'
+#' @param select Should \code{tab} be selected upon being inserted?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso \code{\link{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) \code{tab} to the beginning (or end) of an
+#'   existing \code{\link{navbarMenu}} (which must itself be part of
+#'   an existing \code{\link{navbarPage}}). In this case, this argument
+#'   should be the \code{menuName} that you gave your \code{navbarMenu}
+#'   when you first created it (by default, this is equal to the value
+#'   of the \code{title} argument). Note that you still need to set the
+#'   \code{inputId} argument to whatever the \code{id} of the parent
+#'   \code{navbarPage} is. If \code{menuName} is left as \code{NULL},
+#'   \code{tab} will be prepended (or appended) to whatever
+#'   \code{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 \code{\link{tabPanel}} (or a
+#' \code{\link{navbarMenu}})from an existing \code{\link{tabsetPanel}},
+#' \code{\link{navlistPanel}} or \code{\link{navbarPage}}.
+#'
+#' For \code{navbarPage}, you can hide/show conventional
+#' \code{tabPanel}s (whether at the top level or nested inside a
+#' \code{navbarMenu}), as well as an entire \code{\link{navbarMenu}}.
+#' For the latter case, \code{target} should be the \code{menuName} that
+#' you gave your \code{navbarMenu} when you first created it (by default,
+#' this is equal to the value of the \code{title} argument).
+#'
+#' @param inputId The \code{id} of the \code{tabsetPanel} (or
+#'   \code{navlistPanel} or \code{navbarPage}) in which to find
+#'   \code{target}.
+#'
+#' @param target The \code{value} of the \code{tabPanel} to be
+#'   hidden/shown. See Details if you want to hide/show an entire
+#'   \code{navbarMenu} instead.
+#'
+#' @param select Should \code{target} be selected upon being shown?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso \code{\link{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/middleware-shiny.R

@@ -2,19 +2,43 @@
 NULL
 
 reactLogHandler <- function(req) {
-  if (!identical(req$PATH_INFO, '/reactlog'))
-    return(NULL)
-
-  if (!isTRUE(getOption('shiny.reactlog'))) {
+  if (! rLog$isLogging()) {
     return(NULL)
   }
 
-  sessionToken <- parseQueryString(req$QUERY_STRING)$s
+  if (identical(req$PATH_INFO, "/reactlog/mark")) {
+    sessionToken <- parseQueryString(req$QUERY_STRING)$s
+    shinysession <- appsByToken$get(sessionToken)
 
-  return(httpResponse(
-    status=200,
-    content=list(file=renderReactLog(sessionToken), owned=TRUE)
-  ))
+    # 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 {
+    return(NULL)
+  }
 }
 
 sessionHandler <- function(req) {

R/middleware.R

@@ -321,21 +321,20 @@ HandlerManager <- R6Class("HandlerManager",
               }
             )
           },
-          getOption('shiny.sharedSecret')
+          loadSharedSecret()
         ),
         onWSOpen = function(ws) {
           return(wsHandlers$invoke(ws))
         }
       )
     },
-    .httpServer = function(handler, sharedSecret) {
+    .httpServer = function(handler, checkSharedSecret) {
       filter <- getOption('shiny.http.response.filter')
       if (is.null(filter))
         filter <- function(req, response) response
 
       function(req) {
-        if (!is.null(sharedSecret)
-          && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
+        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')))
@@ -351,38 +350,72 @@ HandlerManager <- R6Class("HandlerManager",
         }
 
         response <- handler(req)
-        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
+        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
+              ))
+            }
 
-          response <- filter(req, response)
-          if (head_request) {
-            headers$`Content-Length` <- nchar(response$content, type = "bytes")
-            return(list(
-              status = response$status,
-              body = "",
-              headers = headers
-            ))
           } else {
-            return(list(
-              status = response$status,
-              body = response$content,
-              headers = headers
-            ))
+            # Assume it's a Rook-compatible response
+            return(response)
           }
-
-        } else {
-          # Assume it's a Rook-compatible response
-          return(response)
-        }
+        })
       }
     }
   )
 )
 
+# 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
 #

R/modules.R

@@ -26,6 +26,11 @@ createSessionProxy <- function(parentSession, ...) {
 
 #' @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.")
 }
 

R/react.R

@@ -1,38 +1,77 @@
+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',
   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,
 
-    initialize = function(domain, label='', type='other', prevId='') {
-      id <<- .getReactiveEnvironment()$nextId()
+    initialize = function(
+      domain, label='', type='other', prevId='',
+      reactId = rLog$noReactId,
+      id = .getReactiveEnvironment()$nextId() # For dummy context
+    ) {
+      id <<- id
       .label <<- label
       .domain <<- domain
-      .graphCreateContext(id, label, type, prevId, domain)
+      .pid <<- processId()
+      .reactId <<- reactId
+      .reactType <<- type
+      rLog$createContext(id, label, type, prevId, domain)
     },
     run = function(func) {
       "Run the provided function under this context."
-      withReactiveDomain(.domain, {
-        env <- .getReactiveEnvironment()
-        .graphEnterContext(id)
-        on.exit(.graphExitContext(id), add = TRUE)
-        env$runWith(self, func)
+
+      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)
+        })
       })
     },
     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
 
-      .graphInvalidate(id, .domain)
+      rLog$invalidateStart(.reactId, id, .reactType, .domain)
+      on.exit(rLog$invalidateEnd(.reactId, id, .reactType, .domain), add = TRUE)
+
       lapply(.invalidateCallbacks, function(func) {
         func()
       })
@@ -43,6 +82,11 @@ Context <- R6Class(
       "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
@@ -52,9 +96,6 @@ Context <- R6Class(
     addPendingFlush = function(priority) {
       "Tell the reactive environment that this context should be flushed the
         next time flushReact() called."
-      if (!is.null(.domain)) {
-        .domain$incrementBusyCount()
-      }
       .getReactiveEnvironment()$addPendingFlush(self, priority)
     },
     onFlush = function(func) {
@@ -64,12 +105,6 @@ Context <- R6Class(
     executeFlushCallbacks = function() {
       "For internal use only."
 
-      on.exit({
-        if (!is.null(.domain)) {
-          .domain$decrementBusyCount()
-        }
-      }, add = TRUE)
-
       lapply(.flushCallbacks, function(flushCallback) {
         flushCallback()
       })
@@ -118,16 +153,24 @@ ReactiveEnvironment <- R6Class(
     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()
+      if (.inFlush) return(invisible(FALSE))
       .inFlush <<- TRUE
-      on.exit(.inFlush <<- FALSE)
+      on.exit({
+        .inFlush <<- FALSE
+        rLog$idle(domain = NULL)
+      })
 
       while (hasPendingFlush()) {
         ctx <- .pendingFlush$dequeue()
         ctx$executeFlushCallbacks()
       }
+
+      invisible(TRUE)
     }
   )
 )
@@ -141,9 +184,10 @@ ReactiveEnvironment <- R6Class(
   }
 })
 
-# Causes any pending invalidations to run.
+# Causes any pending invalidations to run. Returns TRUE if any invalidations
+# were pending (i.e. if work was actually done).
 flushReact <- function() {
-  .getReactiveEnvironment()$flush()
+  return(.getReactiveEnvironment()$flush())
 }
 
 # Retrieves the current reactive context, or errors if there is no reactive
@@ -151,15 +195,41 @@ flushReact <- function() {
 getCurrentContext <- function() {
   .getReactiveEnvironment()$currentContext()
 }
+hasCurrentContext <- function() {
+  !is.null(.getReactiveEnvironment()$.currentContext)
+}
 
-getDummyContext <- function() {}
-local({
-  dummyContext <- NULL
-  getDummyContext <<- function() {
-    if (is.null(dummyContext)) {
-      dummyContext <<- Context$new(getDefaultReactiveDomain(), '[none]',
-        type='isolate')
-    }
-    return(dummyContext)
+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

@@ -95,11 +95,7 @@ getDefaultReactiveDomain <- function() {
 #' @rdname domains
 #' @export
 withReactiveDomain <- function(domain, expr) {
-  oldValue <- .globals$domain
-  .globals$domain <- domain
-  on.exit(.globals$domain <- oldValue)
-
-  expr
+  promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
 }
 
 #

R/reactives.R

@@ -6,26 +6,43 @@ Dependents <- R6Class(
   portable = FALSE,
   class = FALSE,
   public = list(
+    .reactId = character(0),
     .dependents = 'Map',
 
-    initialize = function() {
+    initialize = function(reactId = NULL) {
+      .reactId <<- reactId
       .dependents <<- Map$new()
     },
-    register = function(depId=NULL, depLabel=NULL) {
-      ctx <- .getReactiveEnvironment()$currentContext()
+    # ... ignored, use to be depLabel and depId, not used anymore
+    register = function(...) {
+      ctx <- getCurrentContext()
       if (!.dependents$containsKey(ctx$id)) {
+
+        # must wrap in if statement as ctx react id could be NULL
+        #   if options(shiny.suppressMissingContextError = TRUE)
+        if (is.character(.reactId) && is.character(ctx$.reactId)) {
+          rLog$dependsOn(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
+        }
+
         .dependents$set(ctx$id, ctx)
+
         ctx$onInvalidate(function() {
+          rLog$dependsOnRemove(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
           .dependents$remove(ctx$id)
         })
-
-        if (!is.null(depId) && nchar(depId) > 0)
-          .graphDependsOnId(ctx$id, depId)
-        if (!is.null(depLabel))
-          .graphDependsOn(ctx$id, depLabel)
       }
     },
-    invalidate = function() {
+    # at times, the context is run in a ctx$onInvalidate(...) which has no runtime context
+    invalidate = function(log = TRUE) {
+      if (isTRUE(log)) {
+
+        domain <- getDefaultReactiveDomain()
+        rLog$invalidateStart(.reactId, NULL, "other", domain)
+        on.exit(
+          rLog$invalidateEnd(.reactId, NULL, "other", domain),
+          add = TRUE
+        )
+      }
       lapply(
         .dependents$values(),
         function(ctx) {
@@ -44,19 +61,23 @@ ReactiveVal <- R6Class(
   'ReactiveVal',
   portable = FALSE,
   private = list(
+    reactId = character(0),
     value = NULL,
     label = NULL,
     frozen = FALSE,
-    dependents = Dependents$new()
+    dependents = NULL
   ),
   public = list(
     initialize = function(value, label = NULL) {
+      reactId <- nextGlobalReactId()
+      private$reactId <- reactId
       private$value <- value
       private$label <- label
-      .graphValueChange(private$label, value)
+      private$dependents <- Dependents$new(reactId = private$reactId)
+      rLog$define(private$reactId, value, private$label, type = "reactiveVal", getDefaultReactiveDomain())
     },
     get = function() {
-      private$dependents$register(depLabel = private$label)
+      private$dependents$register()
 
       if (private$frozen)
         reactiveStop()
@@ -67,8 +88,8 @@ ReactiveVal <- R6Class(
       if (identical(private$value, value)) {
         return(invisible(FALSE))
       }
+      rLog$valueChange(private$reactId, value, getDefaultReactiveDomain())
       private$value <- value
-      .graphValueChange(private$label, value)
       private$dependents$invalidate()
       invisible(TRUE)
     },
@@ -76,12 +97,14 @@ ReactiveVal <- R6Class(
       if (is.null(session)) {
         stop("Can't freeze a reactiveVal without a reactive domain")
       }
+      rLog$freezeReactiveVal(private$reactId, session)
       session$onFlushed(function() {
-        self$thaw()
+        self$thaw(session)
       })
       private$frozen <- TRUE
     },
-    thaw = function() {
+    thaw = function(session = getDefaultReactiveDomain()) {
+      rLog$thawReactiveVal(private$reactId, session)
       private$frozen <- FALSE
     },
     isFrozen = function() {
@@ -90,7 +113,7 @@ ReactiveVal <- R6Class(
     format = function(...) {
       # capture.output(print()) is necessary because format() doesn't
       # necessarily return a character vector, e.g. data.frame.
-      label <- capture.output(print(base::format(private$value, ...)))
+      label <- utils::capture.output(print(base::format(private$value, ...)))
       if (length(label) == 1) {
         paste0("reactiveVal: ", label)
       } else {
@@ -117,7 +140,7 @@ ReactiveVal <- R6Class(
 #'
 #' @param value An optional initial value.
 #' @param label An optional label, for debugging purposes (see
-#'   \code{\link{showReactLog}}). If missing, a label will be automatically
+#'   \code{\link{reactlog}}). If missing, a label will be automatically
 #'   created.
 #'
 #' @return A function. Call the function with no arguments to (reactively) read
@@ -267,6 +290,7 @@ ReactiveValues <- R6Class(
   portable = FALSE,
   public = list(
     # For debug purposes
+    .reactId = character(0),
     .label = character(0),
     .values = 'environment',
     .metadata = 'environment',
@@ -277,28 +301,49 @@ ReactiveValues <- R6Class(
     .allValuesDeps = 'Dependents',
     # Dependents for all values
     .valuesDeps = 'Dependents',
+    .dedupe = logical(0),
+    # Key, asList(), or names() have been retrieved
+    .hasRetrieved = list(),
 
-    initialize = function() {
-      .label <<- paste('reactiveValues',
-                       p_randomInt(1000, 10000),
-                       sep="")
+
+    initialize = function(
+      dedupe = TRUE,
+      label = paste0('reactiveValues', p_randomInt(1000, 10000))
+    ) {
+      .reactId <<- nextGlobalReactId()
+      .label <<- label
       .values <<- new.env(parent=emptyenv())
       .metadata <<- new.env(parent=emptyenv())
       .dependents <<- new.env(parent=emptyenv())
-      .namesDeps <<- Dependents$new()
-      .allValuesDeps <<- Dependents$new()
-      .valuesDeps <<- Dependents$new()
+      .hasRetrieved <<- list(names = FALSE, asListAll = FALSE, asList = FALSE, keys = list())
+      .namesDeps <<- Dependents$new(reactId = rLog$namesIdStr(.reactId))
+      .allValuesDeps <<- Dependents$new(reactId = rLog$asListAllIdStr(.reactId))
+      .valuesDeps <<- Dependents$new(reactId = rLog$asListIdStr(.reactId))
+      .dedupe <<- dedupe
     },
 
     get = function(key) {
+      # get value right away to use for logging
+      if (!exists(key, envir=.values, inherits=FALSE))
+        keyValue <- NULL
+      else
+        keyValue <- .values[[key]]
+
       # Register the "downstream" reactive which is accessing this value, so
       # that we know to invalidate them when this value changes.
-      ctx <- .getReactiveEnvironment()$currentContext()
+      ctx <- getCurrentContext()
       dep.key <- paste(key, ':', ctx$id, sep='')
       if (!exists(dep.key, envir=.dependents, inherits=FALSE)) {
-        .graphDependsOn(ctx$id, sprintf('%s$%s', .label, key))
+        reactKeyId <- rLog$keyIdStr(.reactId, key)
+
+        if (!isTRUE(.hasRetrieved$keys[[key]])) {
+          rLog$defineKey(.reactId, keyValue, key, .label, ctx$.domain)
+          .hasRetrieved$keys[[key]] <<- TRUE
+        }
+        rLog$dependsOnKey(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
         .dependents[[dep.key]] <- ctx
         ctx$onInvalidate(function() {
+          rLog$dependsOnKeyRemove(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
           rm(list=dep.key, envir=.dependents, inherits=FALSE)
         })
       }
@@ -306,34 +351,82 @@ ReactiveValues <- R6Class(
       if (isFrozen(key))
         reactiveStop()
 
-      if (!exists(key, envir=.values, inherits=FALSE))
-        NULL
-      else
-        .values[[key]]
+      keyValue
     },
 
     set = function(key, value) {
+      # if key exists
+      #   if it is the same value, return
+      #
+      # update value of `key`
+      #
+      # if key exists
+      #   if `key` has been read,
+      #     log `update key`
+      #     ## (invalidate key later in code)
+      # else # if new key
+      #   if `names()` have been read,
+      #     log `update names()`
+      #     invalidate `names()`
+      #
+      # if hidden
+      #   if asListAll has been read,
+      #     log `update asList(all.names = TRUE)`
+      #     invalidate `asListAll`
+      # else # not hidden
+      #   if asList has been read,
+      #     log `update asList()`
+      #     invalidate `asList`
+      #
+      # update value of `key`
+      # invalidate all deps of `key`
+
+      domain <- getDefaultReactiveDomain()
       hidden <- substr(key, 1, 1) == "."
 
-      if (exists(key, envir=.values, inherits=FALSE)) {
-        if (identical(.values[[key]], value)) {
+      key_exists <- exists(key, envir=.values, inherits=FALSE)
+
+      if (key_exists) {
+        if (.dedupe && identical(.values[[key]], value)) {
           return(invisible())
         }
       }
-      else {
-        .namesDeps$invalidate()
-      }
-
-      if (hidden)
-        .allValuesDeps$invalidate()
-      else
-        .valuesDeps$invalidate()
 
+      # set the value for better logging
       .values[[key]] <- value
 
-      .graphValueChange(sprintf('names(%s)', .label), ls(.values, all.names=TRUE))
-      .graphValueChange(sprintf('%s (all)', .label), as.list(.values))
-      .graphValueChange(sprintf('%s$%s', .label, key), value)
+      if (key_exists) {
+        # key has been depended upon (can not happen if the key is being set)
+        if (isTRUE(.hasRetrieved$keys[[key]])) {
+          rLog$valueChangeKey(.reactId, key, value, domain)
+          keyReactId <- rLog$keyIdStr(.reactId, key)
+          rLog$invalidateStart(keyReactId, NULL, "other", domain)
+          on.exit(
+            rLog$invalidateEnd(keyReactId, NULL, "other", domain),
+            add = TRUE
+          )
+        }
+
+      } else {
+        # only invalidate if there are deps
+        if (isTRUE(.hasRetrieved$names)) {
+          rLog$valueChangeNames(.reactId, ls(.values, all.names = TRUE), domain)
+          .namesDeps$invalidate()
+        }
+      }
+
+      if (hidden) {
+        if (isTRUE(.hasRetrieved$asListAll)) {
+          rLog$valueChangeAsListAll(.reactId, as.list(.values, all.names = TRUE), domain)
+          .allValuesDeps$invalidate()
+        }
+      } else {
+        if (isTRUE(.hasRetrieved$asList)) {
+          # leave as is. both object would be registered to the listening object
+          rLog$valueChangeAsList(.reactId, as.list(.values, all.names = FALSE), domain)
+          .valuesDeps$invalidate()
+        }
+      }
 
       dep.keys <- objects(
         envir=.dependents,
@@ -358,10 +451,14 @@ ReactiveValues <- R6Class(
     },
 
     names = function() {
-      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
-                      sprintf('names(%s)', .label))
+      nameValues <- ls(.values, all.names=TRUE)
+      if (!isTRUE(.hasRetrieved$names)) {
+        domain <- getDefaultReactiveDomain()
+        rLog$defineNames(.reactId, nameValues, .label, domain)
+        .hasRetrieved$names <<- TRUE
+      }
       .namesDeps$register()
-      return(ls(.values, all.names=TRUE))
+      return(nameValues)
     },
 
     # Get a metadata value. Does not trigger reactivity.
@@ -386,10 +483,14 @@ ReactiveValues <- R6Class(
     # Mark a value as frozen If accessed while frozen, a shiny.silent.error will
     # be thrown.
     freeze = function(key) {
+      domain <- getDefaultReactiveDomain()
+      rLog$freezeReactiveKey(.reactId, key, domain)
       setMeta(key, "frozen", TRUE)
     },
 
     thaw = function(key) {
+      domain <- getDefaultReactiveDomain()
+      rLog$thawReactiveKey(.reactId, key, domain)
       setMeta(key, "frozen", NULL)
     },
 
@@ -398,19 +499,27 @@ ReactiveValues <- R6Class(
     },
 
     toList = function(all.names=FALSE) {
-      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
-                      sprintf('%s (all)', .label))
-      if (all.names)
+      listValue <- as.list(.values, all.names=all.names)
+      if (all.names) {
+        if (!isTRUE(.hasRetrieved$asListAll)) {
+          domain <- getDefaultReactiveDomain()
+          rLog$defineAsListAll(.reactId, listValue, .label, domain)
+          .hasRetrieved$asListAll <<- TRUE
+        }
         .allValuesDeps$register()
+      }
 
+      if (!isTRUE(.hasRetrieved$asList)) {
+        domain <- getDefaultReactiveDomain()
+        # making sure the value being recorded is with `all.names = FALSE`
+        rLog$defineAsList(.reactId, as.list(.values, all.names=FALSE), .label, domain)
+        .hasRetrieved$asList <<- TRUE
+      }
       .valuesDeps$register()
 
-      return(as.list(.values, all.names=all.names))
-    },
-
-    .setLabel = function(label) {
-      .label <<- label
+      return(listValue)
     }
+
   )
 )
 
@@ -559,11 +668,6 @@ as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
   reactiveValuesToList(x, all.names)
 }
 
-# For debug purposes
-.setLabel <- function(x, label) {
-  .subset2(x, 'impl')$.setLabel(label)
-}
-
 #' Convert a reactivevalues object to a list
 #'
 #' This function does something similar to what you might \code{\link[base]{as.list}}
@@ -686,6 +790,7 @@ Observable <- R6Class(
   'Observable',
   portable = FALSE,
   public = list(
+    .reactId = character(0),
     .origFunc = 'function',
     .func = 'function',
     .label = character(0),
@@ -716,16 +821,18 @@ Observable <- R6Class(
         funcLabel <- paste0("<reactive:", label, ">")
       }
 
+      .reactId <<- nextGlobalReactId()
       .origFunc <<- func
       .func <<- wrapFunctionLabel(func, funcLabel,
         ..stacktraceon = ..stacktraceon)
       .label <<- label
       .domain <<- domain
-      .dependents <<- Dependents$new()
+      .dependents <<- Dependents$new(reactId = .reactId)
       .invalidated <<- TRUE
       .running <<- FALSE
       .execCount <<- 0L
       .mostRecentCtxId <<- ""
+      rLog$define(.reactId, .value, .label, type = "observable", .domain)
     },
     getValue = function() {
       .dependents$register()
@@ -736,8 +843,6 @@ Observable <- R6Class(
         )
       }
 
-      .graphDependsOnId(getCurrentContext()$id, .mostRecentCtxId)
-
       if (.error) {
         stop(.value)
       }
@@ -753,12 +858,12 @@ Observable <- R6Class(
     },
     .updateValue = function() {
       ctx <- Context$new(.domain, .label, type = 'observable',
-                         prevId = .mostRecentCtxId)
+                         prevId = .mostRecentCtxId, reactId = .reactId)
       .mostRecentCtxId <<- ctx$id
       ctx$onInvalidate(function() {
         .invalidated <<- TRUE
         .value <<- NULL # Value can be GC'd, it won't be read once invalidated
-        .dependents$invalidate()
+        .dependents$invalidate(log = FALSE)
       })
       .execCount <<- .execCount + 1L
 
@@ -780,18 +885,6 @@ Observable <- R6Class(
             # If an error occurs, we want to propagate the error, but we also
             # want to save a copy of it, so future callers of this reactive will
             # get the same error (i.e. the error is cached).
-
-            # We stripStackTrace in the next line, just in case someone
-            # downstream of us (i.e. deeper into the call stack) used
-            # captureStackTraces; otherwise the entire stack would always be the
-            # same (i.e. you'd always see the whole stack trace of the *first*
-            # time the code was run and the condition raised; there'd be no way
-            # to see the stack trace of the call site that caused the cached
-            # exception to be re-raised, and you need that information to figure
-            # out what's triggering the re-raise).
-            #
-            # We use try(stop()) as an easy way to generate a try-error object
-            # out of this condition.
             .value <<- cond
             .error <<- TRUE
             .visible <<- FALSE
@@ -944,6 +1037,7 @@ Observer <- R6Class(
   'Observer',
   portable = FALSE,
   public = list(
+    .reactId = character(0),
     .func = 'function',
     .label = character(0),
     .domain = 'ANY',
@@ -968,19 +1062,12 @@ Observer <- R6Class(
       if (length(formals(observerFunc)) > 0)
         stop("Can't make an observer from a function that takes parameters; ",
              "only functions without parameters can be reactive.")
-registerDebugHook("observerFunc", environment(), label)
-      .func <<- function() {
-        tryCatch(
-          if (..stacktraceon)
-            ..stacktraceon..(observerFunc())
-          else
-            observerFunc(),
-          # It's OK for shiny.silent.error errors to cause an observer to stop running
-          shiny.silent.error = function(e) NULL
-          # validation = function(e) NULL,
-          # shiny.output.cancel = function(e) NULL
-        )
+      if (grepl("\\s", label, perl = TRUE)) {
+        funcLabel <- "<observer>"
+      } else {
+        funcLabel <- paste0("<observer:", label, ">")
       }
+      .func <<- wrapFunctionLabel(observerFunc, funcLabel, ..stacktraceon = ..stacktraceon)
       .label <<- label
       .domain <<- domain
       .priority <<- normalizePriority(priority)
@@ -994,11 +1081,14 @@ registerDebugHook("observerFunc", environment(), label)
       .autoDestroyHandle <<- NULL
       setAutoDestroy(autoDestroy)
 
+      .reactId <<- nextGlobalReactId()
+      rLog$defineObserver(.reactId, .label, .domain)
+
       # Defer the first running of this until flushReact is called
       .createContext()$invalidate()
     },
     .createContext = function() {
-      ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId)
+      ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId, reactId = .reactId)
       .prevId <<- ctx$id
 
       if (!is.null(.ctx)) {
@@ -1025,6 +1115,9 @@ registerDebugHook("observerFunc", environment(), label)
 
         continue <- function() {
           ctx$addPendingFlush(.priority)
+          if (!is.null(.domain)) {
+            .domain$incrementBusyCount()
+          }
         }
 
         if (.suspended == FALSE)
@@ -1034,16 +1127,30 @@ registerDebugHook("observerFunc", environment(), label)
       })
 
       ctx$onFlush(function() {
-        tryCatch({
-          if (!.destroyed)
-            shinyCallingHandlers(run())
 
-        }, error = function(e) {
-          printError(e)
-          if (!is.null(.domain)) {
-            .domain$unhandledError(e)
-          }
-        })
+        hybrid_chain(
+          {
+            if (!.destroyed) {
+              shinyCallingHandlers(run())
+            }
+          },
+          catch = function(e) {
+            # It's OK for shiny.silent.error errors to cause an observer to stop running
+            # shiny.silent.error = function(e) NULL
+            # validation = function(e) NULL,
+            # shiny.output.cancel = function(e) NULL
+
+            if (inherits(e, "shiny.silent.error")) {
+              return()
+            }
+
+            printError(e)
+            if (!is.null(.domain)) {
+              .domain$unhandledError(e)
+            }
+          },
+          finally = .domain$decrementBusyCount
+        )
       })
 
       return(ctx)
@@ -1392,30 +1499,52 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
   # callback below is fired (see #1621).
   force(session)
 
+  # TODO-barret - ## leave alone for now
+  # reactId <- nextGlobalReactId()
+  # rLog$define(reactId, paste0("timer(", intervalMs, ")"))
+
   dependents <- Map$new()
-  timerCallbacks$schedule(intervalMs, function() {
+  timerHandle <- scheduleTask(intervalMs, function() {
     # Quit if the session is closed
     if (!is.null(session) && session$isClosed()) {
       return(invisible())
     }
 
-    timerCallbacks$schedule(intervalMs, sys.function())
-    lapply(
-      dependents$values(),
-      function(dep.ctx) {
-        dep.ctx$invalidate()
-        NULL
-      })
+    timerHandle <<- scheduleTask(intervalMs, sys.function())
+
+    doInvalidate <- function() {
+      lapply(
+        dependents$values(),
+        function(dep.ctx) {
+          dep.ctx$invalidate()
+          NULL
+        })
+    }
+
+    if (!is.null(session)) {
+      # If this timer belongs to a session, we must wait until the next cycle is
+      # ready to invalidate.
+      session$cycleStartAction(doInvalidate)
+    } else {
+      # If this timer doesn't belong to a session, we invalidate right away.
+      doInvalidate()
+    }
   })
+
+  if (!is.null(session)) {
+    session$onEnded(timerHandle)
+  }
+
   return(function() {
-    ctx <- .getReactiveEnvironment()$currentContext()
+    newValue <- Sys.time()
+    ctx <- getCurrentContext()
     if (!dependents$containsKey(ctx$id)) {
       dependents$set(ctx$id, ctx)
       ctx$onInvalidate(function() {
         dependents$remove(ctx$id)
       })
     }
-    return(Sys.time())
+    return(newValue)
   })
 }
 
@@ -1474,14 +1603,31 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #' }
 #' @export
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
-  ctx <- .getReactiveEnvironment()$currentContext()
-  timerCallbacks$schedule(millis, function() {
-    # Quit if the session is closed
-    if (!is.null(session) && session$isClosed()) {
+
+  force(session)
+
+  ctx <- getCurrentContext()
+  rLog$invalidateLater(ctx$.reactId, ctx$id, millis, session)
+
+  timerHandle <- scheduleTask(millis, function() {
+    if (is.null(session)) {
+      ctx$invalidate()
       return(invisible())
     }
-    ctx$invalidate()
+
+    if (!session$isClosed()) {
+      session$cycleStartAction(function() {
+        ctx$invalidate()
+      })
+    }
+
+    invisible()
   })
+
+  if (!is.null(session)) {
+    session$onEnded(timerHandle)
+  }
+
   invisible()
 }
 
@@ -1541,9 +1687,22 @@ coerceToFunc <- function(x) {
 #' @seealso \code{\link{reactiveFileReader}}
 #'
 #' @examples
-#' # Assume the existence of readTimestamp and readValue functions
 #' function(input, output, session) {
-#'   data <- reactivePoll(1000, session, readTimestamp, readValue)
+#'
+#'   data <- reactivePoll(1000, session,
+#'     # This function returns the time that log_file was last modified
+#'     checkFunc = function() {
+#'       if (file.exists(log_file))
+#'         file.info(log_file)$mtime[1]
+#'       else
+#'         ""
+#'     },
+#'     # This function returns the content of log_file
+#'     valueFunc = function() {
+#'       read.csv(log_file)
+#'     }
+#'   )
+#'
 #'   output$dataTable <- renderTable({
 #'     data()
 #'   })
@@ -1714,7 +1873,12 @@ reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...)
 #' # input object, like input$x
 #' @export
 isolate <- function(expr) {
-  ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate')
+  if (hasCurrentContext()) {
+    reactId <- getCurrentContext()$.reactId
+  } else {
+    reactId <- rLog$noReactId
+  }
+  ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate', reactId = reactId)
   on.exit(ctx$invalidate())
   # Matching ..stacktraceon../..stacktraceoff.. pair
   ..stacktraceoff..(ctx$run(function() {
@@ -1786,15 +1950,20 @@ maskReactiveContext <- function(expr) {
 #' the action/calculation and just let the user re-initiate it (like a
 #' "Recalculate" button).
 #'
-#' Unlike what happens for \code{ignoreNULL}, only \code{observeEvent} takes in an
-#' \code{ignoreInit} argument. By default, \code{observeEvent} will run right when
-#' it is created (except if, at that moment, \code{eventExpr} evaluates to \code{NULL}
+#' Likewise, both \code{observeEvent} and \code{eventReactive} also take in an
+#' \code{ignoreInit} argument. By default, both of these will run right when they
+#' are created (except if, at that moment, \code{eventExpr} evaluates to \code{NULL}
 #' and \code{ignoreNULL} is \code{TRUE}). But when responding to a click of an action
 #' button, it may often be useful to set \code{ignoreInit} to \code{TRUE}. For
 #' example, if you're setting up an \code{observeEvent} for a dynamically created
 #' button, then \code{ignoreInit = TRUE} will guarantee that the action (in
 #' \code{handlerExpr}) will only be triggered when the button is actually clicked,
-#' instead of also being triggered when it is created/initialized.
+#' instead of also being triggered when it is created/initialized. Similarly,
+#' if you're setting up an \code{eventReactive} that responds to a dynamically
+#' created button used to refresh some data (then returned by that \code{eventReactive}),
+#' then you should use \code{eventReactive([...], ignoreInit = TRUE)} if you want
+#' to let the user decide if/when they want to refresh the data (since, depending
+#' on the app, this may be a computationally expensive operation).
 #'
 #' Even though \code{ignoreNULL} and \code{ignoreInit} can be used for similar
 #' purposes they are independent from one another. Here's the result of combining
@@ -1802,25 +1971,28 @@ maskReactiveContext <- function(expr) {
 #'
 #' \describe{
 #'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = FALSE}}{
-#'      This is the default. This combination means that \code{handlerExpr} will
-#'      run every time that \code{eventExpr} is not \code{NULL}. If, at the time
-#'      of the \code{observeEvent}'s creation, \code{handleExpr} happens to
-#'      \emph{not} be \code{NULL}, then the code runs.
+#'      This is the default. This combination means that \code{handlerExpr}/
+#'      \code{valueExpr} will run every time that \code{eventExpr} is not
+#'      \code{NULL}. If, at the time of the creation of the
+#'      \code{observeEvent}/\code{eventReactive}, \code{eventExpr} happens
+#'      to \emph{not} be \code{NULL}, then the code runs.
 #'   }
 #'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = FALSE}}{
-#'      This combination means that \code{handlerExpr} will run every time no
-#'      matter what.
+#'      This combination means that \code{handlerExpr}/\code{valueExpr} will
+#'      run every time no matter what.
 #'   }
 #'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = TRUE}}{
-#'      This combination means that \code{handlerExpr} will \emph{not} run when
-#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}),
-#'      but it will run every other time.
+#'      This combination means that \code{handlerExpr}/\code{valueExpr} will
+#'      \emph{not} run when the \code{observeEvent}/\code{eventReactive} is
+#'      created (because \code{ignoreInit = TRUE}), but it will run every
+#'      other time.
 #'   }
 #'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = TRUE}}{
-#'      This combination means that \code{handlerExpr} will \emph{not} run when
-#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}).
-#'      After that, \code{handlerExpr} will run every time that \code{eventExpr}
-#'      is not \code{NULL}.
+#'      This combination means that \code{handlerExpr}/\code{valueExpr} will
+#'      \emph{not} run when the \code{observeEvent}/\code{eventReactive} is
+#'      created (because  \code{ignoreInit = TRUE}). After that,
+#'      \code{handlerExpr}/\code{valueExpr} will run every time that
+#'      \code{eventExpr} is not \code{NULL}.
 #'   }
 #' }
 #'
@@ -1960,22 +2132,25 @@ observeEvent <- function(eventExpr, handlerExpr,
   initialized <- FALSE
 
   o <- observe({
-    e <- eventFunc()
+    hybrid_chain(
+      {eventFunc()},
+      function(value) {
+        if (ignoreInit && !initialized) {
+          initialized <<- TRUE
+          return()
+        }
 
-    if (ignoreInit && !initialized) {
-      initialized <<- TRUE
-      return()
-    }
+        if (ignoreNULL && isNullEvent(value)) {
+          return()
+        }
 
-    if (ignoreNULL && isNullEvent(e)) {
-      return()
-    }
+        if (once) {
+          on.exit(o$destroy())
+        }
 
-    if (once) {
-      on.exit(o$destroy())
-    }
-
-    isolate(handlerFunc())
+        isolate(handlerFunc())
+      }
+    )
   }, label = label, suspended = suspended, priority = priority, domain = domain,
   autoDestroy = TRUE, ..stacktraceon = FALSE)
 
@@ -2001,16 +2176,19 @@ eventReactive <- function(eventExpr, valueExpr,
   initialized <- FALSE
 
   invisible(reactive({
-    e <- eventFunc()
+    hybrid_chain(
+      eventFunc(),
+      function(value) {
+        if (ignoreInit && !initialized) {
+          initialized <<- TRUE
+          req(FALSE)
+        }
 
-    if (ignoreInit && !initialized) {
-      initialized <<- TRUE
-      req(FALSE)
-    }
+        req(!ignoreNULL || !isNullEvent(value))
 
-    req(!ignoreNULL || !isNullEvent(e))
-
-    isolate(handlerFunc())
+        isolate(handlerFunc())
+      }
+    )
   }, label = label, domain = domain, ..stacktraceon = FALSE))
 }
 

R/render-cached-plot.R

@@ -0,0 +1,590 @@
+#' Plot output with cached images
+#'
+#' Renders a reactive plot, with plot images cached to disk.
+#'
+#' \code{expr} is an expression that generates a plot, similar to that in
+#' \code{renderPlot}. Unlike with \code{renderPlot}, this expression does not
+#' take reactive dependencies. It is re-executed only when the cache key
+#' changes.
+#'
+#' \code{cacheKeyExpr} is an expression which, when evaluated, returns an object
+#' which will be serialized and hashed using the \code{\link[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 \code{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, \code{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
+#' \code{\link[digest]{digest}} function.
+#'
+#' Internally, the result from \code{cacheKeyExpr} is combined with the name of
+#' the output (if you assign it to \code{output$plot1}, it will be combined
+#' with \code{"plot1"}) to form the actual key that is used. As a result, even
+#' if there are multiple plots that have the same \code{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 \code{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 \code{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 \code{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 \code{"app"} or \code{"session"} is used, the cache will be 10 MB
+#'   in size, and will be stored stored in memory, using a
+#'   \code{\link{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
+#'   \code{\link{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
+#'   \code{\link{shinyOptions}()} at the top of your server function. To use
+#'   the session-scoped cache, you must also call \code{renderCachedPlot} with
+#'   \code{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 \code{\link{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
+#'   \code{myapp-cache} (replace \code{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 \code{\link{memoryCache}} or \code{\link{diskCache}}, and pass it
+#'   as the \code{cache} argument of \code{renderCachedPlot}.
+#'
+#' @section Interactive plots:
+#'
+#'   \code{renderCachedPlot} can be used to create interactive plots. See
+#'   \code{\link{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, \code{width} and
+#'   \code{height}, and returns a list with \code{width} and \code{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 \code{\link{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
+#'   \code{"app"} (the default), \code{"session"}, or a cache object like
+#'   a \code{\link{diskCache}}. See the Cache Scoping section for more
+#'   information.
+#'
+#' @seealso See \code{\link{renderPlot}} for the regular, non-cached version of
+#'   this function. For more about configuring caches, see
+#'   \code{\link{memoryCache}} and \code{\link{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",
+  ...,
+  outputArgs = list()
+) {
+
+  # 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(...)
+
+  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)
+
+  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
+        })
+
+        pixelratio <- session$clientData$pixelratio %OR% 1
+
+        do.call("drawPlot", c(
+          list(
+            name = outputName,
+            session = session,
+            func = isolatedFunc,
+            width = width,
+            height = height,
+            pixelratio = pixelratio,
+            res = res
+          ),
+          args
+        ))
+      },
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        fitDims$width
+        fitDims$height
+
+        # Propagate the error
+        stop(reason)
+      }
+    )
+  })
+
+
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned.
+  renderFunc <- function(shinysession, name, ...) {
+    outputName <<- name
+    session <<- shinysession
+    ensureCacheSetup()
+    ensureResizeObserver()
+
+    hybrid_chain(
+      # This use of the userCacheKey() sets up the reactive dependency that
+      # causes plot re-draw events. These may involve pulling from the cache,
+      # replaying a display list, or re-executing user code.
+      userCacheKey(),
+      function(userCacheKeyResult) {
+        width  <- fitDims$width
+        height <- fitDims$height
+        pixelratio <- session$clientData$pixelratio %OR% 1
+
+        key <- digest::digest(list(outputName, userCacheKeyResult, width, height, res, pixelratio), "xxhash64")
+
+        plotObj <- cache$get(key)
+
+        # First look in cache.
+        # Case 1. cache hit.
+        if (!is.key_missing(plotObj)) {
+          return(list(
+            cacheHit = TRUE,
+            key = key,
+            plotObj = plotObj,
+            width = width,
+            height = height,
+            pixelratio = pixelratio
+          ))
+        }
+
+        # If not in cache, hybrid_chain call to drawReactive
+        #
+        # Two more possible cases:
+        #   2. drawReactive will re-execute and return a plot that's the
+        #      correct size.
+        #   3. It will not re-execute, but it will return the previous value,
+        #      which is the wrong size. It will include a valid display list
+        #      which can be used by resizeSavedPlot.
+        hybrid_chain(
+          drawReactive(),
+          function(drawReactiveResult) {
+            # Pass along the key for caching in the next stage
+            list(
+              cacheHit = FALSE,
+              key = key,
+              plotObj = drawReactiveResult,
+              width = width,
+              height = height,
+              pixelratio = pixelratio
+            )
+          }
+        )
+      },
+      function(possiblyAsyncResult) {
+        hybrid_chain(possiblyAsyncResult, function(result) {
+          width      <- result$width
+          height     <- result$height
+          pixelratio <- result$pixelratio
+
+          # Three possibilities when we get here:
+          # 1. There was a cache hit. No need to set a value in the cache.
+          # 2. There was a cache miss, and the plotObj is already the correct
+          #    size (because drawReactive re-executed). In this case, we need
+          #    to cache it.
+          # 3. There was a cache miss, and the plotObj was not the corect size.
+          #    In this case, we need to replay the display list, and then cache
+          #    the result.
+          if (!result$cacheHit) {
+            # If the image is already the correct size, this just returns the
+            # object unchanged.
+            result$plotObj <- do.call("resizeSavedPlot", c(
+              list(
+                name,
+                shinysession,
+                result$plotObj,
+                width,
+                height,
+                pixelratio,
+                res
+              ),
+              args
+            ))
+
+            # Save a cached copy of the plotObj. The recorded displaylist for
+            # the plot can't be serialized and restored properly within the same
+            # R session, so we NULL it out before saving. (The image data and
+            # other metadata be saved and restored just fine.) Displaylists can
+            # also be very large (~1.5MB for a basic ggplot), and they would not
+            # be commonly used. Note that displaylist serialization was fixed in
+            # revision 74506 (2e6c669), and should be in R 3.6. A MemoryCache
+            # doesn't need to serialize objects, so it could actually save a
+            # display list, but for the reasons listed previously, it's
+            # generally not worth it.
+            # The plotResult is not the same as the recordedPlot (it is used to
+            # retrieve coordmap information for ggplot2 objects) but it is only
+            # used in conjunction with the recordedPlot, and we'll remove it
+            # because it can be quite large.
+            result$plotObj$plotResult <- NULL
+            result$plotObj$recordedPlot <- NULL
+            cache$set(result$key, result$plotObj)
+          }
+
+          img <- result$plotObj$img
+          # Replace exact pixel dimensions; instead, the max-height and
+          # max-width will be set to 100% from CSS.
+          img$class <- "shiny-scalable"
+          img$width  <- NULL
+          img$height <- NULL
+
+          img
+        })
+      }
+    )
+  }
+
+  # If renderPlot isn't going to adapt to the height of the div, then the
+  # div needs to adapt to the height of renderPlot. By default, plotOutput
+  # sets the height to 400px, so to make it adapt we need to override it
+  # with NULL.
+  outputFunc <- plotOutput
+  formals(outputFunc)['height'] <- list(NULL)
+
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+}
+
+
+#' 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 \code{\link{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-plot.R

@@ -55,37 +55,20 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 
   args <- list(...)
 
-  if (is.function(width))
+  if (is.reactive(width))
+    widthWrapper <- width
+  else if (is.function(width))
     widthWrapper <- reactive({ width() })
   else
     widthWrapper <- function() { width }
 
-  if (is.function(height))
+  if (is.reactive(height))
+    heightWrapper <- height
+  else if (is.function(height))
     heightWrapper <- reactive({ height() })
   else
     heightWrapper <- function() { height }
 
-  # A modified version of print.ggplot which returns the built ggplot object
-  # as well as the gtable grob. This overrides the ggplot::print.ggplot
-  # method, but only within the context of renderPlot. The reason this needs
-  # to be a (pseudo) S3 method is so that, if an object has a class in
-  # addition to ggplot, and there's a print method for that class, that we
-  # won't override that method. https://github.com/rstudio/shiny/issues/841
-  print.ggplot <- function(x) {
-    grid::grid.newpage()
-
-    build <- ggplot2::ggplot_build(x)
-
-    gtable <- ggplot2::ggplot_gtable(build)
-    grid::grid.draw(gtable)
-
-    structure(list(
-      build = build,
-      gtable = gtable
-    ), class = "ggplot_build_gtable")
-  }
-
-
   getDims <- function() {
     width <- widthWrapper()
     height <- heightWrapper()
@@ -106,155 +89,59 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   session <- NULL
   outputName <- NULL
 
-  # This function is the one that's returned from renderPlot(), and gets
-  # wrapped in an observer when the output value is assigned. The expression
-  # passed to renderPlot() is actually run in plotObj(); this function can only
-  # replay a plot if the width/height changes.
-  renderFunc <- function(shinysession, name, ...) {
-    session <<- shinysession
-    outputName <<- name
+  # Calls drawPlot, invoking the user-provided `func` (which may or may not
+  # return a promise). The idea is that the (cached) return value from this
+  # reactive can be used for varying width/heights, as it includes the
+  # displaylist, which is resolution independent.
+  drawReactive <- reactive(label = "plotObj", {
+    hybrid_chain(
+      {
+        # If !execOnResize, don't invalidate when width/height changes.
+        dims <- if (execOnResize) getDims() else isolate(getDims())
+        pixelratio <- session$clientData$pixelratio %OR% 1
+        do.call("drawPlot", c(
+          list(
+            name = outputName,
+            session = session,
+            func = func,
+            width = dims$width,
+            height = dims$height,
+            pixelratio = pixelratio,
+            res = res
+          ), args))
+      },
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        getDims()
 
-    dims <- getDims()
-
-    if (is.null(dims$width) || is.null(dims$height) ||
-        dims$width <= 0 || dims$height <= 0) {
-      return(NULL)
-    }
-
-    # The reactive that runs the expr in renderPlot()
-    plotData <- plotObj()
-
-    img <- plotData$img
-
-    # If only the width/height have changed, simply replay the plot and make a
-    # new img.
-    if (dims$width != img$width || dims$height != img$height) {
-      pixelratio <- session$clientData$pixelratio %OR% 1
-
-      coordmap <- NULL
-      plotFunc <- function() {
-        ..stacktraceon..(grDevices::replayPlot(plotData$recordedPlot))
-
-        # Coordmap must be recalculated after replaying plot, because pixel
-        # dimensions will have changed.
-        if (inherits(plotData$plotResult, "ggplot_build_gtable")) {
-          coordmap <<- getGgplotCoordmap(plotData$plotResult, pixelratio, res)
-        } else {
-          coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
-        }
+        # Propagate the error
+        stop(reason)
       }
-      outfile <- ..stacktraceoff..(
-        plotPNG(plotFunc, width = dims$width*pixelratio, height = dims$height*pixelratio,
-                res = res*pixelratio)
-      )
-      on.exit(unlink(outfile))
-
-      img <- dropNulls(list(
-        src = session$fileUrl(name, outfile, contentType='image/png'),
-        width = dims$width,
-        height = dims$height,
-        coordmap = coordmap,
-        # Get coordmap error message if present
-        error = attr(coordmap, "error", exact = TRUE)
-      ))
-    }
-
-    img
-  }
-
-
-  plotObj <- reactive(label = "plotObj", {
-    if (execOnResize) {
-      dims <- getDims()
-    } else {
-      isolate({ dims <- getDims() })
-    }
-
-    if (is.null(dims$width) || is.null(dims$height) ||
-        dims$width <= 0 || dims$height <= 0) {
-      return(NULL)
-    }
-
-    # Resolution multiplier
-    pixelratio <- session$clientData$pixelratio %OR% 1
-
-    plotResult <- NULL
-    recordedPlot <- NULL
-    coordmap <- NULL
-    plotFunc <- function() {
-      success <-FALSE
-      tryCatch(
-        {
-          # This is necessary to enable displaylist recording
-          grDevices::dev.control(displaylist = "enable")
-
-          # Actually perform the plotting
-          result <- withVisible(func())
-          success <- TRUE
-        },
-        finally = {
-          if (!success) {
-            # If there was an error in making the plot, there's a good chance
-            # it's "Error in plot.new: figure margins too large". We need to
-            # take a reactive dependency on the width and height, so that the
-            # user's plotting code will re-execute when the plot is resized,
-            # instead of just replaying the previous plot (which errored).
-            getDims()
-          }
-        }
-      )
-
-      if (result$visible) {
-        # Use capture.output to squelch printing to the actual console; we
-        # are only interested in plot output
-        utils::capture.output({
-          # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
-          # the call to plotFunc. The value needs to be printed just in case
-          # it's an object that requires printing to generate plot output,
-          # similar to ggplot2. But for base graphics, it would already have
-          # been rendered when func was called above, and the print should
-          # have no effect.
-          plotResult <<- ..stacktraceon..(print(result$value))
-        })
-      }
-
-      recordedPlot <<- grDevices::recordPlot()
-
-      if (inherits(plotResult, "ggplot_build_gtable")) {
-        coordmap <<- getGgplotCoordmap(plotResult, pixelratio, res)
-      } else {
-        coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
-      }
-    }
-
-    # This ..stacktraceoff.. is matched by the `func` function's
-    # wrapFunctionLabel(..stacktraceon=TRUE) call near the beginning of
-    # renderPlot, and by the ..stacktraceon.. in plotFunc where ggplot objects
-    # are printed
-    outfile <- ..stacktraceoff..(
-      do.call(plotPNG, c(plotFunc, width=dims$width*pixelratio,
-        height=dims$height*pixelratio, res=res*pixelratio, args))
-    )
-    on.exit(unlink(outfile))
-
-    list(
-      # img is the content that gets sent to the client.
-      img = dropNulls(list(
-        src = session$fileUrl(outputName, outfile, contentType='image/png'),
-        width = dims$width,
-        height = dims$height,
-        coordmap = coordmap,
-        # Get coordmap error message if present.
-        error = attr(coordmap, "error", exact = TRUE)
-      )),
-      # Returned value from expression in renderPlot() -- may be a printable
-      # object like ggplot2. Needed just in case we replayPlot and need to get
-      # a coordmap again.
-      plotResult = plotResult,
-      recordedPlot = recordedPlot
     )
   })
 
+  # 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
+
+    hybrid_chain(
+      drawReactive(),
+      function(result) {
+        dims <- getDims()
+        pixelratio <- session$clientData$pixelratio %OR% 1
+        result <- do.call("resizeSavedPlot", c(
+          list(name, shinysession, result, dims$width, dims$height, pixelratio, res),
+          args
+        ))
+
+        result$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
@@ -266,26 +153,157 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
 }
 
+resizeSavedPlot <- function(name, session, result, width, height, pixelratio, res, ...) {
+  if (result$img$width == width && result$img$height == height &&
+      result$pixelratio == pixelratio && result$res == res) {
+    return(result)
+  }
+
+  coordmap <- NULL
+  outfile <- plotPNG(function() {
+    grDevices::replayPlot(result$recordedPlot)
+    coordmap <<- getCoordmap(result$plotResult, width*pixelratio, height*pixelratio, res*pixelratio)
+  }, width = width*pixelratio, height = height*pixelratio, res = res*pixelratio, ...)
+  on.exit(unlink(outfile), add = TRUE)
+
+  result$img <- list(
+    src = session$fileUrl(name, outfile, contentType = "image/png"),
+    width = width,
+    height = height,
+    coordmap = coordmap,
+    error = attr(coordmap, "error", exact = TRUE)
+  )
+
+  result
+}
+
+drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
+  #  1. Start PNG
+  #  2. Enable displaylist recording
+  #  3. Call user-defined func
+  #  4. Print/save result, if visible
+  #  5. Snapshot displaylist
+  #  6. Form coordmap
+  #  7. End PNG (in finally)
+  #  8. Form img tag
+  #  9. Return img, value, displaylist, coordmap
+  # 10. On error, take width and height dependency
+
+  outfile <- tempfile(fileext='.png') # If startPNG throws, this could leak. Shrug.
+  device <- startPNG(outfile, width*pixelratio, height*pixelratio, res = res*pixelratio, ...)
+  domain <- createGraphicsDevicePromiseDomain(device)
+  grDevices::dev.control(displaylist = "enable")
+
+  hybrid_chain(
+    hybrid_chain(
+      promises::with_promise_domain(domain, {
+        hybrid_chain(
+          func(),
+          function(value, .visible) {
+            if (.visible) {
+              # A modified version of print.ggplot which returns the built ggplot object
+              # as well as the gtable grob. This overrides the ggplot::print.ggplot
+              # method, but only within the context of renderPlot. The reason this needs
+              # to be a (pseudo) S3 method is so that, if an object has a class in
+              # addition to ggplot, and there's a print method for that class, that we
+              # won't override that method. https://github.com/rstudio/shiny/issues/841
+              print.ggplot <- custom_print.ggplot
+
+              # Use capture.output to squelch printing to the actual console; we
+              # are only interested in plot output
+              utils::capture.output({
+                # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
+                # the call to plotFunc. The value needs to be printed just in case
+                # it's an object that requires printing to generate plot output,
+                # similar to ggplot2. But for base graphics, it would already have
+                # been rendered when func was called above, and the print should
+                # have no effect.
+                result <- ..stacktraceon..(print(value))
+                # TODO jcheng 2017-04-11: Verify above ..stacktraceon..
+              })
+              result
+            } else {
+              # Not necessary, but I wanted to make it explicit
+              NULL
+            }
+          },
+          function(value) {
+            list(
+              plotResult = value,
+              recordedPlot = grDevices::recordPlot(),
+              coordmap = getCoordmap(value, width*pixelratio, height*pixelratio, res*pixelratio),
+              pixelratio = pixelratio,
+              res = res
+            )
+          }
+        )
+      }),
+      finally = function() {
+        grDevices::dev.off(device)
+      }
+    ),
+    function(result) {
+      result$img <- dropNulls(list(
+        src = session$fileUrl(name, outfile, contentType='image/png'),
+        width = width,
+        height = height,
+        coordmap = result$coordmap,
+        # Get coordmap error message if present
+        error = attr(result$coordmap, "error", exact = TRUE)
+      ))
+
+      result
+    },
+    finally = function() {
+      unlink(outfile)
+    }
+  )
+}
+
+# A modified version of print.ggplot which returns the built ggplot object
+# as well as the gtable grob. This overrides the ggplot::print.ggplot
+# method, but only within the context of renderPlot. The reason this needs
+# to be a (pseudo) S3 method is so that, if an object has a class in
+# addition to ggplot, and there's a print method for that class, that we
+# won't override that method. https://github.com/rstudio/shiny/issues/841
+custom_print.ggplot <- function(x) {
+  grid::grid.newpage()
+
+  build <- ggplot2::ggplot_build(x)
+
+  gtable <- ggplot2::ggplot_gtable(build)
+  grid::grid.draw(gtable)
+
+  structure(list(
+    build = build,
+    gtable = gtable
+  ), class = "ggplot_build_gtable")
+}
+
 # The coordmap extraction functions below return something like the examples
 # below. For base graphics:
 # plot(mtcars$wt, mtcars$mpg)
 # str(getPrevPlotCoordmap(400, 300))
-# List of 1
-#  $ :List of 4
-#   ..$ 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 50.4
-#   .. ..$ right : num 373
-#   .. ..$ bottom: num 199
-#   .. ..$ top   : num 79.6
-#   ..$ log    :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ mapping: Named list()
+# List of 2
+#  $ panels:List of 1
+#   ..$ :List of 4
+#   .. ..$ 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 65.6
+#   .. .. ..$ right : num 366
+#   .. .. ..$ bottom: num 238
+#   .. .. ..$ top   : num 48.2
+#   .. ..$ log    :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ mapping: Named list()
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
 #
 # For ggplot2, first you need to define the print.ggplot function from inside
 # renderPlot, then use it to print the plot:
@@ -304,29 +322,33 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 # }
 #
 # p <- print(ggplot(mtcars, aes(wt, mpg)) + geom_point())
-# str(getGgplotCoordmap(p, 1, 72))
-# List of 1
-#  $ :List of 10
-#   ..$ panel     : int 1
-#   ..$ row       : int 1
-#   ..$ col       : int 1
-#   ..$ panel_vars: Named list()
-#   ..$ log       :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ domain    :List of 4
-#   .. ..$ left  : num 1.32
-#   .. ..$ right : num 5.62
-#   .. ..$ bottom: num 9.22
-#   .. ..$ top   : num 35.1
-#   ..$ mapping   :List of 2
-#   .. ..$ x: chr "wt"
-#   .. ..$ y: chr "mpg"
-#   ..$ range     :List of 4
-#   .. ..$ left  : num 40.8
-#   .. ..$ right : num 446
-#   .. ..$ bottom: num 263
-#   .. ..$ top   : num 14.4
+# str(getGgplotCoordmap(p, 400, 300, 72))
+# List of 2
+#  $ panels:List of 1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 1
+#   .. ..$ row       : num 1
+#   .. ..$ col       : num 1
+#   .. ..$ panel_vars: Named list()
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 2
+#   .. .. ..$ x: chr "wt"
+#   .. .. ..$ y: chr "mpg"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 33.3
+#   .. .. ..$ right : num 355
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 5.48
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
 #
 # With a faceted ggplot2 plot, the outer list contains two objects, each of
 # which represents one panel. In this example, there is one panelvar, but there
@@ -334,56 +356,68 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 # mtc <- mtcars
 # mtc$am <- factor(mtc$am)
 # p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am))
-# str(getGgplotCoordmap(p, 1, 72))
+# str(getGgplotCoordmap(p, 400, 300, 72))
 # List of 2
-#  $ :List of 10
-#   ..$ panel     : int 1
-#   ..$ row       : int 1
-#   ..$ col       : int 1
-#   ..$ panel_vars:List of 1
-#   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
-#   ..$ log       :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ domain    :List of 4
-#   .. ..$ left  : num 1.32
-#   .. ..$ right : num 5.62
-#   .. ..$ bottom: num 9.22
-#   .. ..$ top   : num 35.1
-#   ..$ mapping   :List of 3
-#   .. ..$ x        : chr "wt"
-#   .. ..$ y        : chr "mpg"
-#   .. ..$ panelvar1: chr "am"
-#   ..$ range     :List of 4
-#   .. ..$ left  : num 45.6
-#   .. ..$ right : num 317
-#   .. ..$ bottom: num 251
-#   .. ..$ top   : num 35.7
-#  $ :List of 10
-#   ..$ panel     : int 2
-#   ..$ row       : int 1
-#   ..$ col       : int 2
-#   ..$ panel_vars:List of 1
-#   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
-#   ..$ log       :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ domain    :List of 4
-#   .. ..$ left  : num 1.32
-#   .. ..$ right : num 5.62
-#   .. ..$ bottom: num 9.22
-#   .. ..$ top   : num 35.1
-#   ..$ mapping   :List of 3
-#   .. ..$ x        : chr "wt"
-#   .. ..$ y        : chr "mpg"
-#   .. ..$ panelvar1: chr "am"
-#   ..$ range     :List of 4
-#   .. ..$ left  : num 322
-#   .. ..$ right : num 594
-#   .. ..$ bottom: num 251
-#   .. ..$ top   : num 35.7
+#  $ panels:List of 2
+#   ..$ :List of 8
+#   .. ..$ panel     : num 1
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 1
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "wt"
+#   .. .. ..$ y        : chr "mpg"
+#   .. .. ..$ panelvar1: chr "am"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 33.3
+#   .. .. ..$ right : num 191
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 23.1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 2
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 2
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "wt"
+#   .. .. ..$ y        : chr "mpg"
+#   .. .. ..$ panelvar1: chr "am"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 197
+#   .. .. ..$ right : num 355
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 23.1
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
 
 
+getCoordmap <- function(x, width, height, res) {
+  if (inherits(x, "ggplot_build_gtable")) {
+    getGgplotCoordmap(x, width, height, res)
+  } else {
+    getPrevPlotCoordmap(width, height)
+  }
+}
+
 # Get a coordmap for the previous plot made with base graphics.
 # Requires width and height of output image, in pixels.
 # Must be called before the graphics device is closed.
@@ -398,7 +432,7 @@ getPrevPlotCoordmap <- function(width, height) {
   }
 
   # Wrapped in double list because other types of plots can have multiple panels.
-  list(list(
+  panel_info <- list(list(
     # Bounds of the plot area, in data space
     domain = list(
       left = usrCoords[1],
@@ -408,10 +442,10 @@ getPrevPlotCoordmap <- function(width, height) {
     ),
     # The bounds of the plot area, in DOM pixels
     range = list(
-      left = graphics::grconvertX(usrBounds[1], 'user', 'nfc') * width,
-      right = graphics::grconvertX(usrBounds[2], 'user', 'nfc') * width,
-      bottom = (1-graphics::grconvertY(usrBounds[3], 'user', 'nfc')) * height - 1,
-      top = (1-graphics::grconvertY(usrBounds[4], 'user', 'nfc')) * height - 1
+      left = graphics::grconvertX(usrBounds[1], 'user', 'ndc') * width,
+      right = graphics::grconvertX(usrBounds[2], 'user', 'ndc') * width,
+      bottom = (1-graphics::grconvertY(usrBounds[3], 'user', 'ndc')) * height - 1,
+      top = (1-graphics::grconvertY(usrBounds[4], 'user', 'ndc')) * height - 1
     ),
     log = list(
       x = if (graphics::par('xlog')) 10 else NULL,
@@ -422,28 +456,43 @@ getPrevPlotCoordmap <- function(width, height) {
     # (not an array) in JSON.
     mapping = list(x = NULL)[0]
   ))
+
+  list(
+    panels = panel_info,
+    dims = list(
+      width = width,
+      height =height
+    )
+  )
 }
 
-
 # Given a ggplot_build_gtable object, return a coordmap for it.
-getGgplotCoordmap <- function(p, pixelratio, res) {
+getGgplotCoordmap <- function(p, width, height, res) {
   if (!inherits(p, "ggplot_build_gtable"))
     return(NULL)
 
   tryCatch({
     # Get info from built ggplot object
-    info <- find_panel_info(p$build)
+    panel_info <- find_panel_info(p$build)
 
     # Get ranges from gtable - it's possible for this to return more elements than
     # info, because it calculates positions even for panels that aren't present.
     # This can happen with facet_wrap.
-    ranges <- find_panel_ranges(p$gtable, pixelratio, res)
+    ranges <- find_panel_ranges(p$gtable, res)
 
-    for (i in seq_along(info)) {
-      info[[i]]$range <- ranges[[i]]
+    for (i in seq_along(panel_info)) {
+      panel_info[[i]]$range <- ranges[[i]]
     }
 
-    return(info)
+    return(
+      list(
+        panels = panel_info,
+        dims = list(
+          width = width,
+          height = height
+        )
+      )
+    )
 
   }, error = function(e) {
     # If there was an error extracting info from the ggplot object, just return
@@ -537,9 +586,11 @@ find_panel_info_api <- function(b) {
     # ggplot object. The original uses quoted expressions; convert to
     # character.
     mapping <- layers$mapping[[1]]
-    # lapply'ing as.character results in unexpected behavior for expressions
-    # like `wt/2`; deparse handles it correctly.
-    mapping <- lapply(mapping, deparse)
+    # In ggplot2 <=2.2.1, the mappings are expressions. In later versions, they
+    # are quosures. `deparse(quo_squash(x))` will handle both cases.
+    # as.character results in unexpected behavior for expressions like `wt/2`,
+    # which is why we use deparse.
+    mapping <- lapply(mapping, function(x) deparse(rlang::quo_squash(x)))
 
     # If either x or y is not present, give it a NULL entry.
     mapping <- mergeVectors(list(x = NULL, y = NULL), mapping)
@@ -721,8 +772,9 @@ find_panel_info_non_api <- function(b, ggplot_format) {
       mappings <- c(list(mappings), layer_mappings)
       mappings <- Reduce(x = mappings, init = list(x = NULL, y = NULL),
         function(init, m) {
-          if (is.null(init$x) && !is.null(m$x)) init$x <- m$x
-          if (is.null(init$y) && !is.null(m$y)) init$y <- m$y
+          # Can't use m$x/m$y; you get a partial match with xintercept/yintercept
+          if (is.null(init[["x"]]) && !is.null(m[["x"]])) init$x <- m[["x"]]
+          if (is.null(init[["y"]]) && !is.null(m[["y"]])) init$y <- m[["y"]]
           init
         }
       )
@@ -801,7 +853,7 @@ find_panel_info_non_api <- function(b, ggplot_format) {
 
 
 # Given a gtable object, return the x and y ranges (in pixel dimensions)
-find_panel_ranges <- function(g, pixelratio, res) {
+find_panel_ranges <- function(g, res) {
   # Given a vector of unit objects, return logical vector indicating which ones
   # are "null" units. These units use the remaining available width/height --
   # that is, the space not occupied by elements that have an absolute size.
@@ -931,26 +983,15 @@ find_panel_ranges <- function(g, pixelratio, res) {
   layout <- layout[order(layout$t, layout$l), ]
   layout$panel <- seq_len(nrow(layout))
 
-  # When using a HiDPI client on a Linux server, the pixel
-  # dimensions are doubled, so we have to divide the dimensions by
-  # `pixelratio`. When a HiDPI client is used on a Mac server (with
-  # the quartz device), the pixel dimensions _aren't_ doubled, even though
-  # the image has double size. In the latter case we don't have to scale the
-  # numbers down.
-  pix_ratio <- 1
-  if (!grepl("^quartz", names(grDevices::dev.cur()))) {
-    pix_ratio <- pixelratio
-  }
-
   # Return list of lists, where each inner list has left, right, top, bottom
   # values for a panel
   lapply(seq_len(nrow(layout)), function(i) {
     p <- layout[i, , drop = FALSE]
     list(
-      left   = x_pos[p$l - 1] / pix_ratio,
-      right  = x_pos[p$r] / pix_ratio,
-      bottom = y_pos[p$b] / pix_ratio,
-      top    = y_pos[p$t - 1] / pix_ratio
+      left   = x_pos[p$l - 1],
+      right  = x_pos[p$r],
+      bottom = y_pos[p$b],
+      top    = y_pos[p$t - 1]
     )
   })
 }

R/render-table.R

@@ -81,143 +81,148 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
 
   dots <- list(...)  ## used later (but defined here because of scoping)
 
-  renderFunc <- function(shinysession, 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()
+  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=", ")))
-    }
+      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))
+      # For css styling
+      classNames <- paste0("table shiny-table",
+        paste0(" table-", names(format)[format], collapse = "" ),
+        paste0(" spacing-", spacing))
 
-    data <- func()
-    data <- as.data.frame(data)
+      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)
+      # 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)]
+      # 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"
-    }
+      # 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="")
+      # 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 {
-        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")
+        ## 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))
+      # 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), ";'"))
+      # 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))]
+      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")
+      # 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)
+      # 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)
+      # 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))
+        # 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"
+        # 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)
+        # 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)
-  }
-
-  # Main render function
-  markRenderFunction(tableOutput, renderFunc, outputArgs = outputArgs)
+      return(tab)
+    },
+    tableOutput, outputArgs
+  )
 }

R/serializers.R

@@ -1,3 +1,22 @@
+#' 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
@@ -58,12 +77,12 @@ serializeReactiveValues <- function(values, exclude, stateDir = NULL) {
 
     # Get the serializer function for this input value. If none specified, use
     # the default.
-    serializer <- impl$getMeta(name, "shiny.serializer")
-    if (is.null(serializer))
-      serializer <- serializerDefault
+    serializer_fun <- impl$getMeta(name, "shiny.serializer")
+    if (is.null(serializer_fun))
+      serializer_fun <- serializerDefault
 
     # Apply serializer function.
-    serializer(val, stateDir)
+    serializer_fun(val, stateDir)
   })
 
   # Filter out any values that were marked as unserializable.

R/server-input-handlers.R

@@ -142,13 +142,14 @@ registerInputHandler("shiny.matrix", function(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
-  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
+  setSerializer(name, serializerUnserializable)
   val
 })
 
@@ -214,7 +215,27 @@ registerInputHandler("shiny.file", function(val, shinysession, name) {
   # 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`.
-  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerFileInput)
+  setSerializer(name, serializerFileInput)
+
+  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
 
   val
 })
+
+
+# to be used with !!!answer
+registerInputHandler("shiny.symbolList", function(val, ...) {
+  if (is.null(val)) {
+    list()
+  } else {
+    lapply(val, as.symbol)
+  }
+})
+# to be used with !!answer
+registerInputHandler("shiny.symbol", function(val, ...) {
+  if (is.null(val) || identical(val, "")) {
+    NULL
+  } else {
+    as.symbol(val)
+  }
+})

R/server.R

@@ -1,6 +1,7 @@
 #' @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.
@@ -21,7 +22,7 @@ registerClient <- function(client) {
 }
 
 
-.globals$resources <- list()
+.globals$resourcePaths <- list()
 
 .globals$showcaseDefault <- 0
 
@@ -40,11 +41,6 @@ registerClient <- function(client) {
 #' @param directoryPath The directory that contains the static resources to be
 #'   served.
 #'
-#' @details You can call \code{addResourcePath} multiple times for a given
-#'   \code{prefix}; only the most recent value will be retained. If the
-#'   normalized \code{directoryPath} is different than the directory that's
-#'   currently mapped to the \code{prefix}, a warning will be issued.
-#'
 #' @seealso \code{\link{singleton}}
 #'
 #' @examples
@@ -52,46 +48,29 @@ registerClient <- function(client) {
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
-  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case = TRUE, perl = TRUE)) {
     stop("addResourcePath called with invalid prefix; please see documentation")
   }
-
   if (prefix %in% c('shared')) {
     stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
          "please use a different prefix")
   }
+  normalizedPath <- tryCatch(normalizePath(directoryPath, mustWork = TRUE),
+    error = function(e) {
+      stop("Couldn't normalize path in `addResourcePath`, with arguments: ",
+        "`prefix` = '", prefix, "'; `directoryPath` = '" , directoryPath, "'")
+    }
+  )
 
-  directoryPath <- normalizePath(directoryPath, mustWork=TRUE)
+  # 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))
+  }
 
-  existing <- .globals$resources[[prefix]]
-
-  .globals$resources[[prefix]] <- list(directoryPath=directoryPath,
-                                       func=staticHandler(directoryPath))
-}
-
-resourcePathHandler <- function(req) {
-  if (!identical(req$REQUEST_METHOD, 'GET'))
-    return(NULL)
-
-  path <- req$PATH_INFO
-
-  match <- regexpr('^/([^/]+)/', path, perl=TRUE)
-  if (match == -1)
-    return(NULL)
-  len <- attr(match, 'capture.length')
-  prefix <- substr(path, 2, 2 + len - 1)
-
-  resInfo <- .globals$resources[[prefix]]
-  if (is.null(resInfo))
-    return(NULL)
-
-  suffix <- substr(path, 2 + len, nchar(path))
-
-  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))
+  # .globals$resourcePaths persists across runs of applications.
+  .globals$resourcePaths[[prefix]] <- staticPath(normalizedPath)
 }
 
 #' Define Server Functionality
@@ -155,7 +134,7 @@ decodeMessage <- function(data) {
     # Treat message as UTF-8
     charData <- rawToChar(data)
     Encoding(charData) <- 'UTF-8'
-    return(jsonlite::fromJSON(charData, simplifyVector=FALSE))
+    return(safeFromJSON(charData, simplifyVector=FALSE))
   }
 
   i <- 5
@@ -179,23 +158,19 @@ 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).
-  sharedSecret <- getOption('shiny.sharedSecret')
+  checkSharedSecret <- loadSharedSecret()
 
   appHandlers <- list(
     http = joinHandlers(c(
       sessionHandler,
       httpHandlers,
-      sys.www.root,
-      resourcePathHandler,
-      reactLogHandler)),
+      reactLogHandler
+    )),
     ws = function(ws) {
-      if (!is.null(sharedSecret)
-          && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
+      if (!checkSharedSecret(ws$request$HTTP_SHINY_SHARED_SECRET)) {
         ws$close()
         return(TRUE)
       }
@@ -226,7 +201,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
               message("RECV ", rawToChar(msg))
           }
 
-          if (identical(charToRaw("\003\xe9"), msg))
+          if (isEmptyMessage(msg))
             return()
 
           msg <- decodeMessage(msg)
@@ -243,94 +218,87 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
             } else {
               # If there's bookmarked state, save it on the session object
               shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
+              shinysession$createBookmarkObservers()
             }
           }
 
-          withRestoreContext(shinysession$restoreContext, {
 
-            msg$data <- applyInputHandlers(msg$data)
+          msg$data <- applyInputHandlers(msg$data)
 
-            switch(
-              msg$method,
-              init = {
+          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")
-                  }
+              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)
-                }
+              # 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)
+              }
 
-                shinysession$manageInputs(msg$data)
+              # 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]]
-                }
+              # 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)
+              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
-                    )
-                  })
+                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)
-            )
-            shinysession$manageHiddenOutputs()
+              })
+            },
+            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()
 
-            if (exists(".shiny__stdout", globalenv()) &&
-                exists("HTTP_GUID", ws$request)) {
-              # safe to assume we're in shiny-server
-              shiny_stdout <- get(".shiny__stdout", globalenv())
-
-              # eNter a flushReact
-              writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-
-              flushReact()
-
-              # eXit a flushReact
-              writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-            } else {
-              flushReact()
-            }
-
-            flushAllSessions()
-          })
+          # Make httpuv return control to Shiny quickly, instead of waiting
+          # for the usual timeout
+          httpuv::interrupt()
         })
       }
       ws$onMessage(function(binary, msg) {
@@ -341,6 +309,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       ws$onClose(function() {
         shinysession$wsClosed()
         appsByToken$remove(shinysession$token)
+        appsNeedingFlush$remove(shinysession$token)
       })
 
       return(TRUE)
@@ -370,9 +339,9 @@ argsForServerFunc <- function(serverFunc, session) {
 }
 
 getEffectiveBody <- function(func) {
-  # Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
-  # returns NULL.
-  if (isS4(func) && class(func) == "functionWithTrace")
+  if (is.null(func))
+    NULL
+  else if (isS4(func) && class(func) == "functionWithTrace")
     body(func@original)
   else
     body(func)
@@ -420,11 +389,35 @@ startApp <- function(appObj, port, host, quiet) {
   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
+  )
+  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) {
-      message('\n', 'Listening on http://', host, ':', port)
+      hostString <- host
+      if (httpuv::ipFamily(host) == 6L)
+        hostString <- paste0("[", hostString, "]")
+      message('\n', 'Listening on http://', hostString, ':', port)
     }
-    return(startServer(host, port, handlerManager$createHttpuvApp()))
+    return(startServer(host, port, httpuvApp))
   } else if (is.character(port)) {
     if (!quiet) {
       message('\n', 'Listening on domain socket ', port)
@@ -436,28 +429,27 @@ startApp <- function(appObj, port, host, quiet) {
            "configuration (and not domain sockets), then `port` must ",
            "be numeric, not a string.")
     }
-    return(startPipeServer(port, mask, handlerManager$createHttpuvApp()))
+    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() {
-  if (timerCallbacks$executeElapsed()) {
-    for (shinysession in appsByToken$values()) {
-      shinysession$manageHiddenOutputs()
-    }
+  timerCallbacks$executeElapsed()
 
-    flushReact()
-    flushAllSessions()
-  }
+  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()))
+  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs()))
   service(timeout)
+
+  flushReact()
+  flushPendingSessions()
 }
 
 .shinyServerMinVersion <- '0.3.4'
@@ -465,6 +457,17 @@ serviceApp <- function() {
 # Global flag that's TRUE whenever we're inside of the scope of a call to runApp
 .globals$running <- FALSE
 
+#' Check whether a Shiny application is running
+#'
+#' This function tests whether a Shiny application is currently running.
+#'
+#' @return \code{TRUE} if a Shiny application is currently running. Otherwise,
+#'   \code{FALSE}.
+#' @export
+isRunning <- function() {
+  .globals$running
+}
+
 #' Run Shiny Application
 #'
 #' Runs a Shiny application. This function normally does not return; interrupt R
@@ -569,17 +572,30 @@ runApp <- function(appDir=getwd(),
     .globals$running <- FALSE
   }, add = TRUE)
 
-  # Enable per-app Shiny options
+  # Enable per-app Shiny options, for shinyOptions() and getShinyOption().
   oldOptionSet <- .globals$options
   on.exit({
     .globals$options <- oldOptionSet
   },add = TRUE)
 
+  # A unique identifier associated with this run of this application. It is
+  # shared across sessions.
+  shinyOptions(appToken = createUniqueId(8))
+
   # Make warnings print immediately
   # Set pool.scheduler to support pool package
-  ops <- options(warn = 1, pool.scheduler = scheduleTask)
+  ops <- options(
+    # Raise warn level to 1, but don't lower it
+    warn = max(1, getOption("warn", default = 1)),
+    pool.scheduler = scheduleTask
+  )
   on.exit(options(ops), add = TRUE)
 
+  # Set up default cache for app.
+  if (is.null(getShinyOption("cache"))) {
+    shinyOptions(cache = MemoryCache$new())
+  }
+
   appParts <- as.shiny.appobj(appDir)
 
   # The lines below set some of the app's running options, which
@@ -716,7 +732,8 @@ runApp <- function(appDir=getwd(),
           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
-          if (!port %in% c(3659, 4045, 6000, 6665:6669)) {
+          # https://github.com/rstudio/shiny/issues/1784
+          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
             break
           }
         }
@@ -732,27 +749,47 @@ runApp <- function(appDir=getwd(),
     }
   }
 
+  # Invoke user-defined onStop callbacks, before the application's internal
+  # onStop callbacks.
+  on.exit({
+    .globals$onStopCallbacks$invoke()
+    .globals$onStopCallbacks <- Callbacks$new()
+  }, add = TRUE)
+
   # Extract appOptions (which is a list) and store them as shinyOptions, for
   # this app. (This is the only place we have to store settings that are
   # accessible both the UI and server portion of the app.)
   unconsumeAppOptions(appParts$appOptions)
 
-  # Set up the onEnd before we call onStart, so that it gets called even if an
+  # Set up the onStop before we call onStart, so that it gets called even if an
   # error happens in onStart.
-  if (!is.null(appParts$onEnd))
-    on.exit(appParts$onEnd(), add = TRUE)
+  if (!is.null(appParts$onStop))
+    on.exit(appParts$onStop(), add = TRUE)
   if (!is.null(appParts$onStart))
     appParts$onStart()
 
   server <- startApp(appParts, port, host, quiet)
 
+  # Make the httpuv server object accessible. Needed for calling
+  # addResourcePath while app is running.
+  shinyOptions(server = server)
+
   on.exit({
     stopServer(server)
   }, add = TRUE)
 
   if (!is.character(port)) {
-    # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
-    browseHost <- if (identical(host, "0.0.0.0")) "127.0.0.1" else host
+    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))
@@ -776,12 +813,8 @@ runApp <- function(appDir=getwd(),
   # reactive(), Callbacks$invoke(), and others
   ..stacktraceoff..(
     captureStackTraces({
-      # If any observers were created before runApp was called, this will make
-      # sure they run once the app starts. (Issue #1013)
-      scheduleFlush()
-
       while (!.globals$stopped) {
-        serviceApp()
+        ..stacktracefloor..(serviceApp())
         Sys.sleep(0.001)
       }
     })
@@ -1022,3 +1055,9 @@ browserViewer <- function(browser = getOption("browser")) {
 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(charToRaw("\003\xe9"), msg)
+}

R/shinywrappers.R

@@ -1,4 +1,4 @@
-globalVariables('func')
+utils::globalVariables('func')
 
 #' Mark a function as a render function
 #'
@@ -52,6 +52,49 @@ markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
             hasExecuted = hasExecuted)
 }
 
+#' Implement render functions
+#'
+#' @param func A function without parameters, that returns user data. If the
+#'   returned value is a promise, then the render function will proceed in async
+#'   mode.
+#' @param transform A function that takes four arguments: \code{value},
+#'   \code{session}, \code{name}, and \code{...} (for future-proofing). This
+#'   function will be invoked each time a value is returned from \code{func},
+#'   and is responsible for changing the value into a JSON-ready value to be
+#'   JSON-encoded and sent to the browser.
+#' @param outputFunc The UI function that is used (or most commonly used) with
+#'   this render function. This can be used in R Markdown documents to create
+#'   complete output widgets out of just the render function.
+#' @param outputArgs A list of arguments to pass to the \code{outputFunc}.
+#'   Render functions should include \code{outputArgs = list()} in their own
+#'   parameter list, and pass through the value as this argument, to allow app
+#'   authors to customize outputs. (Currently, this is only supported for
+#'   dynamically generated UIs, such as those created by Shiny code snippets
+#'   embedded in R Markdown documents).
+#' @return An annotated render function, ready to be assigned to an
+#'   \code{output} slot.
+#'
+#' @export
+createRenderFunction <- function(
+  func, transform = function(value, session, name, ...) value,
+  outputFunc = NULL, outputArgs = NULL
+) {
+
+  renderFunc <- function(shinysession, name, ...) {
+    hybrid_chain(
+      func(),
+      function(value, .visible) {
+        transform(setVisible(value, .visible), shinysession, name, ...)
+      }
+    )
+  }
+
+  if (!is.null(outputFunc))
+    markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+  else
+    renderFunc
+}
+
 useRenderFunction <- function(renderFunc, inline = FALSE) {
   outputFunction <- attr(renderFunc, "outputFunc")
   outputArgs <- attr(renderFunc, "outputArgs")
@@ -68,12 +111,16 @@ useRenderFunction <- function(renderFunc, inline = FALSE) {
   }
 
   id <- createUniqueId(8, "out")
-  # Make the id the first positional argument
-  outputArgs <- c(list(id), outputArgs)
 
   o <- getDefaultReactiveDomain()$output
-  if (!is.null(o))
+  if (!is.null(o)) {
     o[[id]] <- renderFunc
+    # If there's a namespace, we must respect it
+    id <- getDefaultReactiveDomain()$ns(id)
+  }
+
+  # Make the id the first positional argument
+  outputArgs <- c(list(id), outputArgs)
 
   if (is.logical(formals(outputFunction)[["inline"]]) && !("inline" %in% names(outputArgs))) {
     outputArgs[["inline"]] <- inline
@@ -93,9 +140,13 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'
 #' @inheritParams markRenderFunction
 #' @param snapshotExclude If TRUE, exclude the output from test snapshots.
+#' @param snapshotPreprocess A function for preprocessing the value before
+#'   taking a test snapshot.
 #'
 #' @keywords internal
-markOutputAttrs <- function(renderFunc, snapshotExclude = NULL) {
+markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
+  snapshotPreprocess = NULL)
+{
   # Add the outputAttrs attribute if necessary
   if (is.null(attr(renderFunc, "outputAttrs", TRUE))) {
     attr(renderFunc, "outputAttrs") <- list()
@@ -105,6 +156,10 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL) {
     attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
   }
 
+  if (!is.null(snapshotPreprocess)) {
+    attr(renderFunc, "outputAttrs")$snapshotPreprocess <- snapshotPreprocess
+  }
+
   renderFunc
 }
 
@@ -214,26 +269,25 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
                         deleteFile=TRUE, outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    imageinfo <- func()
-    # Should the file be deleted after being sent? If .deleteFile not set or if
-    # TRUE, then delete; otherwise don't delete.
-    if (deleteFile) {
-      on.exit(unlink(imageinfo$src))
-    }
+  createRenderFunction(func,
+    transform = function(imageinfo, session, name, ...) {
+      # Should the file be deleted after being sent? If .deleteFile not set or if
+      # TRUE, then delete; otherwise don't delete.
+      if (deleteFile) {
+        on.exit(unlink(imageinfo$src))
+      }
 
-    # If contentType not specified, autodetect based on extension
-    contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
+      # If contentType not specified, autodetect based on extension
+      contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
 
-    # Extra values are everything in imageinfo except 'src' and 'contentType'
-    extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
+      # Extra values are everything in imageinfo except 'src' and 'contentType'
+      extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
 
-    # Return a list with src, and other img attributes
-    c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
-      extra_attr)
-  }
-
-  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
+      # Return a list with src, and other img attributes
+      c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
+        extra_attr)
+    },
+    imageOutput, outputArgs)
 }
 
 
@@ -273,15 +327,74 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
                         width = getOption('width'), outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
+  # Set a promise domain that sets the console width
+  #   and captures output
+  # op <- options(width = width)
+  # on.exit(options(op), add = TRUE)
+
   renderFunc <- function(shinysession, name, ...) {
-    op <- options(width = width)
-    on.exit(options(op), add = TRUE)
-    paste(utils::capture.output(func()), collapse = "\n")
+    domain <- createRenderPrintPromiseDomain(width)
+    hybrid_chain(
+      {
+        promises::with_promise_domain(domain, func())
+      },
+      function(value, .visible) {
+        if (.visible) {
+          cat(file = domain$conn, paste(utils::capture.output(value, append = TRUE), collapse = "\n"))
+        }
+        res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
+        res
+      },
+      finally = function() {
+        close(domain$conn)
+      }
+    )
   }
 
   markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
 }
 
+createRenderPrintPromiseDomain <- function(width) {
+  f <- file()
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      op <- options(width = width)
+      on.exit(options(op), add = TRUE)
+
+      sink(f, append = TRUE)
+      on.exit(sink(NULL), add = TRUE)
+
+      force(expr)
+    },
+    conn = f
+  )
+}
+
 #' Text Output
 #'
 #' Makes a reactive version of the given function that also uses
@@ -313,18 +426,18 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
                        outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    value <- func()
-    return(paste(utils::capture.output(cat(value)), collapse="\n"))
-  }
-
-  markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
+  createRenderFunction(
+    func,
+    function(value, session, name, ...) {
+      paste(utils::capture.output(cat(value)), collapse="\n")
+    },
+    textOutput, outputArgs
+  )
 }
 
 #' UI Output
 #'
-#' \bold{Experimental feature.} Makes a reactive version of a function that
-#' generates HTML using the Shiny UI library.
+#' Renders reactive HTML using the Shiny UI library.
 #'
 #' The corresponding HTML output tag should be \code{div} and have the CSS class
 #' name \code{shiny-html-output} (or use \code{\link{uiOutput}}).
@@ -338,7 +451,7 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #'   call to \code{\link{uiOutput}} when \code{renderUI} is used in an
 #'   interactive R Markdown document.
 #'
-#' @seealso conditionalPanel
+#' @seealso \code{\link{uiOutput}}
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -363,15 +476,16 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
                      outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    result <- func()
-    if (is.null(result) || length(result) == 0)
-      return(NULL)
+  createRenderFunction(
+    func,
+    function(result, shinysession, name, ...) {
+      if (is.null(result) || length(result) == 0)
+        return(NULL)
 
-    processDeps(result, shinysession)
-  }
-
-  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
+      processDeps(result, shinysession)
+    },
+    uiOutput, outputArgs
+  )
 }
 
 #' File Downloads
@@ -509,31 +623,46 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     if (is.function(options)) options <- options()
     options <- checkDT9(options)
     res <- checkAsIs(options)
-    data <- func()
-    if (length(dim(data)) != 2) return() # expects a rectangular data object
-    if (is.data.frame(data)) data <- as.data.frame(data)
-    action <- shinysession$registerDataObj(name, data, dataTablesJSON)
-    colnames <- colnames(data)
-    # if escape is column names, turn names to numeric indices
-    if (is.character(escape)) {
-      escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
-      if (any(is.na(escape)))
-        stop("Some column names in the 'escape' argument not found in data")
-    }
-    colnames[escape] <- htmlEscape(colnames[escape])
-    if (!is.logical(escape)) {
-      if (!is.numeric(escape))
-        stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
-      escape <- paste(escape, collapse = ',')
-    }
-    list(
-      colnames = colnames, action = action, options = res$options,
-      evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
-      callback = paste(callback, collapse = '\n'), escape = escape
+    hybrid_chain(
+      func(),
+      function(data) {
+        if (length(dim(data)) != 2) return() # expects a rectangular data object
+        if (is.data.frame(data)) data <- as.data.frame(data)
+        action <- shinysession$registerDataObj(name, data, dataTablesJSON)
+        colnames <- colnames(data)
+        # if escape is column names, turn names to numeric indices
+        if (is.character(escape)) {
+          escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
+          if (any(is.na(escape)))
+            stop("Some column names in the 'escape' argument not found in data")
+        }
+        colnames[escape] <- htmlEscape(colnames[escape])
+        if (!is.logical(escape)) {
+          if (!is.numeric(escape))
+            stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
+          escape <- paste(escape, collapse = ',')
+        }
+        list(
+          colnames = colnames, action = action, options = res$options,
+          evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
+          callback = paste(callback, collapse = '\n'), escape = escape
+        )
+      }
     )
   }
 
-  markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+
+  renderFunc <- snapshotPreprocessOutput(renderFunc, function(value) {
+    # Remove the action field so that it's not saved in test snapshots. It
+    # contains a value that changes every time an app is run, and shouldn't be
+    # stored for test snapshots. It will be something like:
+    # "session/e0d14d3fe97f672f9655a127f2a1e079/dataobj/table?w=&nonce=7f5d6d54e22450a3"
+    value$action <- NULL
+    value
+  })
+
+  renderFunc
 }
 
 # a data frame containing the DataTables 1.9 and 1.10 names

R/snapshot.R

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

@@ -42,6 +42,17 @@ TimerCallbacks <- R6Class(
 
       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)
@@ -79,13 +90,9 @@ timerCallbacks <- TimerCallbacks$new()
 
 scheduleTask <- function(millis, callback) {
   cancelled <- FALSE
-  timerCallbacks$schedule(millis, function() {
-    if (!cancelled)
-      callback()
-  })
+  id <- timerCallbacks$schedule(millis, callback)
 
   function() {
-    cancelled <<- TRUE
-    callback <<- NULL # to allow for callback to be gc'ed
+    invisible(timerCallbacks$unschedule(id))
   }
 }

R/update-input.R

@@ -2,6 +2,7 @@
 #'
 #' @template update-input
 #' @param value The value to set for the input object.
+#' @param placeholder The placeholder to set for the input object.
 #'
 #' @seealso \code{\link{textInput}}
 #'
@@ -34,15 +35,15 @@
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
-  message <- dropNulls(list(label=label, value=value))
+updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeholder = NULL) {
+  message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
   session$sendInputMessage(inputId, message)
 }
 
 #' Change the value of a textarea input on the client
 #'
 #' @template update-input
-#' @param value The value to set for the input object.
+#' @inheritParams updateTextInput
 #'
 #' @seealso \code{\link{textAreaInput}}
 #'
@@ -106,7 +107,10 @@ updateTextAreaInput <- updateTextInput
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateCheckboxInput <- updateTextInput
+updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
+  message <- dropNulls(list(label=label, value=value))
+  session$sendInputMessage(inputId, message)
+}
 
 
 #' Change the label or icon of an action button on the client
@@ -379,13 +383,17 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
   session$sendInputMessage(inputId, message)
 }
 
-#' Change the value of a slider input on the client
+#' Update Slider Input Widget
+#'
+#' Change the value of a slider input on the client.
 #'
 #' @template update-input
 #' @param value The value to set for the input object.
 #' @param min Minimum value.
 #' @param max Maximum value.
 #' @param step Step size.
+#' @param timeFormat Date and POSIXt formatting.
+#' @param timezone The timezone offset for POSIXt objects.
 #'
 #' @seealso \code{\link{sliderInput}}
 #'
@@ -418,22 +426,15 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #' }
 #' @export
 updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
-  min = NULL, max = NULL, step = NULL)
+  min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
 {
-  # Make sure that value, min, max all have the same type, because we need
-  # special handling for dates and datetimes.
-  vals <- dropNulls(list(value, min, max))
+  dataType <- getSliderType(min, max, value)
 
-  type <- unique(lapply(vals, function(x) {
-    if      (inherits(x, "Date"))   "date"
-    else if (inherits(x, "POSIXt")) "datetime"
-    else                            "number"
-  }))
-  if (length(type) > 1) {
-    stop("Type mismatch for value, min, and max")
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if ((length(type) == 1) && (type == "date" || type == "datetime")) {
+  if (dataType == "date" || dataType == "datetime") {
     to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
     if (!is.null(min))   min   <- to_ms(min)
     if (!is.null(max))   max   <- to_ms(max)
@@ -445,7 +446,10 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
     value = formatNoSci(value),
     min = formatNoSci(min),
     max = formatNoSci(max),
-    step = formatNoSci(step)
+    step = formatNoSci(step),
+    `data-type` = dataType,
+    `time-format` = timeFormat,
+    timezone = timezone
   ))
   session$sendInputMessage(inputId, message)
 }
@@ -572,7 +576,7 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @template update-input
 #' @inheritParams selectInput
 #'
-#' @seealso \code{\link{selectInput}}
+#' @seealso \code{\link{selectInput}} \code{\link{varSelectInput}}
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -638,8 +642,95 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   if (!server) {
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
+
+  noOptGroup <- TRUE
+  if (is.list(choices)) {
+    # check if list is nested
+    for (i in seq_along(choices)) {
+      if (is.list(choices[[i]]) || length(choices[[i]]) > 1) {
+        noOptGroup <- FALSE
+        break()
+      }
+    }
+  }
+  # convert choices to a data frame so it returns [{label: , value: , optgroup: },...]
+  choices <- if (is.data.frame(choices)) {
+    # jcheng 2018/09/25: I don't think we ever said data frames were OK to pass
+    # to updateSelectInput, but one of the example apps does this and at least
+    # one user noticed when we broke it.
+    # https://github.com/rstudio/shiny/issues/2172
+    # https://github.com/rstudio/shiny/issues/2192
+    as.data.frame(choices, stringsAsFactors = FALSE)
+  } else if (is.atomic(choices) || noOptGroup) {
+    # fast path for vectors and flat lists
+    if (is.list(choices)) {
+      choices <- unlist(choices)
+    }
+    if (is.null(names(choices))) {
+      lab <- as.character(choices)
+    } else {
+      lab <- names(choices)
+      # replace empty names like: choices = c(a = 1, 2)
+      # in this case: names(choices) = c("a", "")
+      # with replacement below choices will be: lab = c("a", "2")
+      empty_names_indices <- lab == ""
+      lab[empty_names_indices] <- as.character(choices[empty_names_indices])
+    }
+    data.frame(label = lab, value = choices, stringsAsFactors = FALSE)
+  } else {
+    # slow path for nested lists/optgroups
+    list_names <- names(choices)
+    if (is.null(list_names)) {
+      list_names <- rep("", length(choices))
+    }
+
+    choice_list <- mapply(choices, list_names, FUN = function (choice, name) {
+      group <- ""
+      lab <- name
+      if (lab == "") lab <- as.character(choice)
+
+      if (is.list(choice) || length(choice) > 1) {
+        group <- rep(name, length(choice))
+        choice <- unlist(choice)
+
+        if (is.null(names(choice))) {
+          lab <- as.character(choice)
+        } else {
+          lab <- names(choice)
+          # replace empty names like: choices = c(a = 1, 2)
+          # in this case: names(choices) = c("a", "")
+          # with replacement below choices will be: lab = c("a", "2")
+          empty_names_indices <- lab == ""
+          lab[empty_names_indices] <- as.character(choice[empty_names_indices])
+        }
+      }
+
+      list(
+        label = lab,
+        value = as.character(choice),
+        # The name "optgroup" is because this is the default field where
+        # selectize will look for group IDs
+        optgroup = group
+      )
+    }, SIMPLIFY = FALSE)
+
+
+    extract_vector <- function(x, name) {
+      vecs <- lapply(x, `[[`, name)
+      do.call(c, vecs)
+    }
+
+    data.frame(
+      label = extract_vector(choice_list, "label"),
+      value = extract_vector(choice_list, "value"),
+      optgroup = extract_vector(choice_list, "optgroup"),
+      stringsAsFactors = FALSE, row.names = NULL
+    )
+  }
+
   value <- unname(selected)
   attr(choices, 'selected_value') <- value
+
   message <- dropNulls(list(
     label = label,
     value = value,
@@ -647,38 +738,76 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   ))
   session$sendInputMessage(inputId, message)
 }
+#' @rdname updateSelectInput
+#' @inheritParams varSelectInput
+#' @export
+updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected
+  )
+}
+#' @rdname updateSelectInput
+#' @export
+updateVarSelectizeInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL, options = list(), server = FALSE) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectizeInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected,
+    options = options,
+    server = server
+  )
+}
+
+
 
 selectizeJSON <- function(data, req) {
   query <- parseQueryString(req$QUERY_STRING)
+
   # extract the query variables, conjunction (and/or), search string, maximum options
-  var <- c(jsonlite::fromJSON(query$field))
-  cjn <- if (query$conju == 'and') all else any
+  var <- c(safeFromJSON(query$field))
+
   # all keywords in lower-case, for case-insensitive matching
   key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
+
   if (identical(key, '')) key <- character(0)
   mop <- as.numeric(query$maxop)
   vfd <- query$value  # the value field name
   sel <- attr(data, 'selected_value', exact = TRUE)
 
-  # convert a single vector to a data frame so it returns {label: , value: }
-  # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
-  data <- if (is.atomic(data)) {
-    data.frame(label = names(choicesWithNames(data)), value = data,
-               stringsAsFactors = FALSE)
-  } else as.data.frame(data, stringsAsFactors = FALSE)
-
   # start searching for keywords in all specified columns
   idx <- logical(nrow(data))
-  if (length(key)) for (v in var) {
-    matches <- do.call(
-      cbind,
-      lapply(key, function(k) {
-        grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
-      })
-    )
-    # merge column matches using OR, and match multiple keywords in one column
-    # using the conjunction setting (AND or OR)
-    idx <- idx | apply(matches, 1, cjn)
+  if (length(key)) {
+    for (v in var) {
+      matches <- do.call(
+        cbind,
+        lapply(key, function(k) {
+          grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
+        })
+      )
+      # merge column matches using OR, and match multiple keywords in one column
+      # using the conjunction setting (AND or OR)
+      matches <- rowSums(matches)
+      if (query$conju == 'and')
+        idx <- idx | (matches == length(key))
+      else
+        idx <- idx | matches
+    }
   }
   # only return the first n rows (n = maximum options in configuration)
   idx <- utils::head(if (length(key)) which(idx) else seq_along(idx), mop)

R/utils.R

@@ -43,53 +43,43 @@ repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max))
   }
 }
 
-# Temporarily set x in env to value, evaluate expr, and
-# then restore x to its original state
-withTemporary <- function(env, x, value, expr, unset = FALSE) {
-
-  if (exists(x, envir = env, inherits = FALSE)) {
-    oldValue <- get(x, envir = env, inherits = FALSE)
-    on.exit(
-      assign(x, oldValue, envir = env, inherits = FALSE),
-      add = TRUE)
-  } else {
-    on.exit(
-      rm(list = x, envir = env, inherits = FALSE),
-      add = TRUE
-    )
-  }
-
-  if (!missing(value) && !isTRUE(unset))
-    assign(x, value, envir = env, inherits = FALSE)
-  else {
-    if (exists(x, envir = env, inherits = FALSE))
-      rm(list = x, envir = env, inherits = FALSE)
-  }
-  force(expr)
-}
-
 .globals$ownSeed <- NULL
 # Evaluate an expression using Shiny's own private stream of
 # randomness (not affected by set.seed).
 withPrivateSeed <- function(expr) {
-  withTemporary(.GlobalEnv, ".Random.seed",
-    .globals$ownSeed, unset=is.null(.globals$ownSeed), {
-      tryCatch({
-        expr
-      }, finally = {
-        .globals$ownSeed <- getExists('.Random.seed', 'numeric', globalenv())
-      })
-    }
-  )
-}
+  # Save the old seed if present.
+  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
+    hasOrigSeed <- TRUE
+    origSeed <- .GlobalEnv$.Random.seed
+  } else {
+    hasOrigSeed <- FALSE
+  }
 
-# a homemade version of set.seed(NULL) for backward compatibility with R 2.15.x
-reinitializeSeed <- if (getRversion() >= '3.0.0') {
-  function() set.seed(NULL)
-} else function() {
-  if (exists('.Random.seed', globalenv()))
-    rm(list = '.Random.seed', pos = globalenv())
-  stats::runif(1)  # generate any random numbers so R can reinitialize the seed
+  # Swap in the private seed.
+  if (is.null(.globals$ownSeed)) {
+    if (hasOrigSeed) {
+      # Move old seed out of the way if present.
+      rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
+    }
+  } else {
+    .GlobalEnv$.Random.seed <- .globals$ownSeed
+  }
+
+  # On exit, save the modified private seed, and put the old seed back.
+  on.exit({
+    .globals$ownSeed <- .GlobalEnv$.Random.seed
+
+    if (hasOrigSeed) {
+      .GlobalEnv$.Random.seed <- origSeed
+    } else {
+      rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
+    }
+    # Need to call this to make sure that the value of .Random.seed gets put
+    # into R's internal RNG state. (Issue #1763)
+    httpuv::getRNGState()
+  })
+
+  expr
 }
 
 # Version of runif that runs with private seed
@@ -131,8 +121,8 @@ isWholeNum <- function(x, tol = .Machine$double.eps^0.5) {
 }
 
 `%AND%` <- function(x, y) {
-  if (!is.null(x) && !is.na(x))
-    if (!is.null(y) && !is.na(y))
+  if (!is.null(x) && !isTRUE(is.na(x)))
+    if (!is.null(y) && !isTRUE(is.na(y)))
       return(y)
   return(NULL)
 }
@@ -225,7 +215,7 @@ sortByName <- function(x) {
 # R >=3.2.0, this wrapper is not necessary.
 list2env2 <- function(x, ...) {
   # Ensure that zero-length lists have a name attribute
-   if (length(x) == 0)
+  if (length(x) == 0)
     attr(x, "names") <- character(0)
 
   list2env(x, ...)
@@ -279,6 +269,25 @@ dirExists <- function(paths) {
   file.exists(paths) & file.info(paths)$isdir
 }
 
+# Removes empty directory (vectorized). This is needed because file.remove()
+# on Unix will remove empty directories, but on Windows, it will not. On
+# Windows, you would need to use unlink(recursive=TRUE), which is not very
+# safe. This function does it safely on Unix and Windows.
+dirRemove <- function(path) {
+  for (p in path) {
+    if (!dirExists(p)) {
+      stop("Cannot remove non-existent directory ", p, ".")
+    }
+    if (length(dir(p, all.files = TRUE, no.. = TRUE)) != 0) {
+      stop("Cannot remove non-empty directory ", p, ".")
+    }
+    result <- unlink(p, recursive = TRUE)
+    if (result == 1) {
+      stop("Error removing directory ", p, ".")
+    }
+  }
+}
+
 # Attempt to join a path and relative path, and turn the result into a
 # (normalized) absolute path. The result will only be returned if it is an
 # existing file/directory and is a descendant of dir.
@@ -672,6 +681,9 @@ Callbacks <- R6Class(
       .callbacks <<- Map$new()
     },
     register = function(callback) {
+      if (!is.function(callback)) {
+        stop("callback must be a function")
+      }
       id <- as.character(.nextId)
       .nextId <<- .nextId - 1L
       .callbacks$set(id, callback)
@@ -1038,7 +1050,7 @@ safeError <- function(error) {
 # #' @examples
 # #' ## Note: the breaking of the reactive chain that happens in the app
 # #' ## below (when input$txt = 'bad' and input$allowBad = 'FALSE') is
-# #' ## easily visualized with `showReactLog()`
+# #' ## easily visualized with `reactlogShow()`
 # #'
 # #' ## Only run examples in interactive R sessions
 # #' if (interactive()) {
@@ -1539,7 +1551,10 @@ writeUTF8 <- function(text, ...) {
   writeLines(text, ..., useBytes = TRUE)
 }
 
-URLdecode <- decodeURIComponent
+URLdecode <- function(value) {
+  decodeURIComponent(value)
+}
+
 URLencode <- function(value, reserved = FALSE) {
   value <- enc2utf8(value)
   if (reserved) encodeURIComponent(value) else encodeURI(value)
@@ -1585,3 +1600,182 @@ Mutable <- R6Class("Mutable",
     get = function() { private$value }
   )
 )
+
+# More convenient way of chaining together promises than then/catch/finally,
+# without the performance impact of %...>%.
+promise_chain <- function(promise, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    p <- Reduce(function(memo, func) {
+      promises::then(memo, func)
+    }, list(...), promise)
+
+    if (!is.null(catch)) {
+      p <- promises::catch(p, catch)
+    }
+
+    if (!is.null(finally)) {
+      p <- promises::finally(p, finally)
+    }
+
+    p
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Like promise_chain, but if `expr` returns a non-promise, then `...`, `catch`,
+# and `finally` are all executed synchronously
+hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    runFinally <- TRUE
+    tryCatch(
+      {
+        captureStackTraces({
+          result <- withVisible(force(expr))
+          if (promises::is.promising(result$value)) {
+            # Purposefully NOT including domain (nor replace), as we're already in
+            # the domain at this point
+            p <- promise_chain(setVisible(result), ..., catch = catch, finally = finally)
+            runFinally <- FALSE
+            p
+          } else {
+            result <- Reduce(function(v, func) {
+              if (".visible" %in% names(formals(func))) {
+                withVisible(func(v$value, .visible = v$visible))
+              } else {
+                withVisible(func(v$value))
+              }
+            }, list(...), result)
+
+            setVisible(result)
+          }
+        })
+      },
+      error = function(e) {
+        if (!is.null(catch))
+          catch(e)
+        else
+          stop(e)
+      },
+      finally = if (runFinally && !is.null(finally)) finally()
+    )
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Returns `value` with either `invisible()` applied or not, depending on the
+# value of `visible`.
+#
+# If the `visible` is missing, then `value` should be a list as returned from
+# `withVisible()`, and that visibility will be applied.
+setVisible <- function(value, visible) {
+  if (missing(visible)) {
+    visible <- value$visible
+    value <- value$value
+  }
+
+  if (!visible) {
+    invisible(value)
+  } else {
+    (value)
+  }
+}
+
+createVarPromiseDomain <- function(env, name, value) {
+  force(env)
+  force(name)
+  force(value)
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      orig <- env[[name]]
+      env[[name]] <- value
+      on.exit(env[[name]] <- orig)
+
+      force(expr)
+    }
+  )
+}
+
+getSliderType <- function(min, max, value) {
+  vals <- dropNulls(list(value, min, max))
+  type <- unique(lapply(vals, function(x) {
+    if      (inherits(x, "Date"))   "date"
+    else if (inherits(x, "POSIXt")) "datetime"
+    else                            "number"
+  }))
+  if (length(type) > 1) {
+    stop("Type mismatch for `min`, `max`, and `value`. Each must be Date, POSIXt, or number.")
+  }
+  type[[1]]
+}
+
+# Reads the `shiny.sharedSecret` global option, and returns a function that can
+# be used to test header values for a match.
+loadSharedSecret <- function() {
+  normalizeToRaw <- function(value, label = "value") {
+    if (is.null(value)) {
+      raw()
+    } else if (is.character(value)) {
+      charToRaw(paste(value, collapse = "\n"))
+    } else if (is.raw(value)) {
+      value
+    } else {
+      stop("Wrong type for ", label, "; character or raw expected")
+    }
+  }
+
+  sharedSecret <- normalizeToRaw(getOption("shiny.sharedSecret"))
+  if (is.null(sharedSecret)) {
+    function(x) TRUE
+  } else {
+    # We compare the digest of the two values so that their lengths are equalized
+    function(x) {
+      x <- normalizeToRaw(x)
+      # Constant time comparison to avoid timing attacks
+      constantTimeEquals(sharedSecret, x)
+    }
+  }
+}
+
+# Compares two raw vectors of equal length for equality, in constant time
+constantTimeEquals <- function(raw1, raw2) {
+  stopifnot(is.raw(raw1))
+  stopifnot(is.raw(raw2))
+  if (length(raw1) != length(raw2)) {
+    return(FALSE)
+  }
+
+  sum(as.integer(xor(raw1, raw2))) == 0
+}

README.md

@@ -8,6 +8,8 @@ Shiny is a new package from RStudio that makes it incredibly easy to build inter
 
 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).
+
 ## Features
 
 * Build useful web applications with only a few lines of code—no JavaScript required.
@@ -16,7 +18,7 @@ For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstu
 * 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/).
 * A highly customizable slider widget with built-in support for animation.
-* Pre-built output widgets for displaying plots, tables, and printed output of R objects.
+* 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.
 * 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!).
@@ -41,8 +43,6 @@ devtools::install_github("rstudio/shiny")
 
 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.
 
-We hope you enjoy using Shiny. If you have general questions about using Shiny, please use the Shiny [mailing list](https://groups.google.com/forum/#!forum/shiny-discuss). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
-
 ## 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.
@@ -65,7 +65,4 @@ We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.
 
 ## License
 
-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
+The shiny package as a whole is licensed under the GPLv3. See the [LICENSE](LICENSE) file for more details.

TODO-promises.md

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

appveyor.yml

@@ -43,3 +43,7 @@ artifacts:
 
   - path: '\*_*.zip'
     name: Bits
+
+environment:
+  global:
+    USE_RTOOLS: true

inst/examples/01_hello/Readme.md

@@ -1,4 +1,3 @@
-This small Shiny application demonstrates Shiny's automatic UI updates. Move
-the *Number of bins* slider and notice how the `renderPlot` expression is
-automatically re-evaluated when its dependant, `input$bins`, changes,
-causing a histogram with a new number of bins to be rendered.
+This small Shiny application demonstrates Shiny's automatic UI updates. 
+
+Move the *Number of bins* slider and notice how the `renderPlot` expression is automatically re-evaluated when its dependant, `input$bins`, changes, causing a histogram with a new number of bins to be rendered.

inst/examples/01_hello/app.R

@@ -0,0 +1,59 @@
+library(shiny)
+
+# Define UI for app that draws a histogram ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Hello Shiny!"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Slider for the number of bins ----
+      sliderInput(inputId = "bins",
+                  label = "Number of bins:",
+                  min = 1,
+                  max = 50,
+                  value = 30)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Histogram ----
+      plotOutput(outputId = "distPlot")
+
+    )
+  )
+)
+
+# Define server logic required to draw a histogram ----
+server <- function(input, output) {
+
+  # Histogram of the Old Faithful Geyser Data ----
+  # with requested number of bins
+  # This expression that generates a histogram is wrapped in a call
+  # to renderPlot to indicate that:
+  #
+  # 1. It is "reactive" and therefore should be automatically
+  #    re-executed when inputs (input$bins) change
+  # 2. Its output type is a plot
+  output$distPlot <- renderPlot({
+
+    x    <- faithful$waiting
+    bins <- seq(min(x), max(x), length.out = input$bins + 1)
+
+    hist(x, breaks = bins, col = "#75AADB", border = "white",
+         xlab = "Waiting time to next eruption (in mins)",
+         main = "Histogram of waiting times")
+
+    })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = ui, server = server)

inst/examples/01_hello/server.R

@@ -1,21 +0,0 @@
-library(shiny)
-
-# Define server logic required to draw a histogram
-function(input, output) {
-
-  # Expression that generates a histogram. The expression is
-  # wrapped in a call to renderPlot to indicate that:
-  #
-  #  1) It is "reactive" and therefore should be automatically
-  #     re-executed when inputs change
-  #  2) Its output type is a plot
-
-  output$distPlot <- renderPlot({
-    x    <- faithful[, 2]  # Old Faithful Geyser data
-    bins <- seq(min(x), max(x), length.out = input$bins + 1)
-
-    # draw the histogram with the specified number of bins
-    hist(x, breaks = bins, col = 'darkgray', border = 'white')
-  })
-
-}

inst/examples/01_hello/ui.R

@@ -1,24 +0,0 @@
-library(shiny)
-
-# Define UI for application that draws a histogram
-fluidPage(
-
-  # Application title
-  titlePanel("Hello Shiny!"),
-
-  # Sidebar with a slider input for the number of bins
-  sidebarLayout(
-    sidebarPanel(
-      sliderInput("bins",
-                  "Number of bins:",
-                  min = 1,
-                  max = 50,
-                  value = 30)
-    ),
-
-    # Show a plot of the generated distribution
-    mainPanel(
-      plotOutput("distPlot")
-    )
-  )
-)

inst/examples/02_text/Readme.md

@@ -1 +1 @@
-This example demonstrates output of raw text from R using the `renderPrint` function in `server.R` and the `verbatimTextOutput` function in `ui.R`. In this case, a textual summary of the data is shown using R's built-in `summary` function. 
+This example demonstrates output of raw text from R using the `renderPrint` function in `server` and the `verbatimTextOutput` function in `ui`. In this case, a textual summary of the data is shown using R's built-in `summary` function. 

inst/examples/02_text/app.R

@@ -0,0 +1,64 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Shiny Text"),
+
+  # Sidebar layout with a input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Selector for choosing dataset ----
+      selectInput(inputId = "dataset",
+                  label = "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Numeric entry for number of obs to view ----
+      numericInput(inputId = "obs",
+                   label = "Number of observations to view:",
+                   value = 10)
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Verbatim text for data summary ----
+      verbatimTextOutput("summary"),
+
+      # Output: HTML table with requested number of observations ----
+      tableOutput("view")
+
+    )
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Generate a summary of the dataset ----
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = ui, server = server)

inst/examples/02_text/server.R

@@ -1,26 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the selected
-# dataset
-function(input, output) {
-  
-  # Return the requested dataset
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  # Generate a summary of the dataset
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-  
-  # Show the first "n" observations
-  output$view <- renderTable({
-    head(datasetInput(), n = input$obs)
-  })
-}

inst/examples/02_text/ui.R

@@ -1,27 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-fluidPage(
-  
-  # Application title
-  titlePanel("Shiny Text"),
-  
-  # Sidebar with controls to select a dataset and specify the
-  # number of observations to view
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      
-      numericInput("obs", "Number of observations to view:", 10)
-    ),
-    
-    # Show a summary of the dataset and an HTML table with the 
-    # requested number of observations
-    mainPanel(
-      verbatimTextOutput("summary"),
-      
-      tableOutput("view")
-    )
-  )
-)

inst/examples/03_reactivity/Readme.md

@@ -1,5 +1,5 @@
-This example demonstrates a core feature of Shiny: **reactivity**. In `server.R`, a reactive called `datasetInput` is declared. 
+This example demonstrates a core feature of Shiny: **reactivity**. In the `server` function, a reactive called `datasetInput` is declared. 
 
-Notice that the reactive expression depends on the input expression `input$dataset`, and that it's used by both the output expression `output$summary` and `output$view`. Try changing the dataset (using *Choose a dataset*) while looking at the reactive and then at the outputs; you will see first the reactive and then its dependencies flash. 
+Notice that the reactive expression depends on the input expression `input$dataset`, and that it's used by two output expressions: `output$summary` and `output$view`. Try changing the dataset (using *Choose a dataset*) while looking at the reactive and then at the outputs; you will see first the reactive and then its dependencies flash. 
 
 Notice also that the reactive expression doesn't just update whenever anything changes--only the inputs it depends on will trigger an update. Change the "Caption" field and notice how only the `output$caption` expression is re-evaluated; the reactive and its dependents are left alone.

inst/examples/03_reactivity/app.R

@@ -0,0 +1,102 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Reactivity"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Text for providing a caption ----
+      # Note: Changes made to the caption in the textInput control
+      # are updated in the output area immediately as you type
+      textInput(inputId = "caption",
+                label = "Caption:",
+                value = "Data Summary"),
+
+      # Input: Selector for choosing dataset ----
+      selectInput(inputId = "dataset",
+                  label = "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Numeric entry for number of obs to view ----
+      numericInput(inputId = "obs",
+                   label = "Number of observations to view:",
+                   value = 10)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Formatted text for caption ----
+      h3(textOutput("caption", container = span)),
+
+      # Output: Verbatim text for data summary ----
+      verbatimTextOutput("summary"),
+
+      # Output: HTML table with requested number of observations ----
+      tableOutput("view")
+
+    )
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  # By declaring datasetInput as a reactive expression we ensure
+  # that:
+  #
+  # 1. It is only called when the inputs it depends on changes
+  # 2. The computation and result are shared by all the callers,
+  #    i.e. it only executes a single time
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Create caption ----
+  # The output$caption is computed based on a reactive expression
+  # that returns input$caption. When the user changes the
+  # "caption" field:
+  #
+  # 1. This function is automatically called to recompute the output
+  # 2. New caption is pushed back to the browser for re-display
+  #
+  # Note that because the data-oriented reactive expressions
+  # below don't depend on input$caption, those expressions are
+  # NOT called when input$caption changes
+  output$caption <- renderText({
+    input$caption
+  })
+
+  # Generate a summary of the dataset ----
+  # The output$summary depends on the datasetInput reactive
+  # expression, so will be re-executed whenever datasetInput is
+  # invalidated, i.e. whenever the input$dataset changes
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  # The output$view depends on both the databaseInput reactive
+  # expression and input$obs, so it will be re-executed whenever
+  # input$dataset or input$obs is changed
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/03_reactivity/server.R

@@ -1,53 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the selected
-# dataset
-function(input, output) {
-
-  # By declaring datasetInput as a reactive expression we ensure 
-  # that:
-  #
-  #  1) It is only called when the inputs it depends on changes
-  #  2) The computation and result are shared by all the callers 
-  #     (it only executes a single time)
-  #
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  # The output$caption is computed based on a reactive expression
-  # that returns input$caption. When the user changes the
-  # "caption" field:
-  #
-  #  1) This function is automatically called to recompute the 
-  #     output 
-  #  2) The new caption is pushed back to the browser for 
-  #     re-display
-  # 
-  # Note that because the data-oriented reactive expressions
-  # below don't depend on input$caption, those expressions are
-  # NOT called when input$caption changes.
-  output$caption <- renderText({
-    input$caption
-  })
-  
-  # The output$summary depends on the datasetInput reactive
-  # expression, so will be re-executed whenever datasetInput is
-  # invalidated
-  # (i.e. whenever the input$dataset changes)
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-  
-  # The output$view depends on both the databaseInput reactive
-  # expression and input$obs, so will be re-executed whenever
-  # input$dataset or input$obs is changed. 
-  output$view <- renderTable({
-    head(datasetInput(), n = input$obs)
-  })
-}

inst/examples/03_reactivity/ui.R

@@ -1,34 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-fluidPage(
-  
-  # Application title
-  titlePanel("Reactivity"),
-  
-  # Sidebar with controls to provide a caption, select a dataset,
-  # and specify the number of observations to view. Note that
-  # changes made to the caption in the textInput control are
-  # updated in the output area immediately as you type
-  sidebarLayout(
-    sidebarPanel(
-      textInput("caption", "Caption:", "Data Summary"),
-      
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      
-      numericInput("obs", "Number of observations to view:", 10)
-    ),
-    
-    
-    # Show the caption, a summary of the dataset and an HTML 
-    # table with the requested number of observations
-    mainPanel(
-      h3(textOutput("caption", container = span)),
-      
-      verbatimTextOutput("summary"), 
-      
-      tableOutput("view")
-    )
-  )
-)

inst/examples/04_mpg/Readme.md

@@ -1,4 +1,4 @@
 This example demonstrates the following concepts:
 
-* **Global variables**: The `mpgData` variable is declared outside the `shinyServer` function. This makes it available anywhere inside `shinyServer`. The code in `server.R` outside `shinyServer` is only run once when the app starts up, so it can't contain user input.
-* **Reactive expressions**: `formulaText` is a reactive expression. Note how it re-evaluates when the Variable field is changed, but not when the Show Outliers box is ticked. 
+- **Global variables**: The `mpgData` variable is declared outside of the `ui` and `server` function definitions. This makes it available anywhere inside `app.R`. The code in `app.R` outside of `ui` and `server` function definitions is only run once when the app starts up, so it can't contain user input.
+- **Reactive expressions**: `formulaText` is a reactive expression. Note how it re-evaluates when the Variable field is changed, but not when the Show Outliers box is unchecked. 

inst/examples/04_mpg/app.R

@@ -0,0 +1,75 @@
+library(shiny)
+library(datasets)
+
+# Data pre-processing ----
+# Tweak the "am" variable to have nicer factor labels -- since this
+# doesn't rely on any user inputs, we can do this once at startup
+# and then use the value throughout the lifetime of the app
+mpgData <- mtcars
+mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
+
+
+# Define UI for miles per gallon app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Miles Per Gallon"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Selector for variable to plot against mpg ----
+      selectInput("variable", "Variable:",
+                  c("Cylinders" = "cyl",
+                    "Transmission" = "am",
+                    "Gears" = "gear")),
+
+      # Input: Checkbox for whether outliers should be included ----
+      checkboxInput("outliers", "Show outliers", TRUE)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Formatted text for caption ----
+      h3(textOutput("caption")),
+
+      # Output: Plot of the requested variable against mpg ----
+      plotOutput("mpgPlot")
+
+    )
+  )
+)
+
+# Define server logic to plot various variables against mpg ----
+server <- function(input, output) {
+
+  # Compute the formula text ----
+  # This is in a reactive expression since it is shared by the
+  # output$caption and output$mpgPlot functions
+  formulaText <- reactive({
+    paste("mpg ~", input$variable)
+  })
+
+  # Return the formula text for printing as a caption ----
+  output$caption <- renderText({
+    formulaText()
+  })
+
+  # Generate a plot of the requested variable against mpg ----
+  # and only exclude outliers if requested
+  output$mpgPlot <- renderPlot({
+    boxplot(as.formula(formulaText()),
+            data = mpgData,
+            outline = input$outliers,
+            col = "#75AADB", pch = 19)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/04_mpg/server.R

@@ -1,34 +0,0 @@
-library(shiny)
-library(datasets)
-
-# We tweak the "am" field to have nicer factor labels. Since
-# this doesn't rely on any user inputs we can do this once at
-# startup and then use the value throughout the lifetime of the
-# application
-mpgData <- mtcars
-mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
-
-
-# Define server logic required to plot various variables against
-# mpg
-function(input, output) {
-
-  # Compute the formula text in a reactive expression since it is
-  # shared by the output$caption and output$mpgPlot functions
-  formulaText <- reactive({
-    paste("mpg ~", input$variable)
-  })
-
-  # Return the formula text for printing as a caption
-  output$caption <- renderText({
-    formulaText()
-  })
-
-  # Generate a plot of the requested variable against mpg and
-  # only include outliers if requested
-  output$mpgPlot <- renderPlot({
-    boxplot(as.formula(formulaText()),
-            data = mpgData,
-            outline = input$outliers)
-  })
-}

inst/examples/04_mpg/ui.R

@@ -1,29 +0,0 @@
-library(shiny)
-
-# Define UI for miles per gallon application
-fluidPage(
-  
-  # Application title
-  titlePanel("Miles Per Gallon"),
-  
-  # Sidebar with controls to select the variable to plot against
-  # mpg and to specify whether outliers should be included
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("variable", "Variable:",
-                  c("Cylinders" = "cyl",
-                    "Transmission" = "am",
-                    "Gears" = "gear")),
-  
-      checkboxInput("outliers", "Show outliers", FALSE)
-    ),
-    
-    # Show the caption and plot of the requested variable against
-    # mpg
-    mainPanel(
-      h3(textOutput("caption")),
-      
-      plotOutput("mpgPlot")
-    )
-  )
-)

inst/examples/05_sliders/app.R

@@ -0,0 +1,86 @@
+library(shiny)
+
+# Define UI for slider demo app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Sliders"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar to demonstrate various slider options ----
+    sidebarPanel(
+
+      # Input: Simple integer interval ----
+      sliderInput("integer", "Integer:",
+                  min = 0, max = 1000,
+                  value = 500),
+
+      # Input: Decimal interval with step value ----
+      sliderInput("decimal", "Decimal:",
+                  min = 0, max = 1,
+                  value = 0.5, step = 0.1),
+
+      # Input: Specification of range within an interval ----
+      sliderInput("range", "Range:",
+                  min = 1, max = 1000,
+                  value = c(200,500)),
+
+      # Input: Custom currency format for with basic animation ----
+      sliderInput("format", "Custom Format:",
+                  min = 0, max = 10000,
+                  value = 0, step = 2500,
+                  pre = "$", sep = ",",
+                  animate = TRUE),
+
+      # Input: Animation with custom interval (in ms) ----
+      # to control speed, plus looping
+      sliderInput("animation", "Looping Animation:",
+                  min = 1, max = 2000,
+                  value = 1, step = 10,
+                  animate =
+                    animationOptions(interval = 300, loop = TRUE))
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Table summarizing the values entered ----
+      tableOutput("values")
+
+    )
+  )
+)
+
+# Define server logic for slider examples ----
+server <- function(input, output) {
+
+  # Reactive expression to create data frame of all input values ----
+  sliderValues <- reactive({
+
+    data.frame(
+      Name = c("Integer",
+               "Decimal",
+               "Range",
+               "Custom Format",
+               "Animation"),
+      Value = as.character(c(input$integer,
+                             input$decimal,
+                             paste(input$range, collapse = " "),
+                             input$format,
+                             input$animation)),
+      stringsAsFactors = FALSE)
+
+  })
+
+  # Show the values in an HTML table ----
+  output$values <- renderTable({
+    sliderValues()
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/05_sliders/server.R

@@ -1,29 +0,0 @@
-library(shiny)
-
-# Define server logic for slider examples
-function(input, output) {
-  
-  # Reactive expression to compose a data frame containing all of
-  # the values
-  sliderValues <- reactive({
-    
-    # Compose data frame
-    data.frame(
-      Name = c("Integer", 
-               "Decimal",
-               "Range",
-               "Custom Format",
-               "Animation"),
-      Value = as.character(c(input$integer, 
-                             input$decimal,
-                             paste(input$range, collapse=' '),
-                             input$format,
-                             input$animation)), 
-      stringsAsFactors=FALSE)
-  }) 
-  
-  # Show the values using an HTML table
-  output$values <- renderTable({
-    sliderValues()
-  })
-}

inst/examples/05_sliders/ui.R

@@ -1,43 +0,0 @@
-library(shiny)
-
-# Define UI for slider demo application
-fluidPage(
-
-  #  Application title
-  titlePanel("Sliders"),
-
-  # Sidebar with sliders that demonstrate various available
-  # options
-  sidebarLayout(
-    sidebarPanel(
-      # Simple integer interval
-      sliderInput("integer", "Integer:",
-                  min=0, max=1000, value=500),
-
-      # Decimal interval with step value
-      sliderInput("decimal", "Decimal:",
-                  min = 0, max = 1, value = 0.5, step= 0.1),
-
-      # Specification of range within an interval
-      sliderInput("range", "Range:",
-                  min = 1, max = 1000, value = c(200,500)),
-
-      # Provide a custom currency format for value display,
-    # with basic animation
-      sliderInput("format", "Custom Format:",
-                  min = 0, max = 10000, value = 0, step = 2500,
-                  pre = "$", sep = ",", animate=TRUE),
-
-      # Animation with custom interval (in ms) to control speed,
-    # plus looping
-      sliderInput("animation", "Looping Animation:", 1, 2000, 1,
-                  step = 10, animate =
-                  animationOptions(interval=300, loop=TRUE))
-    ),
-
-    # Show a table summarizing the values entered
-    mainPanel(
-      tableOutput("values")
-    )
-  )
-)

inst/examples/06_tabsets/Readme.md

@@ -2,7 +2,7 @@ This example demonstrates the `tabsetPanel` and `tabPanel` widgets.
 
 Notice that outputs that are not visible are not re-evaluated until they become visible. Try this: 
 
-1. Scroll to the bottom of `server.R`
+1. Scroll to the bottom of the `server` function. You might need to use the *show with app* option so you can easily view the code and interact with the app at the same time.
 2. Change the number of observations, and observe that only `output$plot` is evaluated.
 3. Click the Summary tab, and observe that `output$summary` is evaluated.
 4. Change the number of observations again, and observe that now only `output$summary` is evaluated.

inst/examples/06_tabsets/app.R

@@ -0,0 +1,92 @@
+library(shiny)
+
+# Define UI for random distribution app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Tabsets"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Select the random distribution type ----
+      radioButtons("dist", "Distribution type:",
+                   c("Normal" = "norm",
+                     "Uniform" = "unif",
+                     "Log-normal" = "lnorm",
+                     "Exponential" = "exp")),
+
+      # br() element to introduce extra vertical spacing ----
+      br(),
+
+      # Input: Slider for the number of observations to generate ----
+      sliderInput("n",
+                  "Number of observations:",
+                  value = 500,
+                  min = 1,
+                  max = 1000)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Tabset w/ plot, summary, and table ----
+      tabsetPanel(type = "tabs",
+                  tabPanel("Plot", plotOutput("plot")),
+                  tabPanel("Summary", verbatimTextOutput("summary")),
+                  tabPanel("Table", tableOutput("table"))
+      )
+
+    )
+  )
+)
+
+# Define server logic for random distribution app ----
+server <- function(input, output) {
+
+  # Reactive expression to generate the requested distribution ----
+  # This is called whenever the inputs change. The output functions
+  # defined below then use the value computed from this expression
+  d <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+
+    dist(input$n)
+  })
+
+  # Generate a plot of the data ----
+  # Also uses the inputs to build the plot label. Note that the
+  # dependencies on the inputs and the data reactive expression are
+  # both tracked, and all expressions are called in the sequence
+  # implied by the dependency graph.
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+
+    hist(d(),
+         main = paste("r", dist, "(", n, ")", sep = ""),
+         col = "#75AADB", border = "white")
+  })
+
+  # Generate a summary of the data ----
+  output$summary <- renderPrint({
+    summary(d())
+  })
+
+  # Generate an HTML table view of the data ----
+  output$table <- renderTable({
+    d()
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/06_tabsets/server.R

@@ -1,44 +0,0 @@
-library(shiny)
-
-# Define server logic for random distribution application
-function(input, output) {
-  
-  # Reactive expression to generate the requested distribution.
-  # This is called whenever the inputs change. The output
-  # functions defined below then all use the value computed from
-  # this expression
-  data <- reactive({
-    dist <- switch(input$dist,
-                   norm = rnorm,
-                   unif = runif,
-                   lnorm = rlnorm,
-                   exp = rexp,
-                   rnorm)
-    
-    dist(input$n)
-  })
-  
-  # Generate a plot of the data. Also uses the inputs to build
-  # the plot label. Note that the dependencies on both the inputs
-  # and the data reactive expression are both tracked, and
-  # all expressions are called in the sequence implied by the
-  # dependency graph
-  output$plot <- renderPlot({
-    dist <- input$dist
-    n <- input$n
-    
-    hist(data(), 
-         main=paste('r', dist, '(', n, ')', sep=''))
-  })
-  
-  # Generate a summary of the data
-  output$summary <- renderPrint({
-    summary(data())
-  })
-  
-  # Generate an HTML table view of the data
-  output$table <- renderTable({
-    data.frame(x=data())
-  })
-  
-}

inst/examples/06_tabsets/ui.R

@@ -1,38 +0,0 @@
-library(shiny)
-
-# Define UI for random distribution application 
-fluidPage(
-    
-  # Application title
-  titlePanel("Tabsets"),
-  
-  # Sidebar with controls to select the random distribution type
-  # and number of observations to generate. Note the use of the
-  # br() element to introduce extra vertical spacing
-  sidebarLayout(
-    sidebarPanel(
-      radioButtons("dist", "Distribution type:",
-                   c("Normal" = "norm",
-                     "Uniform" = "unif",
-                     "Log-normal" = "lnorm",
-                     "Exponential" = "exp")),
-      br(),
-      
-      sliderInput("n", 
-                  "Number of observations:", 
-                   value = 500,
-                   min = 1, 
-                   max = 1000)
-    ),
-    
-    # Show a tabset that includes a plot, summary, and table view
-    # of the generated distribution
-    mainPanel(
-      tabsetPanel(type = "tabs", 
-        tabPanel("Plot", plotOutput("plot")), 
-        tabPanel("Summary", verbatimTextOutput("summary")), 
-        tabPanel("Table", tableOutput("table"))
-      )
-    )
-  )
-)

inst/examples/07_widgets/app.R

@@ -0,0 +1,82 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("More Widgets"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Select a dataset ----
+      selectInput("dataset", "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Specify the number of observations to view ----
+      numericInput("obs", "Number of observations to view:", 10),
+
+      # Include clarifying text ----
+      helpText("Note: while the data view will show only the specified",
+               "number of observations, the summary will still be based",
+               "on the full dataset."),
+
+      # Input: actionButton() to defer the rendering of output ----
+      # until the user explicitly clicks the button (rather than
+      # doing it immediately when inputs change). This is useful if
+      # the computations required to render output are inordinately
+      # time-consuming.
+      actionButton("update", "Update View")
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Header + summary of distribution ----
+      h4("Summary"),
+      verbatimTextOutput("summary"),
+
+      # Output: Header + table of distribution ----
+      h4("Observations"),
+      tableOutput("view")
+    )
+
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  # Note that we use eventReactive() here, which depends on
+  # input$update (the action button), so that the output is only
+  # updated when the user clicks the button
+  datasetInput <- eventReactive(input$update, {
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  }, ignoreNULL = FALSE)
+
+  # Generate a summary of the dataset ----
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  # The use of isolate() is necessary because we don't want the table
+  # to update whenever input$obs changes (only when the user clicks
+  # the action button)
+  output$view <- renderTable({
+    head(datasetInput(), n = isolate(input$obs))
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/07_widgets/server.R

@@ -1,32 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the
-# selected dataset
-function(input, output) {
-
-  # Return the requested dataset. Note that we use `eventReactive()`
-  # here, which takes a dependency on input$update (the action
-  # button), so that the output is only updated when the user
-  # clicks the button.
-  datasetInput <- eventReactive(input$update, {
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  }, ignoreNULL = FALSE)
-
-  # Generate a summary of the dataset
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-
-  # Show the first "n" observations. The use of `isolate()` here
-  # is necessary because we don't want the table to update
-  # whenever input$obs changes (only when the user clicks the
-  # action button).
-  output$view <- renderTable({
-    head(datasetInput(), n = isolate(input$obs))
-  })
-}

inst/examples/07_widgets/ui.R

@@ -1,43 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-fluidPage(
-
-  # Application title.
-  titlePanel("More Widgets"),
-
-  # Sidebar with controls to select a dataset and specify the
-  # number of observations to view. The helpText function is
-  # also used to include clarifying text. Most notably, the
-  # inclusion of an actionButton defers the rendering of output
-  # until the user explicitly clicks the button (rather than
-  # doing it immediately when inputs change). This is useful if
-  # the computations required to render output are inordinately
-  # time-consuming.
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("dataset", "Choose a dataset:",
-                  choices = c("rock", "pressure", "cars")),
-
-      numericInput("obs", "Number of observations to view:", 10),
-
-      helpText("Note: while the data view will show only the specified",
-               "number of observations, the summary will still be based",
-               "on the full dataset."),
-
-      actionButton("update", "Update View")
-    ),
-
-    # Show a summary of the dataset and an HTML table with the
-    # requested number of observations. Note the use of the h4
-    # function to provide an additional header above each output
-    # section.
-    mainPanel(
-      h4("Summary"),
-      verbatimTextOutput("summary"),
-
-      h4("Observations"),
-      tableOutput("view")
-    )
-  )
-)

inst/examples/08_html/Readme.md

@@ -1,4 +1 @@
-Normally we use the built-in functions, such as `textInput()`, to generate
-the HTML UI in the R script `ui.R`. Actually **shiny** also works with a
-custom HTML page `www/index.html`. See [the
-tutorial](http://rstudio.github.io/shiny/tutorial/#html-ui) for more details.
+Normally we use the built-in functions, such as `textInput()`, to generate the HTML UI in the R script `ui.R`. Actually **shiny** also works with a custom HTML page `www/index.html`. See [the tutorial](http://shiny.rstudio.com/tutorial/) for more details.

inst/examples/08_html/app.R

@@ -0,0 +1,47 @@
+library(shiny)
+
+# Define server logic for random distribution app ----
+server <- function(input, output) {
+
+  # Reactive expression to generate the requested distribution ----
+  # This is called whenever the inputs change. The output functions
+  # defined below then use the value computed from this expression
+  d <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+
+    dist(input$n)
+  })
+
+  # Generate a plot of the data ----
+  # Also uses the inputs to build the plot label. Note that the
+  # dependencies on the inputs and the data reactive expression are
+  # both tracked, and all expressions are called in the sequence
+  # implied by the dependency graph.
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+
+    hist(d(),
+         main = paste("r", dist, "(", n, ")", sep = ""),
+         col = "#75AADB", border = "white")
+  })
+
+  # Generate a summary of the data ----
+  output$summary <- renderPrint({
+    summary(d())
+  })
+
+  # Generate an HTML table view of the head of the data ----
+  output$table <- renderTable({
+    head(data.frame(x = d()))
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = htmlTemplate("www/index.html"), server)

inst/examples/08_html/server.R

@@ -1,42 +0,0 @@
-library(shiny)
-
-# Define server logic for random distribution application
-function(input, output) {
-  
-  # Reactive expression to generate the requested distribution. This is 
-  # called whenever the inputs change. The output expressions defined 
-  # below then all used the value computed from this expression
-  data <- reactive({
-    dist <- switch(input$dist,
-                   norm = rnorm,
-                   unif = runif,
-                   lnorm = rlnorm,
-                   exp = rexp,
-                   rnorm)
-    
-    dist(input$n)
-  })
-  
-  # Generate a plot of the data. Also uses the inputs to build the 
-  # plot label. Note that the dependencies on both the inputs and
-  # the data reactive expression are both tracked, and all expressions 
-  # are called in the sequence implied by the dependency graph
-  output$plot <- renderPlot({
-    dist <- input$dist
-    n <- input$n
-    
-    hist(data(), 
-         main=paste('r', dist, '(', n, ')', sep=''))
-  })
-  
-  # Generate a summary of the data
-  output$summary <- renderPrint({
-    summary(data())
-  })
-  
-  # Generate an HTML table view of the data
-  output$table <- renderTable({
-    data.frame(x=data())
-  })
-  
-}

inst/examples/08_html/www/index.html

@@ -3,13 +3,13 @@
 <head>
   <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"/> 
+  <link rel="stylesheet" type="text/css" href="shared/shiny.css"/>
 </head>
- 
+
 <body>
 
   <h1>HTML UI</h1>
- 
+
   <p>
     <label>Distribution type:</label><br />
     <select name="dist">
@@ -17,22 +17,25 @@
       <option value="unif">Uniform</option>
       <option value="lnorm">Log-normal</option>
       <option value="exp">Exponential</option>
-    </select> 
+    </select>
   </p>
- 
+
   <p>
- 
-    <label>Number of observations:</label><br /> 
+
+    <label>Number of observations:</label><br />
     <input type="number" name="n" value="500" min="1" max="1000" />
 
   </p>
- 
-  <pre id="summary" class="shiny-text-output"></pre> 
-  
-  <div id="plot" class="shiny-plot-output" 
-       style="width: 100%; height: 400px"></div> 
-  
+
+  <h3>Summary of data:</h3>
+  <pre id="summary" class="shiny-text-output"></pre>
+
+  <h3>Plot of data:</h3>
+  <div id="plot" class="shiny-plot-output"
+       style="width: 100%; height: 300px"></div>
+
+  <h3>Head of data:</h3>
   <div id="table" class="shiny-html-output"></div>
- 
+
 </body>
-</html>
+</html>

inst/examples/09_upload/Readme.md

@@ -1,4 +1,3 @@
 We can add a file upload input in the UI using the function `fileInput()`,
-e.g. `fileInput('foo')`. In `server.R`, we can access the uploaded files via
-`input$foo`. See [the
-tutorial](http://rstudio.github.io/shiny/tutorial/#uploads) for more details.
+e.g. `fileInput('foo')`. In the `server` function, we can access the 
+uploaded files via `input$foo`.

inst/examples/09_upload/app.R

@@ -0,0 +1,92 @@
+library(shiny)
+
+# Define UI for data upload app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Uploading Files"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Select a file ----
+      fileInput("file1", "Choose CSV File",
+                multiple = TRUE,
+                accept = c("text/csv",
+                         "text/comma-separated-values,text/plain",
+                         ".csv")),
+
+      # Horizontal line ----
+      tags$hr(),
+
+      # Input: Checkbox if file has header ----
+      checkboxInput("header", "Header", TRUE),
+
+      # Input: Select separator ----
+      radioButtons("sep", "Separator",
+                   choices = c(Comma = ",",
+                               Semicolon = ";",
+                               Tab = "\t"),
+                   selected = ","),
+
+      # Input: Select quotes ----
+      radioButtons("quote", "Quote",
+                   choices = c(None = "",
+                               "Double Quote" = '"',
+                               "Single Quote" = "'"),
+                   selected = '"'),
+
+      # Horizontal line ----
+      tags$hr(),
+
+      # Input: Select number of rows to display ----
+      radioButtons("disp", "Display",
+                   choices = c(Head = "head",
+                               All = "all"),
+                   selected = "head")
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Data file ----
+      tableOutput("contents")
+
+    )
+
+  )
+)
+
+# Define server logic to read selected file ----
+server <- function(input, output) {
+
+  output$contents <- renderTable({
+
+    # input$file1 will be NULL initially. After the user selects
+    # and uploads a file, head of that data file by default,
+    # or all rows if selected, will be shown.
+
+    req(input$file1)
+
+    df <- read.csv(input$file1$datapath,
+             header = input$header,
+             sep = input$sep,
+             quote = input$quote)
+
+    if(input$disp == "head") {
+      return(head(df))
+    }
+    else {
+      return(df)
+    }
+
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/09_upload/server.R

@@ -1,20 +0,0 @@
-library(shiny)
-
-function(input, output) {
-  output$contents <- renderTable({
-    
-    # input$file1 will be NULL initially. After the user selects
-    # and uploads a file, it will be a data frame with 'name',
-    # 'size', 'type', and 'datapath' columns. The 'datapath'
-    # column will contain the local filenames where the data can
-    # be found.
-
-    inFile <- input$file1
-
-    if (is.null(inFile))
-      return(NULL)
-    
-    read.csv(inFile$datapath, header=input$header, sep=input$sep,
-             quote=input$quote)
-  })
-}

inst/examples/09_upload/ui.R

@@ -1,28 +0,0 @@
-library(shiny)
-
-fluidPage(
-  titlePanel("Uploading Files"),
-  sidebarLayout(
-    sidebarPanel(
-      fileInput('file1', 'Choose CSV File',
-                accept=c('text/csv', 
-                'text/comma-separated-values,text/plain',
-                '.csv')),
-      tags$hr(),
-      checkboxInput('header', 'Header', TRUE),
-      radioButtons('sep', 'Separator',
-                   c(Comma=',',
-                     Semicolon=';',
-                     Tab='\t'),
-                   ','),
-      radioButtons('quote', 'Quote',
-                   c(None='',
-                     'Double Quote'='"',
-                     'Single Quote'="'"),
-                   '"')
-    ),
-    mainPanel(
-      tableOutput('contents')
-    )
-  )
-)

inst/examples/10_download/Readme.md

@@ -1,4 +1,2 @@
 We can add a download button to the UI using `downloadButton()`, and write
-the content of the file in `downloadHandler()` in `server.R`. See [the
-tutorial](http://rstudio.github.io/shiny/tutorial/#downloads) for more
-details.
+the content of the file in `downloadHandler()` in the `server` function.

inst/examples/10_download/app.R

@@ -0,0 +1,63 @@
+library(shiny)
+
+# Define UI for data download app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Downloading Data"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Choose dataset ----
+      selectInput("dataset", "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Button
+      downloadButton("downloadData", "Download")
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      tableOutput("table")
+
+    )
+
+  )
+)
+
+# Define server logic to display and download selected file ----
+server <- function(input, output) {
+
+  # Reactive value for selected dataset ----
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Table of selected dataset ----
+  output$table <- renderTable({
+    datasetInput()
+  })
+
+  # Downloadable csv of selected dataset ----
+  output$downloadData <- downloadHandler(
+    filename = function() {
+      paste(input$dataset, ".csv", sep = "")
+    },
+    content = function(file) {
+      write.csv(datasetInput(), file, row.names = FALSE)
+    }
+  )
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/10_download/server.R

@@ -1,21 +0,0 @@
-function(input, output) {
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  output$table <- renderTable({
-    datasetInput()
-  })
-  
-  output$downloadData <- downloadHandler(
-    filename = function() { 
-      paste(input$dataset, '.csv', sep='')
-    },
-    content = function(file) {
-      write.csv(datasetInput(), file)
-    }
-  )
-}

inst/examples/10_download/ui.R

@@ -1,13 +0,0 @@
-fluidPage(
-  titlePanel('Downloading Data'),
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      downloadButton('downloadData', 'Download')
-    ),
-    mainPanel(
-      tableOutput('table')
-    )
-  )
-)

inst/examples/11_timer/app.R

@@ -0,0 +1,21 @@
+library(shiny)
+
+# Define UI for displaying current time ----
+ui <- fluidPage(
+
+  h2(textOutput("currentTime"))
+
+)
+
+# Define server logic to show current time, update every second ----
+server <- function(input, output, session) {
+
+  output$currentTime <- renderText({
+    invalidateLater(1000, session)
+    paste("The current time is", Sys.time())
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/11_timer/server.R

@@ -1,6 +0,0 @@
-function(input, output, session) {
-  output$currentTime <- renderText({
-    invalidateLater(1000, session)
-    paste("The current time is", Sys.time())
-  })
-}

inst/examples/11_timer/ui.R

@@ -1,3 +0,0 @@
-fluidPage(
-  textOutput("currentTime")
-)

inst/staticdocs/index.r

@@ -41,6 +41,7 @@ sd_section("UI Inputs",
     "numericInput",
     "radioButtons",
     "selectInput",
+    "varSelectInput",
     "sliderInput",
     "submitButton",
     "textInput",
@@ -57,6 +58,8 @@ sd_section("UI Inputs",
     "updateSelectInput",
     "updateSliderInput",
     "updateTabsetPanel",
+    "insertTab",
+    "showTab",
     "updateTextInput",
     "updateTextAreaInput",
     "updateQueryString",
@@ -102,6 +105,7 @@ sd_section("Rendering functions",
   "Functions that you use in your application's server side code, assigning them to outputs that appear in your user interface.",
   c(
     "renderPlot",
+    "renderCachedPlot",
     "renderText",
     "renderPrint",
     "renderDataTable",
@@ -113,7 +117,8 @@ sd_section("Rendering functions",
     "reactivePrint",
     "reactiveTable",
     "reactiveText",
-    "reactiveUI"
+    "reactiveUI",
+    "createRenderFunction"
   )
 )
 sd_section("Reactive programming",
@@ -129,7 +134,7 @@ sd_section("Reactive programming",
     "isolate",
     "invalidateLater",
     "debounce",
-    "showReactLog",
+    "reactlog",
     "makeReactiveBinding",
     "reactiveFileReader",
     "reactivePoll",
@@ -154,7 +159,8 @@ sd_section("Running",
     "runGadget",
     "runUrl",
     "stopApp",
-    "viewer"
+    "viewer",
+    "isRunning"
   )
 )
 sd_section("Bookmarking state",
@@ -191,14 +197,23 @@ sd_section("Utility functions",
     "exprToFunction",
     "installExprFunction",
     "parseQueryString",
+    "getCurrentOutputInfo",
     "plotPNG",
+    "sizeGrowthRatio",
     "exportTestValues",
+    "setSerializer",
     "snapshotExclude",
+    "snapshotPreprocessInput",
+    "snapshotPreprocessOutput",
     "markOutputAttrs",
     "repeatable",
     "shinyDeprecated",
     "serverInfo",
-    "shiny-options"
+    "shiny-options",
+    "onStop",
+    "diskCache",
+    "memoryCache",
+    "key_missing"
   )
 )
 sd_section("Plot interaction",

inst/www/shared/datepicker/js/bootstrap-datepicker.js

@@ -529,7 +529,17 @@
 		},
 
 		_utc_to_local: function(utc){
-			return utc && new Date(utc.getTime() + (utc.getTimezoneOffset()*60000));
+
+			if (!utc) return utc;
+
+			var local = new Date(utc.getTime() + (utc.getTimezoneOffset() * 60000));
+
+			if (local.getTimezoneOffset() != utc.getTimezoneOffset())
+			{
+				local = new Date(utc.getTime() + (local.getTimezoneOffset() * 60000));
+			}
+
+			return utc && local;
 		},
 		_local_to_utc: function(local){
 			return local && new Date(local.getTime() - (local.getTimezoneOffset()*60000));
@@ -661,7 +671,7 @@
 				visualPadding = 10,
 				container = $(this.o.container),
 				windowWidth = container.width(),
-				scrollTop = this.o.container === 'body' ? $(document).scrollTop() : container.scrollTop(),
+				scrollTop = this.o.container === 'body:first' ? $(document).scrollTop() : container.scrollTop(),
 				appendOffset = container.offset();
 
 			var parentsZindex = [];
@@ -676,7 +686,7 @@
 			var left = offset.left - appendOffset.left,
 				top = offset.top - appendOffset.top;
 
-			if (this.o.container !== 'body') {
+			if (this.o.container !== 'body:first') {
 				top += scrollTop;
 			}
 
@@ -1756,7 +1766,7 @@
 		enableOnReadonly: true,
 		showOnFocus: true,
 		zIndexOffset: 10,
-		container: 'body',
+		container: 'body:first',
 		immediateUpdates: false,
 		title: '',
 		templates: {