Compare commits

..

1 Commits

282 changed files with 3018 additions and 10552 deletions

View File

@@ -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. 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.
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.
3. Submit a [pull request](https://help.github.com/articles/using-pull-requests).

View File

@@ -1,7 +1,7 @@
Package: shiny
Type: Package
Title: Web Application Framework for R
Version: 1.0.5
Version: 0.14.2.9001
Authors@R: c(
person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -56,23 +56,22 @@ Authors@R: c(
)
Description: Makes it incredibly easy to build interactive web
applications with R. Automatic "reactive" binding between inputs and
outputs and extensive prebuilt widgets make it possible to build
outputs and extensive pre-built widgets make it possible to build
beautiful, responsive, and powerful applications with minimal effort.
License: GPL-3 | file LICENSE
Depends:
R (>= 3.0.2),
R (>= 3.0.0),
methods
Imports:
utils,
httpuv (>= 1.3.5),
httpuv (>= 1.3.3),
mime (>= 0.3),
jsonlite (>= 0.9.16),
xtable,
digest,
htmltools (>= 0.3.5),
R6 (>= 2.0),
sourcetools,
tools
sourcetools
Suggests:
datasets,
Cairo (>= 1.5-5),
@@ -80,11 +79,10 @@ Suggests:
knitr (>= 1.6),
markdown,
rmarkdown,
ggplot2,
magrittr
ggplot2
URL: http://shiny.rstudio.com
BugReports: https://github.com/rstudio/shiny/issues
Collate:
Collate:
'app.R'
'bookmark-state-local.R'
'stack.R'
@@ -99,9 +97,6 @@ Collate:
'diagnose.R'
'fileupload.R'
'graph.R'
'reactives.R'
'reactive-domains.R'
'history.R'
'hooks.R'
'html-deps.R'
'htmltools.R'
@@ -123,7 +118,6 @@ Collate:
'input-text.R'
'input-textarea.R'
'input-utils.R'
'insert-tab.R'
'insert-ui.R'
'jqueryui.R'
'middleware-shiny.R'
@@ -134,6 +128,8 @@ Collate:
'priorityqueue.R'
'progress.R'
'react.R'
'reactive-domains.R'
'reactives.R'
'render-plot.R'
'render-table.R'
'run-url.R'
@@ -145,9 +141,8 @@ Collate:
'shinyui.R'
'shinywrappers.R'
'showcase.R'
'snapshot.R'
'tar.R'
'test-export.R'
'timer.R'
'update-input.R'
RoxygenNote: 6.0.1
RoxygenNote: 5.0.1

View File

@@ -12,7 +12,7 @@ these components are included below):
- Respond.js, https://github.com/scottjehl/Respond
- bootstrap-datepicker, https://github.com/eternicode/bootstrap-datepicker
- Font Awesome, https://github.com/FortAwesome/Font-Awesome
- selectize.js, https://github.com/selectize/selectize.js
- selectize.js, https://github.com/brianreavis/selectize.js
- es5-shim, https://github.com/es-shims/es5-shim
- ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
- strftime for Javascript, https://github.com/samsonjs/strftime

View File

@@ -22,8 +22,6 @@ S3method(as.shiny.appobj,list)
S3method(as.shiny.appobj,shiny.appobj)
S3method(as.tags,shiny.appobj)
S3method(as.tags,shiny.render.function)
S3method(format,reactiveExpr)
S3method(format,reactiveVal)
S3method(names,reactivevalues)
S3method(print,reactive)
S3method(print,shiny.appobj)
@@ -40,7 +38,6 @@ export(actionButton)
export(actionLink)
export(addResourcePath)
export(animationOptions)
export(appendTab)
export(as.shiny.appobj)
export(basicPage)
export(bookmarkButton)
@@ -64,7 +61,6 @@ export(dataTableOutput)
export(dateInput)
export(dateRangeInput)
export(dblclickOpts)
export(debounce)
export(dialogViewer)
export(div)
export(downloadButton)
@@ -87,12 +83,10 @@ export(flowLayout)
export(fluidPage)
export(fluidRow)
export(formatStackTrace)
export(freezeReactiveVal)
export(freezeReactiveValue)
export(getCurrentObserver)
export(getDefaultReactiveDomain)
export(getQueryString)
export(getShinyOption)
export(getUrlHash)
export(h1)
export(h2)
export(h3)
@@ -101,7 +95,6 @@ export(h5)
export(h6)
export(headerPanel)
export(helpText)
export(hideTab)
export(hoverOpts)
export(hr)
export(htmlOutput)
@@ -116,7 +109,6 @@ export(includeMarkdown)
export(includeScript)
export(includeText)
export(inputPanel)
export(insertTab)
export(insertUI)
export(installExprFunction)
export(invalidateLater)
@@ -124,7 +116,6 @@ export(is.reactive)
export(is.reactivevalues)
export(is.shiny.appobj)
export(is.singleton)
export(isRunning)
export(isTruthy)
export(isolate)
export(knit_print.html)
@@ -156,7 +147,6 @@ export(onReactiveDomainEnded)
export(onRestore)
export(onRestored)
export(onSessionEnded)
export(onStop)
export(outputOptions)
export(p)
export(pageWithSidebar)
@@ -166,7 +156,6 @@ export(passwordInput)
export(plotOutput)
export(plotPNG)
export(pre)
export(prependTab)
export(printError)
export(printStackTrace)
export(radioButtons)
@@ -179,14 +168,12 @@ export(reactiveTable)
export(reactiveText)
export(reactiveTimer)
export(reactiveUI)
export(reactiveVal)
export(reactiveValues)
export(reactiveValuesToList)
export(registerInputHandler)
export(removeInputHandler)
export(removeModal)
export(removeNotification)
export(removeTab)
export(removeUI)
export(renderDataTable)
export(renderImage)
@@ -210,7 +197,6 @@ export(selectizeInput)
export(serverInfo)
export(setBookmarkExclude)
export(setProgress)
export(setSerializer)
export(shinyApp)
export(shinyAppDir)
export(shinyAppFile)
@@ -221,14 +207,10 @@ export(showBookmarkUrlModal)
export(showModal)
export(showNotification)
export(showReactLog)
export(showTab)
export(sidebarLayout)
export(sidebarPanel)
export(singleton)
export(sliderInput)
export(snapshotExclude)
export(snapshotPreprocessInput)
export(snapshotPreprocessOutput)
export(span)
export(splitLayout)
export(stopApp)
@@ -248,7 +230,6 @@ export(tags)
export(textAreaInput)
export(textInput)
export(textOutput)
export(throttle)
export(titlePanel)
export(uiOutput)
export(updateActionButton)

220
NEWS.md
View File

@@ -1,198 +1,5 @@
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
================
This is a hotfix release of Shiny. The primary reason for this release is because the web host for MathJax JavaScript library is scheduled to be shut down in the next few weeks. After it is shut down, Shiny applications that use MathJax will no longer be able to load the MathJax library if they are run with Shiny 1.0.1 and below. (If you don't know whether your application uses MathJax, it probably does not.) For more information about why the MathJax CDN is shutting down, see https://www.mathjax.org/cdn-shutting-down/.
## Full changelog
### Minor new features and improvements
* Added a `shiny:sessioninitialized` Javascript event, which is fired at the end of the initialize method of the Session object. This allows us to listen for this event when we want to get the value of things like `Shiny.user`. ([#1568](https://github.com/rstudio/shiny/pull/1568))
* Fixed [#1649](https://github.com/rstudio/shiny/issues/1649): allow the `choices` argument in `checkboxGroupInput()` to be `NULL` (or `c()`) to keep backward compatibility with Shiny < 1.0.1. This will result in the same thing as providing `choices = character(0)`. ([#1652](https://github.com/rstudio/shiny/pull/1652))
* The official URL for accessing MathJax libraries over CDN has been deprecated and will be removed soon. We have switched to a new rstudio.com URL that we will support going forward. ([#1664](https://github.com/rstudio/shiny/pull/1664))
### Bug fixes
* Fixed [#1653](https://github.com/rstudio/shiny/issues/1653): wrong code example in documentation. ([#1658](https://github.com/rstudio/shiny/pull/1658))
shiny 1.0.1
================
This is a maintenance release of Shiny, mostly aimed at fixing bugs and introducing minor features. The most notable additions in this version of Shiny are the introduction of the `reactiveVal()` function (it's like `reactiveValues()`, but it only stores a single value), and that the choices of `radioButtons()` and `checkboxGroupInput()` can now contain HTML content instead of just plain text.
## Full changelog
### Breaking changes
* The functions `radioButtons()`, `checkboxGroupInput()` and `selectInput()` (and the corresponding `updateXXX()` functions) no longer accept a `selected` argument whose value is the name of a choice, instead of the value of the choice. This feature had been deprecated since Shiny 0.10 (it printed a warning message, but still tried to match the name to the right choice) and it's now completely unsupported.
### New features
* Added `reactiveVal` function, for storing a single value which can be (reactively) read and written. Similar to `reactiveValues`, except that `reactiveVal` just lets you store a single value instead of storing multiple values by name. ([#1614](https://github.com/rstudio/shiny/pull/1614))
### Minor new features and improvements
* Fixed [#1637](https://github.com/rstudio/shiny/issues/1637): Outputs stay faded on MS Edge. ([#1640](https://github.com/rstudio/shiny/pull/1640))
* Addressed [#1348](https://github.com/rstudio/shiny/issues/1348) and [#1437](https://github.com/rstudio/shiny/issues/1437) by adding two new arguments to `radioButtons()` and `checkboxGroupInput()`: `choiceNames` (list or vector) and `choiceValues` (list or vector). These can be passed in as an alternative to `choices`, with the added benefit that the elements in `choiceNames` can be arbitrary UI (i.e. anything created by `HTML()` and the `tags()` functions, like icons and images). While the underlying values for each choice (passed in through `choiceValues`) must still be simple text, their visual representation on the app (what the user actually clicks to select a different option) can be any valid HTML element. See `?radioButtons` for a small example. ([#1521](https://github.com/rstudio/shiny/pull/1521))
* Updated `tools/README.md` with more detailed instructions. ([#1616](https://github.com/rstudio/shiny/pull/1616))
* Fixed [#1565](https://github.com/rstudio/shiny/issues/1565), which meant that resources with spaces in their names return HTTP 404. ([#1566](https://github.com/rstudio/shiny/pull/1566))
* Exported `session$user` (if it exists) to the client-side; it's accessible in the Shiny object: `Shiny.user`. ([#1563](https://github.com/rstudio/shiny/pull/1563))
* Added support for HTML5's `pushState` which allows for pseudo-navigation
in shiny apps. For more info, see the documentation (`?updateQueryString` and `?getQueryString`). ([#1447](https://github.com/rstudio/shiny/pull/1447))
* Fixed [#1121](https://github.com/rstudio/shiny/issues/1121): plot interactions with ggplot2 now support `coord_fixed()`. ([#1525](https://github.com/rstudio/shiny/pull/1525))
* Added `snapshotExclude` function, which marks an output so that it is not recorded in a test snapshot. ([#1559](https://github.com/rstudio/shiny/pull/1559))
* Added `shiny:filedownload` JavaScript event, which is triggered when a `downloadButton` or `downloadLink` is clicked. Also, the values of `downloadHandler`s are not recorded in test snapshots, because the values change every time the application is run. ([#1559](https://github.com/rstudio/shiny/pull/1559))
* Added support for plot interactions with ggplot2 > 2.2.1. ([#1578](https://github.com/rstudio/shiny/pull/1578))
* Fixed [#1577](https://github.com/rstudio/shiny/issues/1577): Improved `escapeHTML` (util.js) in terms of the order dependency of replacing, XSS risk attack and performance. ([#1579](https://github.com/rstudio/shiny/pull/1579))
* The `shiny:inputchanged` JavaScript event now includes two new fields, `binding` and `el`, which contain the input binding and DOM element, respectively. Additionally, `Shiny.onInputChange()` now accepts an optional argument, `opts`, which can contain the same fields. ([#1596](https://github.com/rstudio/shiny/pull/1596))
* The `NS()` function now returns a vectorized function. ([#1613](https://github.com/rstudio/shiny/pull/1613))
* Fixed [#1617](https://github.com/rstudio/shiny/issues/1617): `fileInput` can have customized text for the button and the placeholder. ([#1619](https://github.com/rstudio/shiny/pull/1619))
### Bug fixes
* Fixed [#1511](https://github.com/rstudio/shiny/issues/1511): `fileInput`s did not trigger the `shiny:inputchanged` event on the client. Also removed `shiny:fileuploaded` JavaScript event, because it is no longer needed after this fix. ([#1541](https://github.com/rstudio/shiny/pull/1541), [#1570](https://github.com/rstudio/shiny/pull/1570))
* Fixed [#1472](https://github.com/rstudio/shiny/issues/1472): With a Progress object, calling `set(value=NULL)` made the progress bar go to 100%. Now it does not change the value of the progress bar. The documentation also incorrectly said that setting the `value` to `NULL` would hide the progress bar. ([#1547](https://github.com/rstudio/shiny/pull/1547))
* Fixed [#162](https://github.com/rstudio/shiny/issues/162): When a dynamically-generated input changed to a different `inputType`, it might be incorrectly deduplicated. ([#1594](https://github.com/rstudio/shiny/pull/1594))
* Removed redundant call to `inputs.setInput`. ([#1595](https://github.com/rstudio/shiny/pull/1595))
* Fixed bug where `dateRangeInput` did not respect `weekstart` argument. ([#1592](https://github.com/rstudio/shiny/pull/1592))
* Fixed [#1598](https://github.com/rstudio/shiny/issues/1598): `setBookmarkExclude()` did not work properly inside of modules. ([#1599](https://github.com/rstudio/shiny/pull/1599))
* Fixed [#1605](https://github.com/rstudio/shiny/issues/1605): sliders did not move when clicked on the bar area. ([#1610](https://github.com/rstudio/shiny/pull/1610))
* Fixed [#1621](https://github.com/rstudio/shiny/issues/1621): if a `reactiveTimer`'s session was closed before the first time that the `reactiveTimer` fired, then the `reactiveTimer` would not get cleared and would keep firing indefinitely. ([#1623](https://github.com/rstudio/shiny/pull/1623))
* Fixed [#1634](https://github.com/rstudio/shiny/issues/1634): If brushing on a plot causes the plot to redraw, then the redraw could in turn trigger the plot to redraw again and again. This was due to spurious changes in values of floating point numbers. ([#1641](https://github.com/rstudio/shiny/pull/1641))
### Library updates
* Closed [#1500](https://github.com/rstudio/shiny/issues/1500): Updated ion.rangeSlider to 2.1.6. ([#1540](https://github.com/rstudio/shiny/pull/1540))
shiny 1.0.0
===========
Shiny has reached a milestone: version 1.0.0! In the last year, we've added two major features that we considered essential for a 1.0.0 release: bookmarking, and support for testing Shiny applications. As usual, this version of Shiny also includes many minor features and bug fixes.
Here are some highlights from this release. For more details, see the full changelog below.
## Support for testing Shiny applications
Shiny now supports automated testing of applications, with the [shinytest](https://github.com/rstudio/shinytest) package. Shinytest has not yet been released on CRAN, but will be soon. ([#18](https://github.com/rstudio/shiny/issues/18), [#1464](https://github.com/rstudio/shiny/pull/1464))
## Debounce/throttle reactives
Now there's an official way to slow down reactive values and expressions that invalidate too quickly. Pass a reactive expression to the new `debounce` or `throttle` function, and get back a modified reactive expression that doesn't invalidate as often. ([#1510](https://github.com/rstudio/shiny/pull/1510))
shiny 0.14.2.9000
============
## Full changelog
@@ -200,30 +7,16 @@ Now there's an official way to slow down reactive values and expressions that in
* Added a new `placeholder` argument to `verbatimTextOutput()`. The default is `FALSE`, which means that, if there is no content for this output, no representation of this slot will be made in the UI. Previsouly, even if there was no content, you'd see an empty rectangle in the UI that served as a placeholder. You can set `placeholder = TRUE` to revert back to that look. ([#1480](https://github.com/rstudio/shiny/pull/1480))
### New features
* Added support for testing Shiny applications with the shinytest package. ([#18](https://github.com/rstudio/shiny/issues/18), [#1464](https://github.com/rstudio/shiny/pull/1464))
* Added `debounce` and `throttle` functions, to control the rate at which reactive values and expressions invalidate. ([#1510](https://github.com/rstudio/shiny/pull/1510))
### 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))
* Added a more descriptive JS warning for `insertUI()` when the selector argument does not match anything in DOM. ([#1488](https://github.com/rstudio/shiny/pull/1488))
* Added support for injecting JavaScript code when the `shiny.testmode` option is set to `TRUE`. This makes it possible to record test events interactively. ([#1464](https://github.com/rstudio/shiny/pull/1464))
* Added support for injecting JavaScript code when the `shiny.testmode` option is set to `TRUE`. This makes it possible to record test events interactively. ([#1464]https://github.com/rstudio/shiny/pull/1464))
* Added ability through arguments to the `a` tag function called inside `downloadButton()` and `downloadLink()`. Closes [#986](https://github.com/rstudio/shiny/issues/986). ([#1492](https://github.com/rstudio/shiny/pulls/1492))
* Implemented [#1512](https://github.com/rstudio/shiny/issues/1512): added a `userData` environment to `session`, for storing arbitrary session-related variables. Generally, session-scoped variables are created just by declaring normal variables that are local to the Shiny server function, but `session$userData` may be more convenient for some advanced scenarios. ([#1513](https://github.com/rstudio/shiny/pull/1513))
* Relaxed naming requirements for `addResourcePath()` (the first character no longer needs to be a letter). ([#1529](https://github.com/rstudio/shiny/pull/1529))
### Bug fixes
* Fixed [#969](https://github.com/rstudio/shiny/issues/969): allow navbarPage's `fluid` param to control both containers. ([#1481](https://github.com/rstudio/shiny/pull/1481))
@@ -238,13 +31,6 @@ Now there's an official way to slow down reactive values and expressions that in
* Fixed [#1013](https://github.com/rstudio/shiny/issues/1013): `flushReact` should be called after app loads. Observers set up outside of server functions were not running until after the first user connects. ([#1503](https://github.com/rstudio/shiny/pull/1503))
* Fixed [#1453](https://github.com/rstudio/shiny/issues/1453): When using a modal dialog with `easyClose=TRUE` in a Shiny gadget, pressing Esc would close both the modal and the gadget. Now pressing Esc only closes the modal. ([#1523](https://github.com/rstudio/shiny/pull/1523))
### Library updates
* Updated to Font Awesome 4.7.0.
shiny 0.14.2
============

13
R/app.R
View File

@@ -41,8 +41,6 @@
#' @examples
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' shinyApp(
#' ui = fluidPage(
#' numericInput("n", "n", 1),
@@ -71,7 +69,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")
}
@@ -212,7 +210,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
if (file.exists(file.path.ci(appDir, "global.R")))
sourceUTF8(file.path.ci(appDir, "global.R"))
}
onStop <- function() {
onEnd <- function() {
setwd(oldwd)
monitorHandle()
monitorHandle <<- NULL
@@ -223,7 +221,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
serverFuncSource = serverFuncSource,
onStart = onStart,
onStop = onStop,
onEnd = onEnd,
options = options
),
class = "shiny.appobj"
@@ -317,9 +315,8 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
oldwd <<- getwd()
setwd(appDir)
monitorHandle <<- initAutoReloadMonitor(appDir)
if (!is.null(appObj()$onStart)) appObj()$onStart()
}
onStop <- function() {
onEnd <- function() {
setwd(oldwd)
monitorHandle()
monitorHandle <<- NULL
@@ -330,7 +327,7 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
serverFuncSource = dynServerFuncSource,
onStart = onStart,
onStop = onStop,
onEnd = onEnd,
options = options
),
class = "shiny.appobj"

View File

@@ -349,7 +349,7 @@ RestoreContext <- R6Class("RestoreContext",
mapply(names(vals), vals, SIMPLIFY = FALSE,
FUN = function(name, value) {
tryCatch(
safeFromJSON(value),
jsonlite::fromJSON(value),
error = function(e) {
stop("Failed to parse URL parameter \"", name, "\"")
}
@@ -493,90 +493,12 @@ restoreInput <- function(id, default) {
#' It typically is called from an observer. Note that this will not work in
#' Internet Explorer 9 and below.
#'
#' For \code{mode = "push"}, only three updates are currently allowed:
#' \enumerate{
#' \item the query string (format: \code{?param1=val1&param2=val2})
#' \item the hash (format: \code{#hash})
#' \item both the query string and the hash
#' (format: \code{?param1=val1&param2=val2#hash})
#' }
#'
#' In other words, if \code{mode = "push"}, the \code{queryString} must start
#' with either \code{?} or with \code{#}.
#'
#' A technical curiosity: under the hood, this function is calling the HTML5
#' history API (which is where the names for the \code{mode} argument come from).
#' When \code{mode = "replace"}, the function called is
#' \code{window.history.replaceState(null, null, queryString)}.
#' When \code{mode = "push"}, the function called is
#' \code{window.history.pushState(null, null, queryString)}.
#'
#' @param queryString The new query string to show in the location bar.
#' @param mode When the query string is updated, should the the current history
#' entry be replaced (default), or should a new history entry be pushed onto
#' the history stack? The former should only be used in a live bookmarking
#' context. The latter is useful if you want to navigate between states using
#' the browser's back and forward buttons. See Examples.
#' @param session A Shiny session object.
#' @seealso \code{\link{enableBookmarking}}, \code{\link{getQueryString}}
#' @examples
#' ## Only run these examples in interactive sessions
#' if (interactive()) {
#'
#' ## App 1: Doing "live" bookmarking
#' ## Update the browser's location bar every time an input changes.
#' ## This should not be used with enableBookmarking("server"),
#' ## because that would create a new saved state on disk every time
#' ## the user changes an input.
#' enableBookmarking("url")
#' shinyApp(
#' ui = function(req) {
#' fluidPage(
#' textInput("txt", "Text"),
#' checkboxInput("chk", "Checkbox")
#' )
#' },
#' server = function(input, output, session) {
#' observe({
#' # Trigger this observer every time an input changes
#' reactiveValuesToList(input)
#' session$doBookmark()
#' })
#' onBookmarked(function(url) {
#' updateQueryString(url)
#' })
#' }
#' )
#'
#' ## App 2: Printing the value of the query string
#' ## (Use the back and forward buttons to see how the browser
#' ## keeps a record of each state)
#' shinyApp(
#' ui = fluidPage(
#' textInput("txt", "Enter new query string"),
#' helpText("Format: ?param1=val1&param2=val2"),
#' actionButton("go", "Update"),
#' hr(),
#' verbatimTextOutput("query")
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$go, {
#' updateQueryString(input$txt, mode = "push")
#' })
#' output$query <- renderText({
#' query <- getQueryString()
#' queryText <- paste(names(query), query,
#' sep = "=", collapse=", ")
#' paste("Your query string is:\n", queryText)
#' })
#' }
#' )
#' }
#' @seealso \code{\link{enableBookmarking}} for examples.
#' @export
updateQueryString <- function(queryString, mode = c("replace", "push"),
session = getDefaultReactiveDomain()) {
mode <- match.arg(mode)
session$updateQueryString(queryString, mode)
updateQueryString <- function(queryString, session = getDefaultReactiveDomain()) {
session$updateQueryString(queryString)
}
#' Create a button for bookmarking/sharing

View File

@@ -277,7 +277,6 @@ titlePanel <- function(title, windowTitle=title) {
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' # Define UI
#' ui <- fluidPage(
@@ -443,7 +442,6 @@ inputPanel <- function(...) {
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' # Server code used for all examples
#' server <- function(input, output) {

View File

@@ -285,8 +285,7 @@ pageWithSidebar <- function(headerPanel,
#' example below).
#'
#' @seealso \code{\link{tabPanel}}, \code{\link{tabsetPanel}},
#' \code{\link{updateNavbarPage}}, \code{\link{insertTab}},
#' \code{\link{showTab}}
#' \code{\link{updateNavbarPage}}
#'
#' @examples
#' navbarPage("App Title",
@@ -394,15 +393,10 @@ 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, ..., menuName = title, icon = NULL) {
navbarMenu <- function(title, ..., icon = NULL) {
structure(list(title = title,
menuName = menuName,
tabs = list(...),
iconClass = iconClass(icon)),
class = "shiny.navbarmenu")
@@ -508,8 +502,6 @@ 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
@@ -518,55 +510,32 @@ mainPanel <- function(..., width = 8) {
#' \code{input["foo.bar"]} instead of \code{input.foo.bar} to read the input
#' value.
#' @examples
#' ## 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
#' 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
#' conditionalPanel(
#' 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)
#' )
#' condition = "input.breaks == 'custom'",
#' sliderInput("breakCount", "Break Count", min=1, max=1000, 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, ..., ns = NS(NULL)) {
div(`data-display-if`=condition, `data-ns-prefix`=ns(""), ...)
conditionalPanel <- function(condition, ...) {
div('data-display-if'=condition, ...)
}
#' Create a help text element
@@ -640,8 +609,7 @@ 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}},
#' \code{\link{insertTab}}, \code{\link{showTab}}
#' @seealso \code{\link{tabPanel}}, \code{\link{updateTabsetPanel}}
#'
#' @examples
#' # Show a tabset that includes a plot, summary, and
@@ -708,9 +676,7 @@ 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}},
#' \code{\link{insertTab}}, \code{\link{showTab}}
#'
#' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
#' @examples
#' fluidPage(
#'
@@ -760,158 +726,189 @@ navlistPanel <- function(...,
fixedRow(columns)
}
# Helpers to build tabsetPanels (& Co.) and their elements
markTabAsSelected <- function(x) {
attr(x, "selected") <- TRUE
x
}
isTabSelected <- function(x) {
isTRUE(attr(x, "selected", exact = TRUE))
}
buildTabset <- function(tabs, ulClass, textFilter = NULL,
id = NULL, selected = NULL) {
containsSelectedTab <- function(tabs) {
any(vapply(tabs, isTabSelected, logical(1)))
}
# 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.
findAndMarkSelectedTab <- function(tabs, selected, foundSelected) {
tabs <- lapply(tabs, function(div) {
if (foundSelected || is.character(div)) {
# Strings are not selectable items
# Mark an item as selected
markSelected <- function(x) {
attr(x, "selected") <- TRUE
x
}
} else if (inherits(div, "shiny.navbarmenu")) {
# Recur for navbarMenus
res <- findAndMarkSelectedTab(div$tabs, selected, foundSelected)
div$tabs <- res$tabs
foundSelected <<- res$foundSelected
# 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 {
# Base case: regular tab item. If the `selected` argument is
# provided, check for a match in the existing tabs; else,
# mark first available item as selected
if (is.null(selected)) {
foundSelected <<- TRUE
div <- markTabAsSelected(div)
} else {
tabValue <- div$attribs$`data-value` %OR% div$attribs$title
if (identical(selected, tabValue)) {
foundSelected <<- TRUE
div <- markTabAsSelected(div)
# 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)
}
}
}
}
return(div)
})
return(list(tabs = tabs, foundSelected = foundSelected))
}
# Returns the icon object (or NULL if none), provided either a
# tabPanel, OR the icon class
getIcon <- function(tab = NULL, iconClass = NULL) {
if (!is.null(tab)) iconClass <- tab$attribs$`data-icon-class`
if (!is.null(iconClass)) {
if (grepl("fa-", iconClass, fixed = TRUE)) {
return(divTag)
})
}
# Append an optional icon to an aTag
appendIcon <- function(aTag, iconClass) {
if (!is.null(iconClass)) {
# for font-awesome we specify fixed-width
iconClass <- paste(iconClass, "fa-fw")
if (grepl("fa-", iconClass, fixed = TRUE))
iconClass <- paste(iconClass, "fa-fw")
aTag <- tagAppendChild(aTag, icon(name = NULL, class = iconClass))
}
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 = ", "))
aTag
}
tabsetId <- p_randomInt(1000, 10000)
tabs <- lapply(seq_len(length(tabs)), buildTabItem,
tabsetId = tabsetId, foundSelected = foundSelected,
tabs = tabs, textFilter = textFilter)
# 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")
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,
divTag$title, tags$b(class = "caret"),
getIcon(iconClass = divTag$iconClass)
),
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`,
divTag$attribs$title,
getIcon(iconClass = divTag$attribs$`data-icon-class`)
)
)
# if this tabPanel is selected item, mark it active
if (isTabSelected(divTag)) {
liTag$attribs$class <- "active"
divTag$attribs$class <- "tab-pane active"
if (anyNamed(tabs)) {
nms <- names(tabs)
nms <- nms[nzchar(nms)]
stop("Tabs should all be unnamed arguments, but some are named: ",
paste(nms, collapse = ", "))
}
divTag$attribs$id <- tabId
divTag$attribs$title <- NULL
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)
}
return(list(liTag = liTag, divTag = divTag))
# Finally, actually invoke the functions to do the processing.
tabs <- findAndMarkSelected(tabs, selected)
build(tabs, ulClass, textFilter, id)
}
@@ -1456,7 +1453,7 @@ uiOutput <- htmlOutput
#' }
#'
#' @aliases downloadLink
#' @seealso \code{\link{downloadHandler}}
#' @seealso downloadHandler
#' @export
downloadButton <- function(outputId,
label="Download",
@@ -1546,7 +1543,7 @@ 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"),
"font-awesome", "4.6.3", c(href="shared/font-awesome"),
stylesheet = "css/font-awesome.min.css"
)
}

View File

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

View File

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

View File

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

View File

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

View File

@@ -6,22 +6,9 @@
#'
#' @inheritParams textInput
#' @param choices List of values to show checkboxes for. If elements of the list
#' are named then that name rather than the value is displayed to the user. If
#' this argument is provided, then \code{choiceNames} and \code{choiceValues}
#' must not be provided, and vice-versa. The values should be strings; other
#' types (such as logicals and numbers) will be coerced to strings.
#' are named then that name rather than the value is displayed to the user.
#' @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,
#' 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.
#'
#' @return A list of HTML elements that can be added to a UI definition.
#'
#' @family input elements
@@ -39,52 +26,26 @@
#' tableOutput("data")
#' )
#'
#' server <- function(input, output, session) {
#' server <- function(input, output) {
#' output$data <- renderTable({
#' mtcars[, c("mpg", input$variable), drop = FALSE]
#' }, rownames = TRUE)
#' }
#'
#' shinyApp(ui, server)
#'
#' ui <- fluidPage(
#' checkboxGroupInput("icons", "Choose icons:",
#' choiceNames =
#' list(icon("calendar"), icon("bed"),
#' icon("cog"), icon("bug")),
#' choiceValues =
#' list("calendar", "bed", "cog", "bug")
#' ),
#' textOutput("txt")
#' )
#'
#' server <- function(input, output, session) {
#' output$txt <- renderText({
#' icons <- paste(input$icons, collapse = ", ")
#' paste("You chose", icons)
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
#' @export
checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
# keep backward compatibility with Shiny < 1.0.1 (see #1649)
if (is.null(choices) && is.null(choiceNames) && is.null(choiceValues)) {
choices <- character(0)
}
args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
checkboxGroupInput <- function(inputId, label, choices, selected = NULL,
inline = FALSE, width = NULL) {
selected <- restoreInput(id = inputId, default = selected)
# default value if it's not specified
if (!is.null(selected)) selected <- as.character(selected)
# resolve names
choices <- choicesWithNames(choices)
if (!is.null(selected))
selected <- validateSelected(selected, choices, inputId)
options <- generateOptions(inputId, selected, inline,
'checkbox', args$choiceNames, args$choiceValues)
options <- generateOptions(inputId, choices, selected, inline)
divClass <- "form-group shiny-input-checkboxgroup shiny-input-container"
if (inline)

View File

@@ -98,7 +98,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
class = "input-sm form-control",
type = "text",
`data-date-language` = language,
`data-date-week-start` = weekstart,
`data-date-weekstart` = weekstart,
`data-date-format` = format,
`data-date-start-view` = startview,
`data-min-date` = min,
@@ -110,7 +110,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
class = "input-sm form-control",
type = "text",
`data-date-language` = language,
`data-date-week-start` = weekstart,
`data-date-weekstart` = weekstart,
`data-date-format` = format,
`data-date-start-view` = startview,
`data-min-date` = min,

View File

@@ -27,9 +27,6 @@
#' Internet Explorer 9 and earlier.}
#' @param accept A character vector of MIME types; gives the browser a hint of
#' what kind of files the server is expecting.
#' @param buttonLabel The label used on the button. Can be text or an HTML tag
#' object.
#' @param placeholder The text to show before a file has been uploaded.
#'
#' @examples
#' ## Only run examples in interactive R sessions
@@ -73,7 +70,7 @@
#' }
#' @export
fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
width = NULL) {
restoredValue <- restoreInput(id = inputId, default = NULL)
@@ -108,12 +105,12 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
div(class = "input-group",
tags$label(class = "input-group-btn",
span(class = "btn btn-default btn-file",
buttonLabel,
"Browse...",
inputTag
)
),
tags$input(type = "text", class = "form-control",
placeholder = placeholder, readonly = "readonly"
placeholder = "No file selected", readonly = "readonly"
)
),

View File

@@ -3,30 +3,19 @@
#' 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. 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)
#' named then that name rather than the value is displayed to the user)
#' @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.
#'
#' @family input elements
#' @seealso \code{\link{updateRadioButtons}}
@@ -58,46 +47,27 @@
#' }
#'
#' shinyApp(ui, server)
#'
#' ui <- fluidPage(
#' radioButtons("rb", "Choose one:",
#' choiceNames = list(
#' icon("calendar"),
#' HTML("<p style='color:red;'>Red Text</p>"),
#' "Normal text"
#' ),
#' choiceValues = list(
#' "icon", "html", "text"
#' )),
#' textOutput("txt")
#' )
#'
#' server <- function(input, output) {
#' output$txt <- renderText({
#' paste("You chose", input$rb)
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
#' @export
radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
radioButtons <- function(inputId, label, choices, selected = NULL,
inline = FALSE, width = NULL) {
args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
# resolve names
choices <- choicesWithNames(choices)
selected <- restoreInput(id = inputId, default = selected)
# default value if it's not specified
selected <- if (is.null(selected)) args$choiceValues[[1]] else as.character(selected)
selected <- if (is.null(selected)) choices[[1]] else {
validateSelected(selected, choices, inputId)
}
if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
options <- generateOptions(inputId, selected, inline,
'radio', args$choiceNames, args$choiceValues)
options <- generateOptions(inputId, choices, selected, inline, type = 'radio')
divClass <- "form-group shiny-input-radiogroup shiny-input-container"
if (inline) divClass <- paste(divClass, "shiny-input-container-inline")
if (inline)
divClass <- paste(divClass, "shiny-input-container-inline")
tags$div(id = inputId,
style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),

View File

@@ -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/brianreavis/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}.
#'
@@ -74,8 +74,8 @@
#' }
#' @export
selectInput <- function(inputId, label, choices, selected = NULL,
multiple = FALSE, selectize = TRUE, width = NULL,
size = NULL) {
multiple = FALSE, selectize = TRUE, width = NULL,
size = NULL) {
selected <- restoreInput(id = inputId, default = selected)
@@ -85,7 +85,7 @@ selectInput <- function(inputId, label, choices, selected = NULL,
# default value if it's not specified
if (is.null(selected)) {
if (!multiple) selected <- firstChoice(choices)
} else selected <- as.character(selected)
} else selected <- validateSelected(selected, choices, inputId)
if (!is.null(size) && selectize) {
stop("'size' argument is incompatible with 'selectize=TRUE'.")

View File

@@ -51,7 +51,6 @@
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' ui <- fluidPage(
#' sliderInput("obs", "Number of observations:",
@@ -164,21 +163,23 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
`data-grid` = ticks,
`data-grid-num` = n_ticks,
`data-grid-snap` = FALSE,
`data-prettify-separator` = sep,
`data-prettify-enabled` = (sep != ""),
`data-prefix` = pre,
`data-postfix` = post,
`data-keyboard` = TRUE,
`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,
`data-drag-interval` = dragRange,
# The following are ignored by the ion.rangeSlider, but are used by Shiny.
`data-data-type` = dataType,
`data-time-format` = timeFormat,
`data-timezone` = timezone
))
if (sep == "") {
sliderProps$`data-prettify-enabled` <- "0"
} else {
sliderProps$`data-prettify-separator` <- sep
}
# Replace any TRUE and FALSE with "true" and "false"
sliderProps <- lapply(sliderProps, function(x) {
if (identical(x, TRUE)) "true"
@@ -218,7 +219,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
}
dep <- list(
htmlDependency("ionrangeslider", "2.1.6", c(href="shared/ionrangeslider"),
htmlDependency("ionrangeslider", "2.1.2", c(href="shared/ionrangeslider"),
script = "js/ion.rangeSlider.min.js",
# ion.rangeSlider also needs normalize.css, which is already included in
# Bootstrap.

View File

@@ -2,62 +2,45 @@ controlLabel <- function(controlName, label) {
label %AND% tags$label(class = "control-label", `for` = controlName, label)
}
# This function takes in either a list or vector for `choices` (and
# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
# in a list or vector for both `choiceNames` and `choiceValues` (and
# `choices` is passed as NULL) and returns a list of two elements:
# - `choiceNames` is a vector or list that holds the options names
# (each element can be arbitrary UI, or simple text)
# - `choiceValues` is a vector or list that holds the options values
# (each element must be simple text)
normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
mustExist = TRUE) {
# if-else to check that either choices OR (choiceNames + choiceValues)
# were correctly provided
if (is.null(choices)) {
if (is.null(choiceNames) || is.null(choiceValues)) {
if (mustExist) {
stop("Please specify a non-empty vector for `choices` (or, ",
"alternatively, for both `choiceNames` AND `choiceValues`).")
} else {
if (is.null(choiceNames) && is.null(choiceValues)) {
# this is useful when we call this function from `updateInputOptions()`
# in which case, all three `choices`, `choiceNames` and `choiceValues`
# may legitimately be NULL
return(list(choiceNames = NULL, choiceValues = NULL))
} else {
stop("One of `choiceNames` or `choiceValues` was set to ",
"NULL, but either both or none should be NULL.")
}
}
}
if (length(choiceNames) != length(choiceValues)) {
stop("`choiceNames` and `choiceValues` must have the same length.")
}
if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
stop("`choiceNames` and `choiceValues` must not be named.")
}
} else {
if (!is.null(choiceNames) || !is.null(choiceValues)) {
warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
}
choices <- choicesWithNames(choices) # resolve names if not specified
choiceNames <- names(choices)
choiceValues <- unname(choices)
}
return(list(choiceNames = as.list(choiceNames),
choiceValues = as.list(as.character(choiceValues))))
# Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
# refers to values. Below is a function for backward compatibility. It also
# coerces the value to `character`.
validateSelected <- function(selected, choices, inputId) {
# this line accomplishes two tings:
# - coerces selected to character
# - drops name, otherwise toJSON() keeps it too
selected <- as.character(selected)
# if you are using optgroups, you're using shiny > 0.10.0, and you should
# already know that `selected` must be a value instead of a label
if (needOptgroup(choices)) return(selected)
if (is.list(choices)) choices <- unlist(choices)
nms <- names(choices)
# labels and values are identical, no need to validate
if (identical(nms, unname(choices))) return(selected)
# when selected labels instead of values
i <- (selected %in% nms) & !(selected %in% choices)
if (any(i)) {
warnFun <- if (all(i)) {
# replace names with values
selected <- unname(choices[selected])
warning
} else stop # stop when it is ambiguous (some labels == values)
warnFun("'selected' must be the values instead of names of 'choices' ",
"for the input '", inputId, "'")
}
selected
}
# generate options for radio buttons and checkbox groups (type = 'checkbox' or
# 'radio')
generateOptions <- function(inputId, selected, inline, type = 'checkbox',
choiceNames, choiceValues,
session = getDefaultReactiveDomain()) {
generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox') {
# generate a list of <input type=? [checked] />
options <- mapply(
choiceValues, choiceNames,
choices, names(choices),
FUN = function(value, name) {
inputTag <- tags$input(
type = type, name = inputId, value = value
@@ -65,18 +48,14 @@ generateOptions <- function(inputId, selected, inline, type = 'checkbox',
if (value %in% selected)
inputTag$attribs$checked <- "checked"
# in case, the options include UI code other than text
# (arbitrary HTML using the tags() function or equivalent)
pd <- processDeps(name, session)
# If inline, there's no wrapper div, and the label needs a class like
# checkbox-inline.
if (inline) {
tags$label(class = paste0(type, "-inline"), inputTag,
tags$span(pd$html, pd$deps))
tags$label(class = paste0(type, "-inline"), inputTag, tags$span(name))
} else {
tags$div(class = type, tags$label(inputTag,
tags$span(pd$html, pd$deps)))
tags$div(class = type,
tags$label(inputTag, tags$span(name))
)
}
},
SIMPLIFY = FALSE, USE.NAMES = FALSE

View File

@@ -1,325 +0,0 @@
#' 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)
}

View File

@@ -191,7 +191,7 @@ staticHandler <- function(root) {
if (!identical(req$REQUEST_METHOD, 'GET'))
return(NULL)
path <- URLdecode(req$PATH_INFO)
path <- req$PATH_INFO
if (is.null(path))
return(httpResponse(400, content="<h1>Bad Request</h1>"))
@@ -360,9 +360,7 @@ HandlerManager <- R6Class("HandlerManager",
response <- filter(req, response)
if (head_request) {
headers$`Content-Length` <- getResponseContentLength(response, deleteOwnedContent = TRUE)
headers$`Content-Length` <- nchar(response$content, type = "bytes")
return(list(
status = response$status,
body = "",
@@ -385,35 +383,6 @@ HandlerManager <- R6Class("HandlerManager",
)
)
# 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
#

View File

@@ -26,11 +26,6 @@ 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.")
}

View File

@@ -55,6 +55,7 @@
#' de-emphasized appearance relative to \code{message}.
#' @param value A numeric value at which to set
#' the progress bar, relative to \code{min} and \code{max}.
#' \code{NULL} hides the progress bar, if it is currently visible.
#' @param style Progress display style. If \code{"notification"} (the default),
#' the progress indicator will show using Shiny's notification API. If
#' \code{"old"}, use the same HTML and CSS used in Shiny 0.13.2 and below
@@ -97,6 +98,7 @@
#' @export
Progress <- R6Class(
'Progress',
portable = TRUE,
public = list(
initialize = function(session = getDefaultReactiveDomain(),
@@ -110,8 +112,8 @@ Progress <- R6Class(
private$id <- createUniqueId(8)
private$min <- min
private$max <- max
private$value <- NULL
private$style <- match.arg(style, choices = c("notification", "old"))
private$value <- NULL
private$closed <- FALSE
session$sendProgress('open', list(id = private$id, style = private$style))
@@ -123,15 +125,15 @@ Progress <- R6Class(
return()
}
if (is.null(value) || is.na(value))
if (is.null(value) || is.na(value)) {
value <- NULL
if (!is.null(value)) {
private$value <- value
} else {
# Normalize value to number between 0 and 1
value <- min(1, max(0, (value - private$min) / (private$max - private$min)))
}
private$value <- value
data <- dropNulls(list(
id = private$id,
message = message,
@@ -140,14 +142,11 @@ Progress <- R6Class(
style = private$style
))
private$session$sendProgress('update', data)
private$session$sendProgress('update', data)
},
inc = function(amount = 0.1, message = NULL, detail = NULL) {
if (is.null(private$value))
private$value <- private$min
value <- min(private$value + amount, private$max)
value <- min(self$getValue() + amount, private$max)
self$set(value, message, detail)
},
@@ -155,7 +154,10 @@ Progress <- R6Class(
getMax = function() private$max,
getValue = function() private$value,
# Return value (not the normalized 0-1 value, but in the original range)
getValue = function() {
private$value * (private$max - private$min) + private$min
},
close = function() {
if (private$closed) {
@@ -171,12 +173,12 @@ Progress <- R6Class(
),
private = list(
session = 'ShinySession',
session = 'environment',
id = character(0),
min = numeric(0),
max = numeric(0),
style = character(0),
value = numeric(0),
value = NULL,
closed = logical(0)
)
)
@@ -237,12 +239,12 @@ Progress <- R6Class(
#' \code{"old"}, use the same HTML and CSS used in Shiny 0.13.2 and below
#' (this is for backward-compatibility).
#' @param value Single-element numeric vector; the value at which to set the
#' progress bar, relative to \code{min} and \code{max}.
#' progress bar, relative to \code{min} and \code{max}. \code{NULL} hides the
#' progress bar, if it is currently visible.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' ui <- fluidPage(
#' plotOutput("plot")

View File

@@ -38,229 +38,6 @@ Dependents <- R6Class(
)
# ReactiveVal ---------------------------------------------------------------
ReactiveVal <- R6Class(
'ReactiveVal',
portable = FALSE,
private = list(
value = NULL,
label = NULL,
frozen = FALSE,
dependents = NULL
),
public = list(
initialize = function(value, label = NULL) {
private$value <- value
private$label <- label
private$dependents <- Dependents$new()
.graphValueChange(private$label, value)
},
get = function() {
private$dependents$register(depLabel = private$label)
if (private$frozen)
reactiveStop()
private$value
},
set = function(value) {
if (identical(private$value, value)) {
return(invisible(FALSE))
}
private$value <- value
.graphValueChange(private$label, value)
private$dependents$invalidate()
invisible(TRUE)
},
freeze = function(session = getDefaultReactiveDomain()) {
if (is.null(session)) {
stop("Can't freeze a reactiveVal without a reactive domain")
}
session$onFlushed(function() {
self$thaw()
})
private$frozen <- TRUE
},
thaw = function() {
private$frozen <- FALSE
},
isFrozen = function() {
private$frozen
},
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, ...)))
if (length(label) == 1) {
paste0("reactiveVal: ", label)
} else {
c("reactiveVal:", label)
}
}
)
)
#' Create a (single) reactive value
#'
#' The \code{reactiveVal} function is used to construct a "reactive value"
#' object. This is an object used for reading and writing a value, like a
#' variable, but with special capabilities for reactive programming. When you
#' read the value out of a reactiveVal object, the calling reactive expression
#' takes a dependency, and when you change the value, it notifies any reactives
#' that previously depended on that value.
#'
#' \code{reactiveVal} is very similar to \code{\link{reactiveValues}}, except
#' that the former is for a single reactive value (like a variable), whereas the
#' latter lets you conveniently use multiple reactive values by name (like a
#' named list of variables). For a one-off reactive value, it's more natural to
#' use \code{reactiveVal}. See the Examples section for an illustration.
#'
#' @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
#' created.
#'
#' @return A function. Call the function with no arguments to (reactively) read
#' the value; call the function with a single argument to set the value.
#'
#' @examples
#'
#' \dontrun{
#'
#' # Create the object by calling reactiveVal
#' r <- reactiveVal()
#'
#' # Set the value by calling with an argument
#' r(10)
#'
#' # Read the value by calling without arguments
#' r()
#'
#' }
#'
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#' actionButton("minus", "-1"),
#' actionButton("plus", "+1"),
#' br(),
#' textOutput("value")
#' )
#'
#' # The comments below show the equivalent logic using reactiveValues()
#' server <- function(input, output, session) {
#' value <- reactiveVal(0) # rv <- reactiveValues(value = 0)
#'
#' observeEvent(input$minus, {
#' newValue <- value() - 1 # newValue <- rv$value - 1
#' value(newValue) # rv$value <- newValue
#' })
#'
#' observeEvent(input$plus, {
#' newValue <- value() + 1 # newValue <- rv$value + 1
#' value(newValue) # rv$value <- newValue
#' })
#'
#' output$value <- renderText({
#' value() # rv$value
#' })
#' }
#'
#' shinyApp(ui, server)
#'
#' }
#'
#' @export
reactiveVal <- function(value = NULL, label = NULL) {
if (missing(label)) {
call <- sys.call()
label <- rvalSrcrefToLabel(attr(call, "srcref", exact = TRUE))
}
rv <- ReactiveVal$new(value, label)
structure(
function(x) {
if (missing(x)) {
rv$get()
} else {
force(x)
rv$set(x)
}
},
class = c("reactiveVal", "reactive"),
label = label,
.impl = rv
)
}
#' @rdname freezeReactiveValue
#' @export
freezeReactiveVal <- function(x) {
domain <- getDefaultReactiveDomain()
if (is.null(domain)) {
stop("freezeReactiveVal() must be called when a default reactive domain is active.")
}
if (!inherits(x, "reactiveVal")) {
stop("x must be a reactiveVal object")
}
attr(x, ".impl", exact = TRUE)$freeze(domain)
invisible()
}
#' @export
format.reactiveVal <- function(x, ...) {
attr(x, ".impl", exact = TRUE)$format(...)
}
# Attempts to extract the variable name that the reactiveVal object is being
# assigned to (e.g. for `a <- reactiveVal()`, the result should be "a"). This
# is a fragile, error-prone operation, so we default to a random label if
# necessary.
rvalSrcrefToLabel <- function(srcref,
defaultLabel = paste0("reactiveVal", createUniqueId(4))) {
if (is.null(srcref))
return(defaultLabel)
srcfile <- attr(srcref, "srcfile", exact = TRUE)
if (is.null(srcfile))
return(defaultLabel)
if (is.null(srcfile$lines))
return(defaultLabel)
lines <- srcfile$lines
# When pasting at the Console, srcfile$lines is not split
if (length(lines) == 1) {
lines <- strsplit(lines, "\n")[[1]]
}
if (length(lines) < srcref[1]) {
return(defaultLabel)
}
firstLine <- substring(lines[srcref[1]], srcref[2] - 1)
m <- regexec("\\s*([^[:space:]]+)\\s*(<-|=)\\s*reactiveVal\\b", firstLine)
if (m[[1]][1] == -1) {
return(defaultLabel)
}
sym <- regmatches(firstLine, m)[[1]][2]
res <- try(parse(text = sym), silent = TRUE)
if (inherits(res, "try-error"))
return(defaultLabel)
if (length(res) != 1)
return(defaultLabel)
return(as.character(res))
}
# ReactiveValues ------------------------------------------------------------
ReactiveValues <- R6Class(
@@ -620,17 +397,14 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
#' Freeze a reactive value
#'
#' These functions freeze a \code{\link{reactiveVal}}, or an element of a
#' \code{\link{reactiveValues}}. If the value is accessed while frozen, a
#' This freezes a reactive value. If the value is accessed while frozen, a
#' "silent" exception is raised and the operation is stopped. This is the same
#' thing that happens if \code{req(FALSE)} is called. The value is thawed
#' (un-frozen; accessing it will no longer raise an exception) when the current
#' reactive domain is flushed. In a Shiny application, this occurs after all of
#' the observers are executed.
#'
#' @param x For \code{freezeReactiveValue}, a \code{\link{reactiveValues}}
#' object (like \code{input}); for \code{freezeReactiveVal}, a
#' \code{\link{reactiveVal}} object.
#' @param x A \code{\link{reactiveValues}} object (like \code{input}).
#' @param name The name of a value in the \code{\link{reactiveValues}} object.
#'
#' @seealso \code{\link{req}}
@@ -672,7 +446,7 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
#' @export
freezeReactiveValue <- function(x, name) {
domain <- getDefaultReactiveDomain()
if (is.null(domain)) {
if (is.null(getDefaultReactiveDomain)) {
stop("freezeReactiveValue() must be called when a default reactive domain is active.")
}
@@ -687,7 +461,6 @@ Observable <- R6Class(
'Observable',
portable = FALSE,
public = list(
.origFunc = 'function',
.func = 'function',
.label = character(0),
.domain = NULL,
@@ -717,7 +490,6 @@ Observable <- R6Class(
funcLabel <- paste0("<reactive:", label, ">")
}
.origFunc <<- func
.func <<- wrapFunctionLabel(func, funcLabel,
..stacktraceon = ..stacktraceon)
.label <<- label
@@ -748,10 +520,6 @@ Observable <- R6Class(
else
invisible(.value)
},
format = function() {
label <- sprintf('reactive(%s)', paste(deparse(body(.origFunc)), collapse='\n'))
strsplit(label, "\n")[[1]]
},
.updateValue = function() {
ctx <- Context$new(.domain, .label, type = 'observable',
prevId = .mostRecentCtxId)
@@ -861,13 +629,13 @@ reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
# Attach a label and a reference to the original user source for debugging
srcref <- attr(substitute(x), "srcref", exact = TRUE)
if (is.null(label)) {
label <- rexprSrcrefToLabel(srcref[[1]],
label <- srcrefToLabel(srcref[[1]],
sprintf('reactive(%s)', paste(deparse(body(fun)), collapse='\n')))
}
if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
o <- Observable$new(fun, label, domain, ..stacktraceon = ..stacktraceon)
structure(o$getValue, observable = o, class = c("reactiveExpr", "reactive"))
structure(o$getValue, observable = o, class = "reactive")
}
# Given the srcref to a reactive expression, attempts to figure out what the
@@ -875,7 +643,7 @@ reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
# scans the line of code that started the reactive block and looks for something
# that looks like assignment. If we fail, fall back to a default value (likely
# the block of code in the body of the reactive).
rexprSrcrefToLabel <- function(srcref, defaultLabel) {
srcrefToLabel <- function(srcref, defaultLabel) {
if (is.null(srcref))
return(defaultLabel)
@@ -913,25 +681,19 @@ rexprSrcrefToLabel <- function(srcref, defaultLabel) {
return(as.character(res))
}
#' @export
format.reactiveExpr <- function(x, ...) {
attr(x, "observable", exact = TRUE)$format()
}
#' @export
print.reactive <- function(x, ...) {
cat(paste(format(x), collapse = "\n"), "\n")
label <- attr(x, "observable", exact = TRUE)$.label
cat(label, "\n")
}
#' @export
#' @rdname reactive
is.reactive <- function(x) {
inherits(x, "reactive")
}
is.reactive <- function(x) inherits(x, "reactive")
# Return the number of times that a reactive expression or observer has been run
execCount <- function(x) {
if (inherits(x, "reactiveExpr"))
if (is.reactive(x))
return(attr(x, "observable", exact = TRUE)$.execCount)
else if (inherits(x, 'Observer'))
return(x$.execCount)
@@ -941,6 +703,10 @@ execCount <- function(x) {
# Observer ------------------------------------------------------------------
# The initial value of "current observer" is NULL (and will always be NULL,
# except when within the scope of the observe or observeEvent)
.globals$currentObserver <- NULL
Observer <- R6Class(
'Observer',
portable = FALSE,
@@ -1052,6 +818,8 @@ registerDebugHook("observerFunc", environment(), label)
run = function() {
ctx <- .createContext()
.execCount <<- .execCount + 1L
.globals$currentObserver <- self
on.exit(.globals$currentObserver <- NULL) # On exit, set it back to NULL
ctx$run(.func)
},
onInvalidate = function(callback) {
@@ -1142,6 +910,125 @@ registerDebugHook("observerFunc", environment(), label)
)
)
#' Return the current observer
#'
#' This function is useful when you want to access an observer's methods or
#' variables directly. For example, you may have logic that destroys or
#' suspends the observer (from within its own scope) on some condition.
#'
#' This function works by returning the observer that is currently being run
#' when \code{getCurrentObserver()} is called. If there is no observer being
#' run (for example, if you called it from outside of a reactive context),
#' it will always return \code{NULL}. There are a few subtleties, however.
#' Consider the following five situations:
#'
#' \enumerate{
#' \item \code{getCurrentObserver() #outside of a reactive context}
#' \item \code{observe({ getCurrentObserver() }) }
#' \item \code{observe({ (function(){ getCurrentObserver() })() )} }
#' \item \code{observe({ isolate({ getCurrentObserver() }) }) }
#' \item \code{observe({ reactive({ getCurrentObserver() }) }) }
#' }
#'
#' In (1), since you're outside of a reactive context, we've already
#' established that \code{getCurrentObserver()} will return \code{NULL}.
#' In (2), we have the "vanilla" case, in which \code{getCurrentObserver()}
#' is called directly from within the body of the \code{observe} call.
#' This returns that observer. So far, so good. The problem comes with
#' the last three cases -- should we be able to "retrieve" the outer
#' observer if we're inside an inner function's scope, or inside of an
#' \code{isolate} or a \code{reactive} block?
#'
#' Before we can even asnwer that, there is an important distinction to
#' be made here: are function calls, \code{reactive} calls and
#' \code{isolate} blocks the same \emph{type} of thing? As far as Shiny
#' is concerned, the answer is no. Shiny-specific things (like observers,
#' reactives and code inside of an \code{isolate} chunk) exist in what we
#' call reactive contexts. Each run of an observer or a reactive is
#' associated with a particular reactive context. But regular functions
#' have no relation to reactive contexts. So, while calling a regular
#' function inside of an observer does not change the reactive context,
#' calling a \code{reactive} or \code{isolate} certainly does.
#'
#' With this distinction in mind, we can refine our definition of
#' \code{getCurrentObserver()} as follows: it returns the observer (if any)
#' that is currently running, as long as it is called from within the
#' same reactive context that was created when the observer started
#' running. If the reactive context changed (most likely because of a
#' call to \code{reactive} or \code{isolate}), \code{getCurrentObserver}
#' will return \code{NULL}. (There is another common way that the reactive
#' context can change inside an observer, which is if there is a second,
#' nested observer. In this case, \code{getCurrentObserver()} will return
#' the second, nested observer, since that is the one that is actually
#' running at that time.)
#'
#' So to recap, here's the return value for each of the five situations:
#' \enumerate{
#' \item \code{NULL}
#' \item the observer
#' \item the observer
#' \item \code{NULL}
#' \item \code{NULL}
#' }
#'
#' Now, you may be wondering why \code{getCurrentObserver()} should't be able
#' to get the running observer even if the reactive context changes. This isn't
#' technically impossible. In fact, if you want this behavior for some reason,
#' you can set the argument \code{dig} to be \code{TRUE}, so that the function
#' will "dig" through the reactive contexts until it retrieves the one for the
#' observer and returns the observer.
#'
#' So, with \code{dig = TRUE}, here's the return value for each of the five
#' situations:
#' \enumerate{
#' \item \code{NULL}
#' \item the observer
#' \item the observer
#' \item the observer
#' \item the observer
#' }
#'
#' The reason that this is not the default (or even encouraged) is because
#' things can get messy quickly when you cross reactive contexts at will.
#' For example, the return value of a \code{reactive} call is cached and that
#' reactive is not re-run unless its reactive dependencies change. If that
#' reactive has a call to \code{getCurrentObserver()}, this can produce
#' undesirable and unintuitive results.
#'
#' @param dig If \code{FALSE} (default), \code{getCurrentObserver} will only
#' return the observer if it's invoked directly from within the observer's
#' body or from a regular function. If \code{TRUE}, it will always return
#' the observer (if it exists on the stack), even if it's invoked from
#' within a \code{reactive} or an \code{isolate} scope. See below for more
#' information.
#'
#' @return The observer (created with a call to either \code{observe} or to
#' \code{observeEvent}) that is currently running.
#'
#' @seealso \code{\link{observe}}
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' shinyApp(
#' ui = basicPage( actionButton("go", "Go")),
#' server = function(input, output, session) {
#' observeEvent(input$go, {
#' print(paste("This will only be printed once; all",
#' "subsequent button clicks won't do anything"))
#' getCurrentObserver()$destroy()
#' })
#' }
#' )
#' }
#' @export
getCurrentObserver <- function(dig = FALSE) {
o <- .globals$currentObserver
ctx <- getCurrentContext()
if (!dig && !is.null(o) && ctx$id != o$.ctx$id) o <- NULL
o
}
#' Create a reactive observer
#'
#' Creates an observer from the given expression.
@@ -1389,10 +1276,6 @@ setAutoflush <- local({
#' }
#' @export
reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain()) {
# Need to make sure that session is resolved at creation, not when the
# callback below is fired (see #1621).
force(session)
dependents <- Map$new()
timerCallbacks$schedule(intervalMs, function() {
# Quit if the session is closed
@@ -1542,22 +1425,9 @@ coerceToFunc <- function(x) {
#' @seealso \code{\link{reactiveFileReader}}
#'
#' @examples
#' # Assume the existence of readTimestamp and readValue functions
#' function(input, output, session) {
#'
#' 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)
#' }
#' )
#'
#' data <- reactivePoll(1000, session, readTimestamp, readValue)
#' output$dataTable <- renderTable({
#' data()
#' })
@@ -1632,7 +1502,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
#' # Cross-session reactive file reader. In this example, all sessions share
#' # the same reader, so read.csv only gets executed once no matter how many
#' # user sessions are connected.
#' fileData <- reactiveFileReader(1000, NULL, 'data.csv', read.csv)
#' fileData <- reactiveFileReader(1000, session, 'data.csv', read.csv)
#' function(input, output, session) {
#' output$data <- renderTable({
#' fileData()
@@ -1786,8 +1656,6 @@ maskReactiveContext <- function(expr) {
#' invalidations that come from its reactive dependencies; it only invalidates
#' in response to the given event.
#'
#' @section ignoreNULL and ignoreInit:
#'
#' Both \code{observeEvent} and \code{eventReactive} take an \code{ignoreNULL}
#' parameter that affects behavior when the \code{eventExpr} evaluates to
#' \code{NULL} (or in the special case of an \code{\link{actionButton}},
@@ -1800,44 +1668,6 @@ 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}
#' 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.
#'
#' 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
#' these:
#'
#' \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.
#' }
#' \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = FALSE}}{
#' This combination means that \code{handlerExpr} 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.
#' }
#' \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}.
#' }
#' }
#'
#' @param eventExpr A (quoted or unquoted) expression that represents the event;
#' this can be a simple reactive value like \code{input$click}, a call to a
#' reactive expression like \code{dataset()}, or even a complex expression
@@ -1879,15 +1709,6 @@ maskReactiveContext <- function(expr) {
#' @param ignoreNULL Whether the action should be triggered (or value
#' calculated, in the case of \code{eventReactive}) when the input is
#' \code{NULL}. See Details.
#' @param ignoreInit If \code{TRUE}, then, when this \code{observeEvent} is
#' first created/initialized, ignore the \code{handlerExpr} (the second
#' argument), whether it is otherwise supposed to run or not. The default is
#' \code{FALSE}. See Details.
#' @param once Whether this \code{observeEvent} should be immediately destroyed
#' after the first time that the code in \code{handlerExpr} is run. This
#' pattern is useful when you want to subscribe to a event that should only
#' happen once.
#'
#' @return \code{observeEvent} returns an observer reference class object (see
#' \code{\link{observe}}). \code{eventReactive} returns a reactive expression
#' object (see \code{\link{reactive}}).
@@ -1897,71 +1718,37 @@ maskReactiveContext <- function(expr) {
#' @examples
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#'
#' ## App 1: Sample usage
#' shinyApp(
#' ui = fluidPage(
#' column(4,
#' numericInput("x", "Value", 5),
#' br(),
#' actionButton("button", "Show")
#' ),
#' column(8, tableOutput("table"))
#' ui <- fluidPage(
#' column(4,
#' numericInput("x", "Value", 5),
#' br(),
#' actionButton("button", "Show")
#' ),
#' server = function(input, output) {
#' # Take an action every time button is pressed;
#' # here, we just print a message to the console
#' observeEvent(input$button, {
#' cat("Showing", input$x, "rows\n")
#' })
#' # Take a reactive dependency on input$button, but
#' # not on any of the stuff inside the function
#' df <- eventReactive(input$button, {
#' head(cars, input$x)
#' })
#' output$table <- renderTable({
#' df()
#' })
#' }
#' )
#'
#' ## App 2: Using `once`
#' shinyApp(
#' ui = basicPage( actionButton("go", "Go")),
#' server = function(input, output, session) {
#' observeEvent(input$go, {
#' print(paste("This will only be printed once; all",
#' "subsequent button clicks won't do anything"))
#' }, once = TRUE)
#' }
#' )
#'
#' ## App 3: Using `ignoreInit` and `once`
#' shinyApp(
#' ui = basicPage(actionButton("go", "Go")),
#' server = function(input, output, session) {
#' observeEvent(input$go, {
#' insertUI("#go", "afterEnd",
#' actionButton("dynamic", "click to remove"))
#'
#' # set up an observer that depends on the dynamic
#' # input, so that it doesn't run when the input is
#' # created, and only runs once after that (since
#' # the side effect is remove the input from the DOM)
#' observeEvent(input$dynamic, {
#' removeUI("#dynamic")
#' }, ignoreInit = TRUE, once = TRUE)
#' })
#' }
#' column(8, tableOutput("table"))
#' )
#' server <- function(input, output) {
#' # Take an action every time button is pressed;
#' # here, we just print a message to the console
#' observeEvent(input$button, {
#' cat("Showing", input$x, "rows\n")
#' })
#' # Take a reactive dependency on input$button, but
#' # not on any of the stuff inside the function
#' df <- eventReactive(input$button, {
#' head(cars, input$x)
#' })
#' output$table <- renderTable({
#' df()
#' })
#' }
#' shinyApp(ui=ui, server=server)
#' }
#' @export
observeEvent <- function(eventExpr, handlerExpr,
event.env = parent.frame(), event.quoted = FALSE,
handler.env = parent.frame(), handler.quoted = FALSE,
label = NULL, suspended = FALSE, priority = 0,
domain = getDefaultReactiveDomain(), autoDestroy = TRUE,
ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE) {
label=NULL, suspended=FALSE, priority=0, domain=getDefaultReactiveDomain(),
autoDestroy = TRUE, ignoreNULL = TRUE) {
eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
if (is.null(label))
@@ -1971,29 +1758,16 @@ observeEvent <- function(eventExpr, handlerExpr,
handlerFunc <- exprToFunction(handlerExpr, handler.env, handler.quoted)
handlerFunc <- wrapFunctionLabel(handlerFunc, "observeEventHandler", ..stacktraceon = TRUE)
initialized <- FALSE
o <- observe({
invisible(observe({
e <- eventFunc()
if (ignoreInit && !initialized) {
initialized <<- TRUE
return()
}
if (ignoreNULL && isNullEvent(e)) {
return()
}
if (once) {
on.exit(o$destroy())
}
isolate(handlerFunc())
}, label = label, suspended = suspended, priority = priority, domain = domain,
autoDestroy = TRUE, ..stacktraceon = FALSE)
invisible(o)
autoDestroy = TRUE, ..stacktraceon = FALSE))
}
#' @rdname observeEvent
@@ -2001,8 +1775,8 @@ observeEvent <- function(eventExpr, handlerExpr,
eventReactive <- function(eventExpr, valueExpr,
event.env = parent.frame(), event.quoted = FALSE,
value.env = parent.frame(), value.quoted = FALSE,
label = NULL, domain = getDefaultReactiveDomain(),
ignoreNULL = TRUE, ignoreInit = FALSE) {
label=NULL, domain=getDefaultReactiveDomain(),
ignoreNULL = TRUE) {
eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
if (is.null(label))
@@ -2012,17 +1786,13 @@ eventReactive <- function(eventExpr, valueExpr,
handlerFunc <- exprToFunction(valueExpr, value.env, value.quoted)
handlerFunc <- wrapFunctionLabel(handlerFunc, "eventReactiveHandler", ..stacktraceon = TRUE)
initialized <- FALSE
invisible(reactive({
e <- eventFunc()
if (ignoreInit && !initialized) {
initialized <<- TRUE
req(FALSE)
}
req(!ignoreNULL || !isNullEvent(e))
validate(need(
!ignoreNULL || !isNullEvent(e),
message = FALSE
))
isolate(handlerFunc())
}, label = label, domain = domain, ..stacktraceon = FALSE))
@@ -2031,246 +1801,3 @@ eventReactive <- function(eventExpr, valueExpr,
isNullEvent <- function(value) {
is.null(value) || (inherits(value, 'shinyActionButtonValue') && value == 0)
}
#' Slow down a reactive expression with debounce/throttle
#'
#' Transforms a reactive expression by preventing its invalidation signals from
#' being sent unnecessarily often. This lets you ignore a very "chatty" reactive
#' expression until it becomes idle, which is useful when the intermediate
#' values don't matter as much as the final value, and the downstream
#' calculations that depend on the reactive expression take a long time.
#' \code{debounce} and \code{throttle} use different algorithms for slowing down
#' invalidation signals; see Details.
#'
#' @section Limitations:
#'
#' Because R is single threaded, we can't come close to guaranteeing that the
#' timing of debounce/throttle (or any other timing-related functions in
#' Shiny) will be consistent or accurate; at the time we want to emit an
#' invalidation signal, R may be performing a different task and we have no
#' way to interrupt it (nor would we necessarily want to if we could).
#' Therefore, it's best to think of the time windows you pass to these
#' functions as minimums.
#'
#' You may also see undesirable behavior if the amount of time spent doing
#' downstream processing for each change approaches or exceeds the time
#' window: in this case, debounce/throttle may not have any effect, as the
#' time each subsequent event is considered is already after the time window
#' has expired.
#'
#' @details
#'
#' This is not a true debounce/throttle in that it will not prevent \code{r}
#' from being called many times (in fact it may be called more times than
#' usual), but rather, the reactive invalidation signal that is produced by
#' \code{r} is debounced/throttled instead. Therefore, these functions should be
#' used when \code{r} is cheap but the things it will trigger (downstream
#' outputs and reactives) are expensive.
#'
#' Debouncing means that every invalidation from \code{r} will be held for the
#' specified time window. If \code{r} invalidates again within that time window,
#' then the timer starts over again. This means that as long as invalidations
#' continually arrive from \code{r} within the time window, the debounced
#' reactive will not invalidate at all. Only after the invalidations stop (or
#' slow down sufficiently) will the downstream invalidation be sent.
#'
#' \code{ooo-oo-oo---- => -----------o-}
#'
#' (In this graphical depiction, each character represents a unit of time, and
#' the time window is 3 characters.)
#'
#' Throttling, on the other hand, delays invalidation if the \emph{throttled}
#' reactive recently (within the time window) invalidated. New \code{r}
#' invalidations do not reset the time window. This means that if invalidations
#' continually come from \code{r} within the time window, the throttled reactive
#' will invalidate regularly, at a rate equal to or slower than than the time
#' window.
#'
#' \code{ooo-oo-oo---- => o--o--o--o---}
#'
#' @param r A reactive expression (that invalidates too often).
#' @param millis The debounce/throttle time window. You may optionally pass a
#' no-arg function or reactive expression instead, e.g. to let the end-user
#' control the time window.
#' @param priority Debounce/throttle is implemented under the hood using
#' \link[=observe]{observers}. Use this parameter to set the priority of
#' these observers. Generally, this should be higher than the priorities of
#' downstream observers and outputs (which default to zero).
#' @param domain See \link{domains}.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' library(shiny)
#' library(magrittr)
#'
#' ui <- fluidPage(
#' plotOutput("plot", click = clickOpts("hover")),
#' helpText("Quickly click on the plot above, while watching the result table below:"),
#' tableOutput("result")
#' )
#'
#' server <- function(input, output, session) {
#' hover <- reactive({
#' if (is.null(input$hover))
#' list(x = NA, y = NA)
#' else
#' input$hover
#' })
#' hover_d <- hover %>% debounce(1000)
#' hover_t <- hover %>% throttle(1000)
#'
#' output$plot <- renderPlot({
#' plot(cars)
#' })
#'
#' output$result <- renderTable({
#' data.frame(
#' mode = c("raw", "throttle", "debounce"),
#' x = c(hover()$x, hover_t()$x, hover_d()$x),
#' y = c(hover()$y, hover_t()$y, hover_d()$y)
#' )
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
# TODO: make a nice label for the observer(s)
force(r)
force(millis)
if (!is.function(millis)) {
origMillis <- millis
millis <- function() origMillis
}
v <- reactiveValues(
trigger = NULL,
when = NULL # the deadline for the timer to fire; NULL if not scheduled
)
# Responsible for tracking when f() changes.
firstRun <- TRUE
observe({
r()
if (firstRun) {
# During the first run we don't want to set v$when, as this will kick off
# the timer. We only want to do that when we see r() change.
firstRun <<- FALSE
return()
}
# The value (or possibly millis) changed. Start or reset the timer.
v$when <- Sys.time() + millis()/1000
}, label = "debounce tracker", domain = domain, priority = priority)
# This observer is the timer. It rests until v$when elapses, then touches
# v$trigger.
observe({
if (is.null(v$when))
return()
now <- Sys.time()
if (now >= v$when) {
# Mod by 999999999 to get predictable overflow behavior
v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
v$when <- NULL
} else {
invalidateLater((v$when - now) * 1000)
}
}, label = "debounce timer", domain = domain, priority = priority)
# This is the actual reactive that is returned to the user. It returns the
# value of r(), but only invalidates/updates when v$trigger is touched.
er <- eventReactive(v$trigger, {
r()
}, label = "debounce result", ignoreNULL = FALSE, domain = domain)
# Force the value of er to be immediately cached upon creation. It's very hard
# to explain why this observer is needed, but if you want to understand, try
# commenting it out and studying the unit test failure that results.
primer <- observe({
primer$destroy()
er()
}, label = "debounce primer", domain = domain, priority = priority)
er
}
#' @rdname debounce
#' @export
throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
# TODO: make a nice label for the observer(s)
force(r)
force(millis)
if (!is.function(millis)) {
origMillis <- millis
millis <- function() origMillis
}
v <- reactiveValues(
trigger = 0,
lastTriggeredAt = NULL, # Last time we fired; NULL if never
pending = FALSE # If TRUE, trigger again when timer elapses
)
blackoutMillisLeft <- function() {
if (is.null(v$lastTriggeredAt)) {
0
} else {
max(0, (v$lastTriggeredAt + millis()/1000) - Sys.time()) * 1000
}
}
trigger <- function() {
v$lastTriggeredAt <- Sys.time()
# Mod by 999999999 to get predictable overflow behavior
v$trigger <- isolate(v$trigger) %% 999999999 + 1
v$pending <- FALSE
}
# Responsible for tracking when f() changes.
observeEvent(r(), {
if (v$pending) {
# In a blackout period and someone already scheduled; do nothing
} else if (blackoutMillisLeft() > 0) {
# In a blackout period but this is the first change in that period; set
# v$pending so that a trigger will be scheduled at the end of the period
v$pending <- TRUE
} else {
# Not in a blackout period. Trigger, which will start a new blackout
# period.
trigger()
}
}, label = "throttle tracker", ignoreNULL = FALSE, priority = priority, domain = domain)
observe({
if (!v$pending) {
return()
}
timeout <- blackoutMillisLeft()
if (timeout > 0) {
invalidateLater(timeout)
} else {
trigger()
}
}, priority = priority, domain = domain)
# This is the actual reactive that is returned to the user. It returns the
# value of r(), but only invalidates/updates when v$trigger is touched.
eventReactive(v$trigger, {
r()
}, label = "throttle result", ignoreNULL = FALSE, domain = domain)
}

View File

@@ -287,30 +287,17 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
# .. ..$ y: NULL
# ..$ mapping: Named list()
#
# For ggplot2, first you need to define the print.ggplot function from inside
# renderPlot, then use it to print the plot:
# 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")
# }
#
# p <- print(ggplot(mtcars, aes(wt, mpg)) + geom_point())
# str(getGgplotCoordmap(p, 1, 72))
# For ggplot2, it might be something like:
# p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
# str(getGgplotCoordmap(p, 1))
# List of 1
# $ :List of 10
# ..$ panel : int 1
# ..$ row : int 1
# ..$ col : int 1
# ..$ panel_vars: Named list()
# ..$ scale_x : int 1
# ..$ scale_y : int 1
# ..$ log :List of 2
# .. ..$ x: NULL
# .. ..$ y: NULL
@@ -333,8 +320,8 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
# can be up to two of them.
# mtc <- mtcars
# mtc$am <- factor(mtc$am)
# p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am))
# str(getGgplotCoordmap(p, 1, 72))
# p <- ggplot(mtcars, aes(wt, mpg)) + geom_point() + facet_wrap(~ am)
# str(getGgplotCoordmap(p, 1))
# List of 2
# $ :List of 10
# ..$ panel : int 1
@@ -342,6 +329,8 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
# ..$ col : int 1
# ..$ panel_vars:List of 1
# .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
# ..$ scale_x : int 1
# ..$ scale_y : int 1
# ..$ log :List of 2
# .. ..$ x: NULL
# .. ..$ y: NULL
@@ -365,6 +354,8 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
# ..$ col : int 2
# ..$ panel_vars:List of 1
# .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
# ..$ scale_x : int 1
# ..$ scale_y : int 1
# ..$ log :List of 2
# .. ..$ x: NULL
# .. ..$ y: NULL
@@ -427,191 +418,81 @@ getPrevPlotCoordmap <- function(width, height) {
# Given a ggplot_build_gtable object, return a coordmap for it.
getGgplotCoordmap <- function(p, pixelratio, res) {
# Structure of ggplot objects changed after 2.1.0
new_ggplot <- (utils::packageVersion("ggplot2") > "2.1.0")
if (!inherits(p, "ggplot_build_gtable"))
return(NULL)
tryCatch({
# Get info from built ggplot object
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)
for (i in seq_along(info)) {
info[[i]]$range <- ranges[[i]]
}
return(info)
}, error = function(e) {
# If there was an error extracting info from the ggplot object, just return
# a list with the error message.
return(structure(list(), error = e$message))
})
}
find_panel_info <- function(b) {
# Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
# an API for extracting the necessary information.
ggplot_ver <- utils::packageVersion("ggplot2")
if (ggplot_ver > "2.2.1") {
find_panel_info_api(b)
} else if (ggplot_ver > "2.1.0") {
find_panel_info_non_api(b, ggplot_format = "new")
} else {
find_panel_info_non_api(b, ggplot_format = "old")
}
}
# This is for ggplot2>2.2.1, after an API was introduced for extracting
# information about the plot object.
find_panel_info_api <- function(b) {
# Workaround for check NOTE, until ggplot2 >2.2.1 is released
colon_colon <- `::`
# Given a built ggplot object, return x and y domains (data space coords) for
# each panel.
layout <- colon_colon("ggplot2", "summarise_layout")(b)
coord <- colon_colon("ggplot2", "summarise_coord")(b)
layers <- colon_colon("ggplot2", "summarise_layers")(b)
find_panel_info <- function(b) {
if (new_ggplot) {
layout <- b$layout$panel_layout
} else {
layout <- b$panel$layout
}
# Convert factor to numbers
layout$PANEL <- as.integer(as.character(layout$PANEL))
# Given x and y scale objects and a coord object, return a list that has
# the bases of log transformations for x and y, or NULL if it's not a
# log transform.
get_log_bases <- function(xscale, yscale, coord) {
# Given a transform object, find the log base; if the transform object is
# NULL, or if it's not a log transform, return NA.
get_log_base <- function(trans) {
if (!is.null(trans) && grepl("^log-", trans$name)) {
environment(trans$transform)$base
} else {
NA_real_
# Names of facets
facet_vars <- NULL
if (new_ggplot) {
facet <- b$layout$facet
if (inherits(facet, "FacetGrid")) {
facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
} else if (inherits(facet, "FacetWrap")) {
facet_vars <- vapply(facet$params$facets, as.character, character(1))
}
} else {
facet <- b$plot$facet
if (inherits(facet, "grid")) {
facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
} else if (inherits(facet, "wrap")) {
facet_vars <- vapply(facet$facets, as.character, character(1))
}
}
# First look for log base in scale, then coord; otherwise NULL.
list(
x = get_log_base(xscale$trans) %OR% coord$xlog %OR% NULL,
y = get_log_base(yscale$trans) %OR% coord$ylog %OR% NULL
)
# Iterate over each row in the layout data frame
lapply(seq_len(nrow(layout)), function(i) {
# Slice out one row
l <- layout[i, ]
scale_x <- l$SCALE_X
scale_y <- l$SCALE_Y
mapping <- find_plot_mappings(b)
# For each of the faceting variables, get the value of that variable in
# the current panel. Default to empty _named_ list so that it's sent as a
# JSON object, not array.
panel_vars <- list(a = NULL)[0]
for (i in seq_along(facet_vars)) {
var_name <- facet_vars[[i]]
vname <- paste0("panelvar", i)
mapping[[vname]] <- var_name
panel_vars[[vname]] <- l[[var_name]]
}
list(
panel = l$PANEL,
row = l$ROW,
col = l$COL,
panel_vars = panel_vars,
scale_x = scale_x,
scale_y = scale_x,
log = check_log_scales(b, scale_x, scale_y),
domain = find_panel_domain(b, l$PANEL, scale_x, scale_y),
mapping = mapping
)
})
}
# Given x/y min/max, and the x/y scale objects, create a list that
# represents the domain. Note that the x/y min/max should be taken from
# the layout summary table, not the scale objects.
get_domain <- function(xmin, xmax, ymin, ymax, xscale, yscale) {
is_reverse <- function(scale) {
identical(scale$trans$name, "reverse")
}
domain <- list(
left = xmin,
right = xmax,
bottom = ymin,
top = ymax
)
if (is_reverse(xscale)) {
domain$left <- -domain$left
domain$right <- -domain$right
}
if (is_reverse(yscale)) {
domain$top <- -domain$top
domain$bottom <- -domain$bottom
}
domain
}
# Rename the items in vars to have names like panelvar1, panelvar2.
rename_panel_vars <- function(vars) {
for (i in seq_along(vars)) {
names(vars)[i] <- paste0("panelvar", i)
}
vars
}
get_mappings <- function(layers, layout, coord) {
# For simplicity, we'll just use the mapping from the first layer of the
# 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)
# If either x or y is not present, give it a NULL entry.
mapping <- mergeVectors(list(x = NULL, y = NULL), mapping)
# The names (not values) of panel vars are the same across all panels,
# so just look at the first one. Also, the order of panel vars needs
# to be reversed.
vars <- rev(layout$vars[[1]])
for (i in seq_along(vars)) {
mapping[[paste0("panelvar", i)]] <- names(vars)[i]
}
if (isTRUE(coord$flip)) {
mapping[c("x", "y")] <- mapping[c("y", "x")]
}
mapping
}
# Mapping is constant across all panels, so get it here and reuse later.
mapping <- get_mappings(layers, layout, coord)
# If coord_flip is used, these need to be swapped
flip_xy <- function(layout) {
l <- layout
l$xscale <- layout$yscale
l$yscale <- layout$xscale
l$xmin <- layout$ymin
l$xmax <- layout$ymax
l$ymin <- layout$xmin
l$ymax <- layout$xmax
l
}
if (coord$flip) {
layout <- flip_xy(layout)
}
# Iterate over each row in the layout data frame
lapply(seq_len(nrow(layout)), function(i) {
# Slice out one row, use it as a list. The (former) list-cols are still
# in lists, so we need to unwrap them.
l <- as.list(layout[i, ])
l$vars <- l$vars[[1]]
l$xscale <- l$xscale[[1]]
l$yscale <- l$yscale[[1]]
list(
panel = as.numeric(l$panel),
row = l$row,
col = l$col,
# Rename panel vars. They must also be in reversed order.
panel_vars = rename_panel_vars(rev(l$vars)),
log = get_log_bases(l$xscale, l$yscale, coord),
domain = get_domain(l$xmin, l$xmax, l$ymin, l$ymax, l$xscale, l$yscale),
mapping = mapping
)
})
}
# This is for ggplot2<=2.2.1, before an API was introduced for extracting
# information about the plot object. The "old" format was used before 2.1.0.
# The "new" format was used after 2.1.0, up to 2.2.1. The reason these two
# formats are mixed together in a single function is historical, and it's not
# worthwhile to separate them at this point.
find_panel_info_non_api <- function(b, ggplot_format) {
# Given a single range object (representing the data domain) from a built
# ggplot object, return the domain.
find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
if (ggplot_format == "new") {
if (new_ggplot) {
range <- b$layout$panel_ranges[[panel_num]]
} else {
range <- b$panel$ranges[[panel_num]]
@@ -624,7 +505,7 @@ find_panel_info_non_api <- function(b, ggplot_format) {
)
# Check for reversed scales
if (ggplot_format == "new") {
if (new_ggplot) {
xscale <- b$layout$panel_scales$x[[scalex_num]]
yscale <- b$layout$panel_scales$y[[scaley_num]]
} else {
@@ -665,7 +546,7 @@ find_panel_info_non_api <- function(b, ggplot_format) {
y_names <- character(0)
# Continuous scales have a trans; discrete ones don't
if (ggplot_format == "new") {
if (new_ggplot) {
if (!is.null(b$layout$panel_scales$x[[scalex_num]]$trans))
x_names <- b$layout$panel_scales$x[[scalex_num]]$trans$name
if (!is.null(b$layout$panel_scales$y[[scaley_num]]$trans))
@@ -739,220 +620,129 @@ find_panel_info_non_api <- function(b, ggplot_format) {
mappings
}
if (ggplot_format == "new") {
layout <- b$layout$panel_layout
} else {
layout <- b$panel$layout
}
# Convert factor to numbers
layout$PANEL <- as.integer(as.character(layout$PANEL))
# Given a gtable object, return the x and y ranges (in pixel dimensions)
find_panel_ranges <- function(g, pixelratio) {
# 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.
is_null_unit <- function(x) {
# A vector of units can be either a list of individual units (a unit.list
# object), each with their own set of attributes, or an atomic vector with
# one set of attributes. ggplot2 switched from the former (in version
# 1.0.1) to the latter. We need to make sure that we get the correct
# result in both cases.
if (inherits(x, "unit.list")) {
# For ggplot2 <= 1.0.1
vapply(x, FUN.VALUE = logical(1), function(u) {
isTRUE(attr(u, "unit", exact = TRUE) == "null")
})
} else {
# For later versions of ggplot2
attr(x, "unit", exact = TRUE) == "null"
}
}
# Names of facets
facet_vars <- NULL
if (ggplot_format == "new") {
facet <- b$layout$facet
if (inherits(facet, "FacetGrid")) {
facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
} else if (inherits(facet, "FacetWrap")) {
facet_vars <- vapply(facet$params$facets, as.character, character(1))
# Workaround for a bug in the quartz device. If you have a 400x400 image and
# run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
# res setting of the device. If res=72, then it returns 400 (as expected),
# but if, e.g., res=96, it will return 300, which is incorrect.
devScaleFactor <- 1
if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
devScaleFactor <- res / 72
}
} else {
facet <- b$plot$facet
if (inherits(facet, "grid")) {
facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
} else if (inherits(facet, "wrap")) {
facet_vars <- vapply(facet$facets, as.character, character(1))
# Convert a unit (or vector of units) to a numeric vector of pixel sizes
h_px <- function(x) {
devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
}
w_px <- function(x) {
devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
}
# Given a vector of relative sizes (in grid units), and a function for
# converting grid units to numeric pixels, return a numeric vector of
# pixel sizes.
find_px_sizes <- function(rel_sizes, unit_to_px) {
# Total pixels (in height or width)
total_px <- unit_to_px(grid::unit(1, "npc"))
# Calculate size of all panel(s) together. Panels (and only panels) have
# null size.
null_idx <- is_null_unit(rel_sizes)
# All the absolute heights. At this point, null heights are 0. We need to
# calculate them separately and add them in later.
px_sizes <- unit_to_px(rel_sizes)
# Total size for panels is image size minus absolute (non-panel) elements
panel_px_total <- total_px - sum(px_sizes)
# Divide up the total panel size up into the panels (scaled by size)
panel_sizes_rel <- as.numeric(rel_sizes[null_idx])
panel_sizes_rel <- panel_sizes_rel / sum(panel_sizes_rel)
px_sizes[null_idx] <- panel_px_total * panel_sizes_rel
abs(px_sizes)
}
px_heights <- find_px_sizes(g$heights, h_px)
px_widths <- find_px_sizes(g$widths, w_px)
# Convert to absolute pixel positions
x_pos <- cumsum(px_widths)
y_pos <- cumsum(px_heights)
# Match up the pixel dimensions to panels
layout <- g$layout
# For panels:
# * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
# * For no facet or facet_grid, they'll just be named "panel". For
# facet_grid, we need to re-order the layout table. Assume that panel
# numbers go from left to right, then next row.
# Assign a number to each panel, corresponding to PANEl in the built ggplot
# object.
layout <- layout[grepl("^panel", layout$name), ]
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
)
})
}
# Iterate over each row in the layout data frame
lapply(seq_len(nrow(layout)), function(i) {
# Slice out one row
l <- layout[i, ]
scale_x <- l$SCALE_X
scale_y <- l$SCALE_Y
tryCatch({
# Get info from built ggplot object
info <- find_panel_info(p$build)
mapping <- find_plot_mappings(b)
# 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)
# For each of the faceting variables, get the value of that variable in
# the current panel. Default to empty _named_ list so that it's sent as a
# JSON object, not array.
panel_vars <- list(a = NULL)[0]
for (i in seq_along(facet_vars)) {
var_name <- facet_vars[[i]]
vname <- paste0("panelvar", i)
mapping[[vname]] <- var_name
panel_vars[[vname]] <- l[[var_name]]
for (i in seq_along(info)) {
info[[i]]$range <- ranges[[i]]
}
list(
panel = l$PANEL,
row = l$ROW,
col = l$COL,
panel_vars = panel_vars,
scale_x = scale_x,
scale_y = scale_x,
log = check_log_scales(b, scale_x, scale_y),
domain = find_panel_domain(b, l$PANEL, scale_x, scale_y),
mapping = mapping
)
})
}
# Given a gtable object, return the x and y ranges (in pixel dimensions)
find_panel_ranges <- function(g, pixelratio, 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.
is_null_unit <- function(x) {
# A vector of units can be either a list of individual units (a unit.list
# object), each with their own set of attributes, or an atomic vector with
# one set of attributes. ggplot2 switched from the former (in version
# 1.0.1) to the latter. We need to make sure that we get the correct
# result in both cases.
if (inherits(x, "unit.list")) {
# For ggplot2 <= 1.0.1
vapply(x, FUN.VALUE = logical(1), function(u) {
isTRUE(attr(u, "unit", exact = TRUE) == "null")
})
} else {
# For later versions of ggplot2
attr(x, "unit", exact = TRUE) == "null"
}
}
# Workaround for a bug in the quartz device. If you have a 400x400 image and
# run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
# res setting of the device. If res=72, then it returns 400 (as expected),
# but if, e.g., res=96, it will return 300, which is incorrect.
devScaleFactor <- 1
if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
devScaleFactor <- res / 72
}
# Convert a unit (or vector of units) to a numeric vector of pixel sizes
h_px <- function(x) {
devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
}
w_px <- function(x) {
devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
}
# Given a vector of relative sizes (in grid units), and a function for
# converting grid units to numeric pixels, return a list with: known pixel
# dimensions, scalable dimensions, and the overall space for the scalable
# objects.
find_size_info <- function(rel_sizes, unit_to_px) {
# Total pixels (in height or width)
total_px <- unit_to_px(grid::unit(1, "npc"))
# Calculate size of all panel(s) together. Panels (and only panels) have
# null size.
null_idx <- is_null_unit(rel_sizes)
# All the absolute heights. At this point, null heights are 0. We need to
# calculate them separately and add them in later.
px_sizes <- unit_to_px(rel_sizes)
# Mark the null heights as NA.
px_sizes[null_idx] <- NA_real_
# The plotting panels all are 'null' units.
null_sizes <- rep(NA_real_, length(rel_sizes))
null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
# Total size allocated for panels is the total image size minus absolute
# (non-panel) elements.
panel_px_total <- total_px - sum(px_sizes, na.rm = TRUE)
# Size of a 1null unit
null_px <- abs(panel_px_total / sum(null_sizes, na.rm = TRUE))
# This returned list contains:
# * px_sizes: A vector of known pixel dimensions. The values that were
# null units will be assigned NA. The null units are ones that scale
# when the plotting area is resized.
# * null_sizes: A vector of the null units. All others will be assigned
# NA. The null units often are 1, but they may be any value, especially
# when using coord_fixed.
# * null_px: The size (in pixels) of a 1null unit.
# * null_px_scaled: The size (in pixels) of a 1null unit when scaled to
# fit a smaller dimension (used for plots with coord_fixed).
list(
px_sizes = abs(px_sizes),
null_sizes = null_sizes,
null_px = null_px,
null_px_scaled = null_px
)
}
# Given a size_info, return absolute pixel positions
size_info_to_px <- function(info) {
px_sizes <- info$px_sizes
null_idx <- !is.na(info$null_sizes)
px_sizes[null_idx] <- info$null_sizes[null_idx] * info$null_px_scaled
# If this direction is scaled down because of coord_fixed, we need to add an
# offset so that the pixel locations are centered.
offset <- (info$null_px - info$null_px_scaled) *
sum(info$null_sizes, na.rm = TRUE) / 2
# Get absolute pixel positions
cumsum(px_sizes) + offset
}
heights_info <- find_size_info(g$heights, h_px)
widths_info <- find_size_info(g$widths, w_px)
if (g$respect) {
# This is a plot with coord_fixed. The grid 'respect' option means to use
# the same pixel value for 1null, for width and height. We want the
# smaller of the two values -- that's what makes the plot fit in the
# viewport.
null_px_min <- min(heights_info$null_px, widths_info$null_px)
heights_info$null_px_scaled <- null_px_min
widths_info$null_px_scaled <- null_px_min
}
# Convert to absolute pixel positions
y_pos <- size_info_to_px(heights_info)
x_pos <- size_info_to_px(widths_info)
# Match up the pixel dimensions to panels
layout <- g$layout
# For panels:
# * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
# * For no facet or facet_grid, they'll just be named "panel". For
# facet_grid, we need to re-order the layout table. Assume that panel
# numbers go from left to right, then next row.
# Assign a number to each panel, corresponding to PANEl in the built ggplot
# object.
layout <- layout[grepl("^panel", layout$name), ]
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
)
return(info)
}, error = function(e) {
# If there was an error extracting info from the ggplot object, just return
# a list with the error message.
return(structure(list(), error = e$message))
})
}

View File

@@ -176,12 +176,7 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
else ""
}, " ",
"class = '", htmlEscape(classNames, TRUE), "' ",
"style = 'width:", validateCssUnit(width), ";'"),
comment = {
if ("comment" %in% names(dots)) dots$comment
else FALSE
}
)
"style = 'width:", validateCssUnit(width), ";'"))
print_args <- c(print_args, non_xtable_args)
print_args <- print_args[unique(names(print_args))]

View File

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

View File

@@ -148,7 +148,7 @@ registerInputHandler("shiny.number", function(val, ...){
registerInputHandler("shiny.password", function(val, shinysession, name) {
# Mark passwords as not serializable
setSerializer(name, serializerUnserializable)
.subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
val
})
@@ -214,9 +214,7 @@ 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`.
setSerializer(name, serializerFileInput)
snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
.subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerFileInput)
val
})

View File

@@ -34,7 +34,7 @@ registerClient <- function(client) {
#' JavaScript/CSS files available to their components.
#'
#' @param prefix The URL prefix (without slashes). Valid characters are a-z,
#' A-Z, 0-9, hyphen, period, and underscore.
#' A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
#' For example, a value of 'foo' means that any request paths that begin with
#' '/foo' will be mapped to the given directory.
#' @param directoryPath The directory that contains the static resources to be
@@ -52,7 +52,7 @@ 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-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
stop("addResourcePath called with invalid prefix; please see documentation")
}
@@ -155,7 +155,7 @@ decodeMessage <- function(data) {
# Treat message as UTF-8
charData <- rawToChar(data)
Encoding(charData) <- 'UTF-8'
return(safeFromJSON(charData, simplifyVector=FALSE))
return(jsonlite::fromJSON(charData, simplifyVector=FALSE))
}
i <- 5
@@ -226,7 +226,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
message("RECV ", rawToChar(msg))
}
if (isEmptyMessage(msg))
if (identical(charToRaw("\003\xe9"), msg))
return()
msg <- decodeMessage(msg)
@@ -370,9 +370,9 @@ argsForServerFunc <- function(serverFunc, session) {
}
getEffectiveBody <- function(func) {
if (is.null(func))
NULL
else if (isS4(func) && class(func) == "functionWithTrace")
# Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
# returns NULL.
if (isS4(func) && class(func) == "functionWithTrace")
body(func@original)
else
body(func)
@@ -462,20 +462,6 @@ serviceApp <- function() {
.shinyServerMinVersion <- '0.3.4'
# 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
@@ -532,8 +518,6 @@ isRunning <- function() {
#'
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' # Apps can be run without a server.r and ui.r file
#' runApp(list(
#' ui = bootstrapPage(
@@ -571,15 +555,6 @@ runApp <- function(appDir=getwd(),
handlerManager$clear()
}, add = TRUE)
if (.globals$running) {
stop("Can't call `runApp()` from within `runApp()`. If your ",
"application code contains `runApp()`, please remove it.")
}
.globals$running <- TRUE
on.exit({
.globals$running <- FALSE
}, add = TRUE)
# Enable per-app Shiny options
oldOptionSet <- .globals$options
on.exit({
@@ -588,11 +563,7 @@ runApp <- function(appDir=getwd(),
# Make warnings print immediately
# Set pool.scheduler to support pool package
ops <- options(
# Raise warn level to 1, but don't lower it
warn = max(1, getOption("warn", default = 1)),
pool.scheduler = scheduleTask
)
ops <- options(warn = 1, pool.scheduler = scheduleTask)
on.exit(options(ops), add = TRUE)
appParts <- as.shiny.appobj(appDir)
@@ -747,22 +718,15 @@ 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 onStop before we call onStart, so that it gets called even if an
# Set up the onEnd before we call onStart, so that it gets called even if an
# error happens in onStart.
if (!is.null(appParts$onStop))
on.exit(appParts$onStop(), add = TRUE)
if (!is.null(appParts$onEnd))
on.exit(appParts$onEnd(), add = TRUE)
if (!is.null(appParts$onStart))
appParts$onStart()
@@ -1044,9 +1008,3 @@ 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)
}

286
R/shiny.R
View File

@@ -5,7 +5,7 @@ NULL
#'
#' Shiny makes it incredibly easy to build interactive web applications with R.
#' Automatic "reactive" binding between inputs and outputs and extensive
#' prebuilt widgets make it possible to build beautiful, responsive, and
#' pre-built widgets make it possible to build beautiful, responsive, and
#' powerful applications with minimal effort.
#'
#' The Shiny tutorial at \url{http://shiny.rstudio.com/tutorial/} explains
@@ -142,15 +142,6 @@ toJSON <- function(x, ..., dataframe = "columns", null = "null", na = "null",
keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...)
}
# If the input to jsonlite::fromJSON is not valid JSON, it will try to fetch a
# URL or read a file from disk. We don't want to allow that.
safeFromJSON <- function(txt, ...) {
if (!jsonlite::validate(txt)) {
stop("Argument 'txt' is not a valid JSON string.")
}
jsonlite::fromJSON(txt, ...)
}
# Call the workerId func with no args to get the worker id, and with an arg to
# set it.
#
@@ -210,13 +201,12 @@ workerId <- local({
#' }
#' \item{\code{singletons} - for internal use}
#' \item{\code{url_protocol}, \code{url_hostname}, \code{url_port},
#' \code{url_pathname}, \code{url_search}, \code{url_hash_initial}
#' and \code{url_hash} can be used to get the components of the URL
#' that was requested by the browser to load the Shiny app page.
#' These values are from the browser's perspective, so neither HTTP
#' proxies nor Shiny Server will affect these values. The
#' \code{url_search} value may be used with \code{\link{parseQueryString}}
#' to access query string parameters.
#' \code{url_pathname}, \code{url_search}, and \code{url_hash_initial}
#' can be used to get the components of the URL that was requested by the
#' browser to load the Shiny app page. These values are from the
#' browser's perspective, so neither HTTP proxies nor Shiny Server will
#' affect these values. The \code{url_search} value may be used with
#' \code{\link{parseQueryString}} to access query string parameters.
#' }
#' }
#' \code{clientData} also contains information about each output.
@@ -384,24 +374,12 @@ NULL
#' @seealso \url{http://shiny.rstudio.com/articles/modules.html}
#' @export
NS <- function(namespace, id = NULL) {
if (length(namespace) == 0)
ns_prefix <- character(0)
else
ns_prefix <- paste(namespace, collapse = ns.sep)
f <- function(id) {
if (length(id) == 0)
return(ns_prefix)
if (length(ns_prefix) == 0)
return(id)
paste(ns_prefix, id, sep = ns.sep)
}
if (missing(id)) {
f
function(id) {
paste(c(namespace, id), collapse = ns.sep)
}
} else {
f(id)
paste(c(namespace, id), collapse = ns.sep)
}
}
@@ -437,7 +415,6 @@ ShinySession <- R6Class(
restoreCallbacks = 'Callbacks',
restoredCallbacks = 'Callbacks',
bookmarkExclude = character(0), # Names of inputs to exclude from bookmarking
getBookmarkExcludeFuns = list(),
testMode = FALSE, # Are we running in test mode?
testExportExprs = list(),
@@ -602,16 +579,6 @@ ShinySession <- R6Class(
}) # withReactiveDomain
},
# Modules (scopes) call this to register a function that returns a vector
# of names to exclude from bookmarking. The function should return
# something like c("scope1-x", "scope1-y"). This doesn't use a Callback
# object because the return values of the functions are needed, but
# Callback$invoke() discards return values.
registerBookmarkExclude = function(fun) {
len <- length(private$getBookmarkExcludeFuns) + 1
private$getBookmarkExcludeFuns[[len]] <- fun
},
# Save output values and errors. This is only used for testing mode.
storeOutputValues = function(values = NULL) {
private$outputValues <- mergeVectors(private$outputValues, values)
@@ -648,15 +615,6 @@ ShinySession <- R6Class(
values$input <- allInputs[items]
}
# Apply preprocessor functions for inputs that have them.
values$input <- lapply(
setNames(names(values$input), names(values$input)),
function(name) {
preprocess <- private$getSnapshotPreprocessInput(name)
preprocess(values$input[[name]])
}
)
values$input <- sortByName(values$input)
}
@@ -670,21 +628,6 @@ ShinySession <- R6Class(
values$output <- private$outputValues[items]
}
# Filter out those outputs that have the snapshotExclude attribute.
exclude_idx <- vapply(names(values$output), function(name) {
isTRUE(attr(private$.outputs[[name]], "snapshotExclude", TRUE))
}, logical(1))
values$output <- values$output[!exclude_idx]
# Apply snapshotPreprocess functions for outputs that have them.
values$output <- lapply(
setNames(names(values$output), names(values$output)),
function(name) {
preprocess <- private$getSnapshotPreprocessOutput(name)
preprocess(values$output[[name]])
}
)
values$output <- sortByName(values$output)
}
@@ -739,20 +682,6 @@ ShinySession <- R6Class(
}
}
)
},
# Get the snapshotPreprocessOutput function for an output name. If no preprocess
# function has been set, return the identity function.
getSnapshotPreprocessOutput = function(name) {
fun <- attr(private$.outputs[[name]], "snapshotPreprocess", exact = TRUE)
fun %OR% identity
},
# Get the snapshotPreprocessInput function for an input name. If no preprocess
# function has been set, return the identity function.
getSnapshotPreprocessInput = function(name) {
fun <- private$.input$getMeta(name, "shiny.snapshot.preprocess")
fun %OR% identity
}
),
public = list(
@@ -814,7 +743,7 @@ ShinySession <- R6Class(
if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
try({
creds <- safeFromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
creds <- jsonlite::fromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
self$user <- creds$user
self$groups <- creds$groups
}, silent=FALSE)
@@ -828,8 +757,7 @@ ShinySession <- R6Class(
private$sendMessage(
config = list(
workerId = workerId(),
sessionId = self$token,
user = self$user
sessionId = self$token
)
)
},
@@ -897,7 +825,7 @@ ShinySession <- R6Class(
if (anyUnnamed(dots))
stop("exportTestValues: all arguments must be named.")
names(dots) <- ns(names(dots))
names(dots) <- vapply(names(dots), ns, character(1))
do.call(
.subset2(self, "exportTestValues"),
@@ -1011,12 +939,6 @@ ShinySession <- R6Class(
restoredCallbacks$invoke(scopeState)
})
# Returns the excluded names with the scope's ns prefix on them.
private$registerBookmarkExclude(function() {
excluded <- scope$getBookmarkExclude()
ns(excluded)
})
scope
},
ns = function(id) {
@@ -1100,10 +1022,6 @@ ShinySession <- R6Class(
}
if (is.function(func)) {
# Extract any output attributes attached to the render function. These
# will be attached to the observer after it's created.
outputAttrs <- attr(func, "outputAttrs", TRUE)
funcFormals <- formals(func)
# ..stacktraceon matches with the top-level ..stacktraceoff.., because
# the observer we set up below has ..stacktraceon=FALSE
@@ -1133,17 +1051,17 @@ ShinySession <- R6Class(
shinyCallingHandlers(func()),
shiny.custom.error = function(cond) {
if (isTRUE(getOption("show.error.messages"))) printError(cond)
structure(list(), class = "try-error", condition = cond)
structure(NULL, class = "try-error", condition = cond)
},
shiny.output.cancel = function(cond) {
structure(list(), class = "cancel-output")
structure(NULL, class = "cancel-output")
},
shiny.silent.error = function(cond) {
# Don't let shiny.silent.error go through the normal stop
# path of try, because we don't want it to print. But we
# do want to try to return the same looking result so that
# the code below can send the error to the browser.
structure(list(), class = "try-error", condition = cond)
structure(NULL, class = "try-error", condition = cond)
},
error = function(cond) {
if (isTRUE(getOption("show.error.messages"))) printError(cond)
@@ -1152,7 +1070,7 @@ ShinySession <- R6Class(
"logs or contact the app author for",
"clarification."))
}
invisible(structure(list(), class = "try-error", condition = cond))
invisible(structure(NULL, class = "try-error", condition = cond))
},
finally = {
private$sendMessage(recalculating = list(
@@ -1181,12 +1099,6 @@ ShinySession <- R6Class(
private$invalidatedOutputValues$set(name, value)
}, suspended=private$shouldSuspend(name), label=label)
# If any output attributes were added to the render function attach
# them to observer.
lapply(names(outputAttrs), function(name) {
attr(obs, name) <- outputAttrs[[name]]
})
obs$onInvalidate(function() {
self$showProgress(name)
})
@@ -1233,13 +1145,6 @@ ShinySession <- R6Class(
})
if (!hasPendingUpdates()) {
# Normally, if there are no updates, simply return without sending
# anything to the client. But if we are in test mode, we still want to
# send a message with blank `values`, so that the client knows that
# any changed inputs have been received by the server and processed.
if (isTRUE(private$testMode)) {
private$sendMessage( values = list() )
}
return(invisible())
}
@@ -1355,12 +1260,8 @@ ShinySession <- R6Class(
private$bookmarkExclude <- names
},
getBookmarkExclude = function() {
scopedExcludes <- lapply(private$getBookmarkExcludeFuns, function(f) f())
scopedExcludes <- unlist(scopedExcludes)
c(private$bookmarkExclude, scopedExcludes)
private$bookmarkExclude
},
onBookmark = function(fun) {
if (!is.function(fun) || length(fun) != 1) {
stop("`fun` must be a function that takes one argument")
@@ -1501,40 +1402,8 @@ ShinySession <- R6Class(
)
)
},
sendInsertTab = function(inputId, liTag, divTag, menuName,
target, position, select) {
private$sendMessage(
`shiny-insert-tab` = list(
inputId = inputId,
liTag = liTag,
divTag = divTag,
menuName = menuName,
target = target,
position = position,
select = select
)
)
},
sendRemoveTab = function(inputId, target) {
private$sendMessage(
`shiny-remove-tab` = list(
inputId = inputId,
target = target
)
)
},
sendChangeTabVisibility = function(inputId, target, type) {
private$sendMessage(
`shiny-change-tab-visibility` = list(
inputId = inputId,
target = target,
type = type
)
)
},
updateQueryString = function(queryString, mode) {
private$sendMessage(updateQueryString = list(
queryString = queryString, mode = mode))
updateQueryString = function(queryString) {
private$sendMessage(updateQueryString = list(queryString = queryString))
},
resetBrush = function(brushId) {
private$sendMessage(
@@ -1570,8 +1439,7 @@ ShinySession <- R6Class(
fileData <- private$fileUploadContext$getUploadOperation(jobId)$finish()
private$.input$set(inputId, fileData)
setSerializer(inputId, serializerFileInput)
snapshotPreprocessInput(inputId, snapshotPreprocessorFileInput)
private$.input$setMeta(inputId, "shiny.serializer", serializerFileInput)
invisible()
},
@@ -1614,30 +1482,9 @@ ShinySession <- R6Class(
}
}
# @description Only applicable to files uploaded via IE. When possible,
# adds the appropriate extension to temporary files created by
# \code{mime::parse_multipart}.
# @param multipart A named list as returned by
# \code{mime::parse_multipart}
# @return A named list with datapath updated to point to the new location
# of the file, if an extension was added.
maybeMoveIEUpload <- function(multipart) {
if (is.null(multipart)) return(NULL)
lapply(multipart, function(input) {
oldPath <- input$datapath
newPath <- paste0(oldPath, maybeGetExtension(input$name))
if (oldPath != newPath) {
file.rename(oldPath, newPath)
input$datapath <- newPath
}
input
})
}
if (matches[2] == 'uploadie' && identical(req$REQUEST_METHOD, "POST")) {
id <- URLdecode(matches[3])
res <- maybeMoveIEUpload(mime::parse_multipart(req))
res <- mime::parse_multipart(req)
private$.input$set(id, res[[id]])
return(httpResponse(200, 'text/plain', 'OK'))
}
@@ -1962,6 +1809,7 @@ outputOptions <- function(x, name, ...) {
.subset2(x, 'impl')$outputOptions(name, ...)
}
#' Add callbacks for Shiny session events
#'
#' These functions are for registering callbacks on Shiny session events.
@@ -1993,9 +1841,6 @@ onFlushed <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
}
#' @rdname onFlush
#'
#' @seealso \code{\link{onStop}()} for registering callbacks that will be
#' invoked when the application exits, or when a session ends.
#' @export
onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) {
session$onSessionEnded(fun)
@@ -2020,86 +1865,3 @@ flushAllSessions <- function() {
NULL
})
}
.globals$onStopCallbacks <- Callbacks$new()
#' Run code after an application or session ends
#'
#' This function registers callback functions that are invoked when the
#' application exits (when \code{\link{runApp}} exits), or after each user
#' session ends (when a client disconnects).
#'
#' @param fun A function that will be called after the app has finished running.
#' @param session A scope for when the callback will run. If \code{onStop} is
#' called from within the server function, this will default to the current
#' session, and the callback will be invoked when the current session ends. If
#' \code{onStop} is called outside a server function, then the callback will
#' be invoked with the application exits.
#'
#'
#' @seealso \code{\link{onSessionEnded}()} for the same functionality, but at
#' the session level only.
#'
#' @return A function which, if invoked, will cancel the callback.
#' @examples
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#' # Open this application in multiple browsers, then close the browsers.
#' shinyApp(
#' ui = basicPage("onStop demo"),
#'
#' server = function(input, output, session) {
#' onStop(function() cat("Session stopped\n"))
#' },
#'
#' onStart = function() {
#' cat("Doing application setup\n")
#'
#' onStop(function() {
#' cat("Doing application cleanup\n")
#' })
#' }
#' )
#' }
#' # In the example above, onStop() is called inside of onStart(). This is
#' # the pattern that should be used when creating a shinyApp() object from
#' # a function, or at the console. If instead you are writing an app.R which
#' # will be invoked with runApp(), you can do it that way, or put the onStop()
#' # before the shinyApp() call, as shown below.
#'
#' \dontrun{
#' # ==== app.R ====
#' cat("Doing application setup\n")
#' onStop(function() {
#' cat("Doing application cleanup\n")
#' })
#'
#' shinyApp(
#' ui = basicPage("onStop demo"),
#'
#' server = function(input, output, session) {
#' onStop(function() cat("Session stopped\n"))
#' }
#' )
#' # ==== end app.R ====
#'
#'
#' # Similarly, if you have a global.R, you can call onStop() from there.
#' # ==== global.R ====
#' cat("Doing application setup\n")
#' onStop(function() {
#' cat("Doing application cleanup\n")
#' })
#' # ==== end global.R ====
#' }
#' @export
onStop <- function(fun, session = getDefaultReactiveDomain()) {
if (is.null(getDefaultReactiveDomain())) {
return(.globals$onStopCallbacks$register(fun))
} else {
# Note: In the future if we allow scoping the onStop() callback to modules
# and allow modules to be stopped, then session_proxy objects will need
# its own implementation of $onSessionEnded.
return(session$onSessionEnded(fun))
}
}

View File

@@ -14,7 +14,7 @@ NULL
#' # now we can just write "static" content without withMathJax()
#' div("more math here $$\\sqrt{2}$$")
withMathJax <- function(...) {
path <- 'https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
path <- 'https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
tagList(
tags$head(
singleton(tags$script(src = path, type = 'text/javascript'))
@@ -45,6 +45,7 @@ renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
shiny_deps <- list(
htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
htmlDependency("jquery", "1.12.4", c(href="shared"), script = "jquery.min.js"),
htmlDependency("babel-polyfill", "6.7.2", c(href="shared"), script = "babel-polyfill.min.js"),
htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
stylesheet = "shiny.css")

View File

@@ -88,34 +88,6 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
useRenderFunction(x, inline = inline)
}
#' Mark a render function with attributes that will be used by the output
#'
#' @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,
snapshotPreprocess = NULL)
{
# Add the outputAttrs attribute if necessary
if (is.null(attr(renderFunc, "outputAttrs", TRUE))) {
attr(renderFunc, "outputAttrs") <- list()
}
if (!is.null(snapshotExclude)) {
attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
}
if (!is.null(snapshotPreprocess)) {
attr(renderFunc, "outputAttrs")$snapshotPreprocess <- snapshotPreprocess
}
renderFunc
}
#' Image file output
#'
#' Renders a reactive image that is suitable for assigning to an \code{output}
@@ -155,7 +127,6 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' ui <- fluidPage(
#' sliderInput("n", "Number of observations", 2, 1000, 500),
@@ -438,9 +409,7 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
renderFunc <- function(shinysession, name, ...) {
shinysession$registerDownload(name, filename, contentType, content)
}
snapshotExclude(
markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
)
markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
}
#' Table output with the JavaScript library DataTables
@@ -541,18 +510,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
)
}
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
markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
}
# a data frame containing the DataTables 1.9 and 1.10 names

View File

@@ -18,8 +18,7 @@ licenseLink <- function(licenseName) {
"Artistic-2.0" = "http://www.r-project.org/Licenses/Artistic-2.0",
"BSD_2_clause" = "http://www.r-project.org/Licenses/BSD_2_clause",
"BSD_3_clause" = "http://www.r-project.org/Licenses/BSD_3_clause",
"MIT" = "http://www.r-project.org/Licenses/MIT",
"CC-BY-SA-4.0" = "https://www.r-project.org/Licenses/CC-BY-SA-4.0")
"MIT" = "http://www.r-project.org/Licenses/MIT")
if (exists(licenseName, where = licenses)) {
tags$a(href=licenses[[licenseName]], licenseName)
} else {

View File

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

View File

@@ -2,7 +2,6 @@
#'
#' @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}}
#'
@@ -35,15 +34,15 @@
#' shinyApp(ui, server)
#' }
#' @export
updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeholder = NULL) {
message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
message <- dropNulls(list(label=label, value=value))
session$sendInputMessage(inputId, message)
}
#' Change the value of a textarea input on the client
#'
#' @template update-input
#' @inheritParams updateTextInput
#' @param value The value to set for the input object.
#'
#' @seealso \code{\link{textAreaInput}}
#'
@@ -107,10 +106,7 @@ updateTextAreaInput <- updateTextInput
#' shinyApp(ui, server)
#' }
#' @export
updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
message <- dropNulls(list(label=label, value=value))
session$sendInputMessage(inputId, message)
}
updateCheckboxInput <- updateTextInput
#' Change the label or icon of an action button on the client
@@ -456,18 +452,16 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
selected = NULL, inline = FALSE, type = NULL,
choiceNames = NULL, choiceValues = NULL) {
if (is.null(type)) stop("Please specify the type ('checkbox' or 'radio')")
selected = NULL, inline = FALSE,
type = 'checkbox') {
if (!is.null(choices))
choices <- choicesWithNames(choices)
if (!is.null(selected))
selected <- validateSelected(selected, choices, session$ns(inputId))
args <- normalizeChoicesArgs(choices, choiceNames, choiceValues, mustExist = FALSE)
if (!is.null(selected)) selected <- as.character(selected)
options <- if (!is.null(args$choiceValues)) {
options <- if (!is.null(choices)) {
format(tagList(
generateOptions(session$ns(inputId), selected, inline, type,
args$choiceNames, args$choiceValues)
generateOptions(session$ns(inputId), choices, selected, inline, type = type)
))
}
@@ -516,10 +510,9 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
#' }
#' @export
updateCheckboxGroupInput <- function(session, inputId, label = NULL,
choices = NULL, selected = NULL, inline = FALSE,
choiceNames = NULL, choiceValues = NULL) {
updateInputOptions(session, inputId, label, choices, selected,
inline, "checkbox", choiceNames, choiceValues)
choices = NULL, selected = NULL,
inline = FALSE) {
updateInputOptions(session, inputId, label, choices, selected, inline)
}
@@ -559,15 +552,10 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
#' }
#' @export
updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
selected = NULL, inline = FALSE,
choiceNames = NULL, choiceValues = NULL) {
selected = NULL, inline = FALSE) {
# you must select at least one radio button
if (is.null(selected)) {
if (!is.null(choices)) selected <- choices[[1]]
else if (!is.null(choiceValues)) selected <- choiceValues[[1]]
}
updateInputOptions(session, inputId, label, choices, selected,
inline, 'radio', choiceNames, choiceValues)
if (is.null(selected) && !is.null(choices)) selected <- choices[[1]]
updateInputOptions(session, inputId, label, choices, selected, inline, type = 'radio')
}
@@ -613,7 +601,8 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
selected = NULL) {
choices <- if (!is.null(choices)) choicesWithNames(choices)
if (!is.null(selected)) selected <- as.character(selected)
if (!is.null(selected))
selected <- validateSelected(selected, choices, inputId)
options <- if (!is.null(choices)) selectOptions(choices, selected)
message <- dropNulls(list(label = label, options = options, value = selected))
session$sendInputMessage(inputId, message)
@@ -655,7 +644,7 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
selectizeJSON <- function(data, req) {
query <- parseQueryString(req$QUERY_STRING)
# extract the query variables, conjunction (and/or), search string, maximum options
var <- c(safeFromJSON(query$field))
var <- c(jsonlite::fromJSON(query$field))
cjn <- if (query$conju == 'and') all else any
# all keywords in lower-case, for case-insensitive matching
key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])

View File

@@ -43,43 +43,53 @@ 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) {
# Save the old seed if present.
if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
hasOrigSeed <- TRUE
origSeed <- .GlobalEnv$.Random.seed
} else {
hasOrigSeed <- FALSE
}
# 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)
withTemporary(.GlobalEnv, ".Random.seed",
.globals$ownSeed, unset=is.null(.globals$ownSeed), {
tryCatch({
expr
}, finally = {
.globals$ownSeed <- getExists('.Random.seed', 'numeric', globalenv())
})
}
} 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
# 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
}
# Version of runif that runs with private seed
@@ -215,7 +225,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, ...)
@@ -662,9 +672,6 @@ 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)
@@ -1121,7 +1128,6 @@ reactiveStop <- function(message = "", class = NULL) {
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' ui <- fluidPage(
#' checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),

View File

@@ -14,9 +14,9 @@ For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstu
* Shiny applications are automatically "live" in the same way that spreadsheets are live. Outputs change instantly as users modify inputs, without requiring a reload of the browser.
* Shiny user interfaces can be built entirely using R, or can be written directly in HTML, CSS, and JavaScript for more flexibility.
* Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.).
* Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/).
* Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/2.3.2/).
* A highly customizable slider widget with built-in support for animation.
* Prebuilt output widgets for displaying plots, tables, and printed output of R objects.
* Pre-built output widgets for displaying plots, tables, and printed output of R objects.
* Fast bidirectional communication between the web browser and R using the [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!).

View File

@@ -1,3 +1,4 @@
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.

View File

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

View File

@@ -0,0 +1,21 @@
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')
})
}

View File

@@ -0,0 +1,24 @@
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")
)
)
)

View File

@@ -1 +1 @@
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.
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.

View File

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

View File

@@ -0,0 +1,26 @@
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)
})
}

View File

@@ -0,0 +1,27 @@
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")
)
)
)

View File

@@ -1,5 +1,5 @@
This example demonstrates a core feature of Shiny: **reactivity**. In the `server` function, a reactive called `datasetInput` is declared.
This example demonstrates a core feature of Shiny: **reactivity**. In `server.R`, a reactive called `datasetInput` is declared.
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 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 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.

View File

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

View File

@@ -0,0 +1,53 @@
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)
})
}

View File

@@ -0,0 +1,34 @@
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")
)
)
)

View File

@@ -1,4 +1,4 @@
This example demonstrates the following concepts:
- **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.
* **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.

View File

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

View File

@@ -0,0 +1,34 @@
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)
})
}

29
inst/examples/04_mpg/ui.R Normal file
View File

@@ -0,0 +1,29 @@
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")
)
)
)

View File

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

View File

@@ -0,0 +1,29 @@
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()
})
}

View File

@@ -0,0 +1,43 @@
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")
)
)
)

View File

@@ -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 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.
1. Scroll to the bottom of `server.R`
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.

View File

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

View File

@@ -0,0 +1,44 @@
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())
})
}

View File

@@ -0,0 +1,38 @@
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"))
)
)
)
)

View File

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

View File

@@ -0,0 +1,32 @@
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))
})
}

View File

@@ -0,0 +1,43 @@
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")
)
)
)

View File

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

View File

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

View File

@@ -0,0 +1,42 @@
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())
})
}

View File

@@ -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,25 +17,22 @@
<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>
<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>
<pre id="summary" class="shiny-text-output"></pre>
<div id="plot" class="shiny-plot-output"
style="width: 100%; height: 400px"></div>
<div id="table" class="shiny-html-output"></div>
</body>
</html>
</html>

View File

@@ -1,3 +1,4 @@
We can add a file upload input in the UI using the function `fileInput()`,
e.g. `fileInput('foo')`. In the `server` function, we can access the
uploaded files via `input$foo`.
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.

View File

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

View File

@@ -0,0 +1,20 @@
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)
})
}

View File

@@ -0,0 +1,28 @@
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')
)
)
)

View File

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

View File

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

View File

@@ -0,0 +1,21 @@
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)
}
)
}

View File

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

View File

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

View File

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

View File

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

View File

@@ -57,12 +57,9 @@ sd_section("UI Inputs",
"updateSelectInput",
"updateSliderInput",
"updateTabsetPanel",
"insertTab",
"showTab",
"updateTextInput",
"updateTextAreaInput",
"updateQueryString",
"getQueryString"
"updateQueryString"
)
)
sd_section("UI Outputs",
@@ -118,26 +115,25 @@ sd_section("Rendering functions",
"reactiveUI"
)
)
sd_section("Reactive programming",
sd_section("Reactive constructs",
"A sub-library that provides reactive programming facilities for R.",
c(
"reactive",
"observe",
"observeEvent",
"reactiveVal",
"reactiveValues",
"reactiveValuesToList",
"invalidateLater",
"is.reactivevalues",
"isolate",
"invalidateLater",
"debounce",
"showReactLog",
"makeReactiveBinding",
"observe",
"observeEvent",
"getCurrentObserver",
"reactive",
"reactiveFileReader",
"reactivePoll",
"reactiveTimer",
"reactiveValues",
"reactiveValuesToList",
"freezeReactiveValue",
"domains",
"freezeReactiveValue"
"showReactLog"
)
)
sd_section("Boilerplate",
@@ -156,8 +152,7 @@ sd_section("Running",
"runGadget",
"runUrl",
"stopApp",
"viewer",
"isRunning"
"viewer"
)
)
sd_section("Bookmarking state",
@@ -196,16 +191,10 @@ sd_section("Utility functions",
"parseQueryString",
"plotPNG",
"exportTestValues",
"setSerializer",
"snapshotExclude",
"snapshotPreprocessInput",
"snapshotPreprocessOutput",
"markOutputAttrs",
"repeatable",
"shinyDeprecated",
"serverInfo",
"shiny-options",
"onStop"
"shiny-options"
)
)
sd_section("Plot interaction",

3
inst/www/shared/babel-polyfill.min.js vendored Normal file

File diff suppressed because one or more lines are too long

View File

@@ -1,13 +1,13 @@
/*!
* Font Awesome 4.7.0 by @davegandy - http://fontawesome.io - @fontawesome
* Font Awesome 4.6.3 by @davegandy - http://fontawesome.io - @fontawesome
* License - http://fontawesome.io/license (Font: SIL OFL 1.1, CSS: MIT License)
*/
/* FONT PATH
* -------------------------- */
@font-face {
font-family: 'FontAwesome';
src: url('../fonts/fontawesome-webfont.eot?v=4.7.0');
src: url('../fonts/fontawesome-webfont.eot?#iefix&v=4.7.0') format('embedded-opentype'), url('../fonts/fontawesome-webfont.woff2?v=4.7.0') format('woff2'), url('../fonts/fontawesome-webfont.woff?v=4.7.0') format('woff'), url('../fonts/fontawesome-webfont.ttf?v=4.7.0') format('truetype'), url('../fonts/fontawesome-webfont.svg?v=4.7.0#fontawesomeregular') format('svg');
src: url('../fonts/fontawesome-webfont.eot?v=4.6.3');
src: url('../fonts/fontawesome-webfont.eot?#iefix&v=4.6.3') format('embedded-opentype'), url('../fonts/fontawesome-webfont.woff2?v=4.6.3') format('woff2'), url('../fonts/fontawesome-webfont.woff?v=4.6.3') format('woff'), url('../fonts/fontawesome-webfont.ttf?v=4.6.3') format('truetype'), url('../fonts/fontawesome-webfont.svg?v=4.6.3#fontawesomeregular') format('svg');
font-weight: normal;
font-style: normal;
}
@@ -1832,7 +1832,6 @@
content: "\f23e";
}
.fa-battery-4:before,
.fa-battery:before,
.fa-battery-full:before {
content: "\f240";
}
@@ -2179,143 +2178,6 @@
.fa-font-awesome:before {
content: "\f2b4";
}
.fa-handshake-o:before {
content: "\f2b5";
}
.fa-envelope-open:before {
content: "\f2b6";
}
.fa-envelope-open-o:before {
content: "\f2b7";
}
.fa-linode:before {
content: "\f2b8";
}
.fa-address-book:before {
content: "\f2b9";
}
.fa-address-book-o:before {
content: "\f2ba";
}
.fa-vcard:before,
.fa-address-card:before {
content: "\f2bb";
}
.fa-vcard-o:before,
.fa-address-card-o:before {
content: "\f2bc";
}
.fa-user-circle:before {
content: "\f2bd";
}
.fa-user-circle-o:before {
content: "\f2be";
}
.fa-user-o:before {
content: "\f2c0";
}
.fa-id-badge:before {
content: "\f2c1";
}
.fa-drivers-license:before,
.fa-id-card:before {
content: "\f2c2";
}
.fa-drivers-license-o:before,
.fa-id-card-o:before {
content: "\f2c3";
}
.fa-quora:before {
content: "\f2c4";
}
.fa-free-code-camp:before {
content: "\f2c5";
}
.fa-telegram:before {
content: "\f2c6";
}
.fa-thermometer-4:before,
.fa-thermometer:before,
.fa-thermometer-full:before {
content: "\f2c7";
}
.fa-thermometer-3:before,
.fa-thermometer-three-quarters:before {
content: "\f2c8";
}
.fa-thermometer-2:before,
.fa-thermometer-half:before {
content: "\f2c9";
}
.fa-thermometer-1:before,
.fa-thermometer-quarter:before {
content: "\f2ca";
}
.fa-thermometer-0:before,
.fa-thermometer-empty:before {
content: "\f2cb";
}
.fa-shower:before {
content: "\f2cc";
}
.fa-bathtub:before,
.fa-s15:before,
.fa-bath:before {
content: "\f2cd";
}
.fa-podcast:before {
content: "\f2ce";
}
.fa-window-maximize:before {
content: "\f2d0";
}
.fa-window-minimize:before {
content: "\f2d1";
}
.fa-window-restore:before {
content: "\f2d2";
}
.fa-times-rectangle:before,
.fa-window-close:before {
content: "\f2d3";
}
.fa-times-rectangle-o:before,
.fa-window-close-o:before {
content: "\f2d4";
}
.fa-bandcamp:before {
content: "\f2d5";
}
.fa-grav:before {
content: "\f2d6";
}
.fa-etsy:before {
content: "\f2d7";
}
.fa-imdb:before {
content: "\f2d8";
}
.fa-ravelry:before {
content: "\f2d9";
}
.fa-eercast:before {
content: "\f2da";
}
.fa-microchip:before {
content: "\f2db";
}
.fa-snowflake-o:before {
content: "\f2dc";
}
.fa-superpowers:before {
content: "\f2dd";
}
.fa-wpexplorer:before {
content: "\f2de";
}
.fa-meetup:before {
content: "\f2e0";
}
.sr-only {
position: absolute;
width: 1px;

File diff suppressed because one or more lines are too long

File diff suppressed because it is too large Load Diff

Before

Width:  |  Height:  |  Size: 434 KiB

After

Width:  |  Height:  |  Size: 382 KiB

View File

@@ -141,7 +141,6 @@
line-height: 0 !important;
padding: 0 !important;
margin: 0 !important;
overflow: hidden;
outline: none !important;
z-index: -9999 !important;
background: none !important;

View File

@@ -1,6 +1,6 @@
// Ion.RangeSlider
// version 2.1.6 Build: 369
// © Denis Ineshin, 2016
// Ion.RangeSlider
// version 2.1.2 Build: 350
// © Denis Ineshin, 2015
// https://github.com/IonDen
//
// Project page: http://ionden.com/a/plugins/ion.rangeSlider/en.html
@@ -10,17 +10,7 @@
// http://ionden.com/a/plugins/licence-en.html
// =====================================================================================================================
;(function(factory) {
if (typeof define === "function" && define.amd) {
define(["jquery"], function (jQuery) {
return factory(jQuery, document, window, navigator);
});
} else if (typeof exports === "object") {
factory(require("jquery"), document, window, navigator);
} else {
factory(jQuery, document, window, navigator);
}
} (function ($, document, window, navigator, undefined) {
;(function ($, document, window, navigator, undefined) {
"use strict";
// =================================================================================================================
@@ -156,7 +146,7 @@
* @constructor
*/
var IonRangeSlider = function (input, options, plugin_count) {
this.VERSION = "2.1.6";
this.VERSION = "2.1.2";
this.input = input;
this.plugin_count = plugin_count;
this.current_plugin = 0;
@@ -171,15 +161,12 @@
this.no_diapason = false;
this.is_key = false;
this.is_update = false;
this.is_first_update = true;
this.is_start = true;
this.is_finish = false;
this.is_active = false;
this.is_resize = false;
this.is_click = false;
options = options || {};
// cache for links to all DOM elements
this.$cache = {
win: $(window),
@@ -331,11 +318,6 @@
};
// check if base element is input
if ($inp[0].nodeName !== "INPUT") {
console && console.warn && console.warn("Base element should be <input>!", $inp[0]);
}
// config from data-attributes extends js config
config_from_data = {
@@ -393,15 +375,16 @@
for (prop in config_from_data) {
if (config_from_data.hasOwnProperty(prop)) {
if (config_from_data[prop] === undefined || config_from_data[prop] === "") {
if (!config_from_data[prop] && config_from_data[prop] !== 0) {
delete config_from_data[prop];
}
}
}
// input value extends default config
if (val !== undefined && val !== "") {
if (val) {
val = val.split(config_from_data.input_values_separator || options.input_values_separator || ";");
if (val[0] && val[0] == +val[0]) {
@@ -433,7 +416,6 @@
// validate config, to be sure that all data types are correct
this.update_check = {};
this.validate();
@@ -465,7 +447,7 @@
/**
* Starts or updates the plugin instance
*
* @param [is_update] {boolean}
* @param is_update {boolean}
*/
init: function (is_update) {
this.no_diapason = false;
@@ -752,6 +734,7 @@
// callbacks call
if ($.contains(this.$cache.cont[0], e.target) || this.dragging) {
this.is_finish = true;
this.callOnFinish();
}
@@ -778,7 +761,7 @@
}
if (!target) {
target = this.target || "from";
target = this.target;
}
this.current_plugin = this.plugin_count;
@@ -965,12 +948,6 @@
this.calcPointerPercent();
var handle_x = this.getHandleX();
if (this.target === "both") {
this.coords.p_gap = 0;
handle_x = this.getHandleX();
}
if (this.target === "click") {
this.coords.p_gap = this.coords.p_handle / 2;
handle_x = this.getHandleX();
@@ -1058,7 +1035,7 @@
break;
}
handle_x = this.toFixed(handle_x + (this.coords.p_handle * 0.001));
handle_x = this.toFixed(handle_x + (this.coords.p_handle * 0.1));
this.coords.p_from_real = this.convertToRealPercent(handle_x) - this.coords.p_gap_left;
this.coords.p_from_real = this.calcWithStep(this.coords.p_from_real);
@@ -1336,6 +1313,13 @@
this.$cache.s_single[0].style.left = this.coords.p_single_fake + "%";
this.$cache.single[0].style.left = this.labels.p_single_left + "%";
if (this.options.values.length) {
this.$cache.input.prop("value", this.result.from_value);
} else {
this.$cache.input.prop("value", this.result.from);
}
this.$cache.input.data("from", this.result.from);
} else {
this.$cache.s_from[0].style.left = this.coords.p_from_fake + "%";
this.$cache.s_to[0].style.left = this.coords.p_to_fake + "%";
@@ -1348,13 +1332,18 @@
}
this.$cache.single[0].style.left = this.labels.p_single_left + "%";
}
this.writeToInput();
if (this.options.values.length) {
this.$cache.input.prop("value", this.result.from_value + this.options.input_values_separator + this.result.to_value);
} else {
this.$cache.input.prop("value", this.result.from + this.options.input_values_separator + this.result.to);
}
this.$cache.input.data("from", this.result.from);
this.$cache.input.data("to", this.result.to);
}
if ((this.old_from !== this.result.from || this.old_to !== this.result.to) && !this.is_start) {
this.$cache.input.trigger("change");
this.$cache.input.trigger("input");
}
this.old_from = this.result.from;
@@ -1364,10 +1353,9 @@
if (!this.is_resize && !this.is_update && !this.is_start && !this.is_finish) {
this.callOnChange();
}
if (this.is_key || this.is_click || this.is_first_update) {
if (this.is_key || this.is_click) {
this.is_key = false;
this.is_click = false;
this.is_first_update = false;
this.callOnFinish();
}
@@ -1479,8 +1467,6 @@
this.$cache.from[0].style.visibility = "visible";
} else if (this.target === "to") {
this.$cache.to[0].style.visibility = "visible";
} else if (!this.target) {
this.$cache.from[0].style.visibility = "visible";
}
this.$cache.single[0].style.visibility = "hidden";
max = to_left;
@@ -1575,57 +1561,25 @@
/**
* Write values to input element
*/
writeToInput: function () {
if (this.options.type === "single") {
if (this.options.values.length) {
this.$cache.input.prop("value", this.result.from_value);
} else {
this.$cache.input.prop("value", this.result.from);
}
this.$cache.input.data("from", this.result.from);
} else {
if (this.options.values.length) {
this.$cache.input.prop("value", this.result.from_value + this.options.input_values_separator + this.result.to_value);
} else {
this.$cache.input.prop("value", this.result.from + this.options.input_values_separator + this.result.to);
}
this.$cache.input.data("from", this.result.from);
this.$cache.input.data("to", this.result.to);
}
},
// =============================================================================================================
// Callbacks
callOnStart: function () {
this.writeToInput();
if (this.options.onStart && typeof this.options.onStart === "function") {
this.options.onStart(this.result);
}
},
callOnChange: function () {
this.writeToInput();
if (this.options.onChange && typeof this.options.onChange === "function") {
this.options.onChange(this.result);
}
},
callOnFinish: function () {
this.writeToInput();
if (this.options.onFinish && typeof this.options.onFinish === "function") {
this.options.onFinish(this.result);
}
},
callOnUpdate: function () {
this.writeToInput();
if (this.options.onUpdate && typeof this.options.onUpdate === "function") {
this.options.onUpdate(this.result);
}
@@ -1633,7 +1587,6 @@
// =============================================================================================================
// Service methods
@@ -1843,7 +1796,7 @@
},
toFixed: function (num) {
num = num.toFixed(20);
num = num.toFixed(9);
return +num;
},
@@ -1931,36 +1884,31 @@
o.from = o.min;
}
if (typeof o.to !== "number" || isNaN(o.to)) {
if (typeof o.to !== "number" || isNaN(o.from)) {
o.to = o.max;
}
if (o.type === "single") {
if (o.from < o.min) o.from = o.min;
if (o.from > o.max) o.from = o.max;
if (o.from < o.min) {
o.from = o.min;
}
if (o.from > o.max) {
o.from = o.max;
}
} else {
if (o.from < o.min) o.from = o.min;
if (o.from > o.max) o.from = o.max;
if (o.to < o.min) o.to = o.min;
if (o.to > o.max) o.to = o.max;
if (this.update_check.from) {
if (this.update_check.from !== o.from) {
if (o.from > o.to) o.from = o.to;
}
if (this.update_check.to !== o.to) {
if (o.to < o.from) o.to = o.from;
}
if (o.from < o.min || o.from > o.max) {
o.from = o.min;
}
if (o.to > o.max || o.to < o.min) {
o.to = o.max;
}
if (o.from > o.to) {
o.from = o.to;
}
if (o.from > o.to) o.from = o.to;
if (o.to < o.from) o.to = o.from;
}
@@ -2219,10 +2167,7 @@
for (i = 0; i < num; i++) {
label = this.$cache.grid_labels[i][0];
if (this.coords.big_x[i] !== Number.POSITIVE_INFINITY) {
label.style.marginLeft = -this.coords.big_x[i] + "%";
}
label.style.marginLeft = -this.coords.big_x[i] + "%";
}
},
@@ -2284,8 +2229,6 @@
this.options.from = this.result.from;
this.options.to = this.result.to;
this.update_check.from = this.result.from;
this.update_check.to = this.result.to;
this.options = $.extend(this.options, options);
this.validate();
@@ -2363,4 +2306,4 @@
};
}());
}));
} (jQuery, document, window, navigator));

File diff suppressed because one or more lines are too long

View File

@@ -6,7 +6,6 @@
.shiny-code {
background-color: white;
margin-bottom: 0;
}
.shiny-code code {

View File

@@ -217,7 +217,7 @@
var app = document.getElementById("showcase-app-container");
$(app).animate({
width: appWidth + "px",
zoom: (zoom*100) + "%"
zoom: zoom
}, animate ? animateMs : 0);
};

View File

@@ -95,13 +95,6 @@ pre.shiny-text-output.noplaceholder:empty {
font-weight: inherit;
}
/* Work around MS Edge transition bug (issue #1637) */
@supports (-ms-ime-align:auto) {
.shiny-bound-output {
transition: 0;
}
}
.recalculating {
opacity: 0.3;
transition: opacity 250ms ease 500ms;
@@ -373,11 +366,3 @@ pre.shiny-text-output.noplaceholder:empty {
text-decoration: underline;
font-weight: bold;
}
.shiny-file-input-active {
box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(102, 175, 233, .6);
}
.shiny-file-input-over {
box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(76, 174, 76, .6);
}

File diff suppressed because it is too large Load Diff

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View File

@@ -41,3 +41,4 @@ into a namespaced one, by combining them with \code{ns.sep} in between.
\url{http://shiny.rstudio.com/articles/modules.html}
}
\keyword{datasets}

Some files were not shown because too many files have changed in this diff Show More