manipulateWidget/ 0000755 0001762 0000144 00000000000 13256207254 013563 5 ustar ligges users manipulateWidget/inst/ 0000755 0001762 0000144 00000000000 13256205556 014543 5 ustar ligges users manipulateWidget/inst/htmlwidgets/ 0000755 0001762 0000144 00000000000 13256176767 017111 5 ustar ligges users manipulateWidget/inst/htmlwidgets/combineWidgets.js 0000644 0001762 0000144 00000004024 13256176767 022412 0 ustar ligges users //Copyright © 2016 RTE Réseau de transport d’électricité
HTMLWidgets.widget({
name: 'combineWidgets',
type: 'output',
factory: function(el, width, height) {
var widgets = {};
function toArray(x) {
if (x.constructor !== Array) x = [x];
return x;
}
function getWidgetFactory(name) {
return HTMLWidgets.widgets.filter(function(x) {return x.name == name})[0];
}
function resizeAll() {
for (var k in widgets) {
var widgetEl = document.getElementById(k);
if (!widgetEl) {
delete widgets[k];
} else {
var x = widgets[k];
x.factory.resize(widgetEl, widgetEl.clientWidth, widgetEl.clientHeight, x.instance);
}
}
}
return {
renderValue: function(x) {
x.elementId = toArray(x.elementId);
x.widgetType = toArray(x.widgetType);
var nWidgets = x.widgetType.length;
el.innerHTML = x.html;
for (var i = 0; i < nWidgets; i++) {
var child = document.getElementById(x.elementId[i]);
if (x.widgetType[i] == "html") {
child.innerHTML = x.data[i];
} else {
var widgetFactory = getWidgetFactory(x.widgetType[i]);
var w = widgetFactory.initialize(child, child.clientWidth, child.clientHeight);
widgetFactory.renderValue(child, x.data[i], w);
widgets[x.elementId[i]] = {factory:widgetFactory, instance:w};
}
}
// Crosstalk inputs need special handling: see
// https://github.com/ramnathv/htmlwidgets/issues/300
if (x.hasCrosstalkInputs && crosstalk && crosstalk.bind) {
crosstalk.bind();
}
// Sometimes widgets are rendered before the size of all html element has
// been computed. Adding a small delay fixes this problem.
setTimeout(resizeAll, 5);
},
resize: function(width, height) {
resizeAll();
}
};
}
});
manipulateWidget/inst/htmlwidgets/combineWidgets.yaml 0000644 0001762 0000144 00000000266 13211521412 022710 0 ustar ligges users #Copyright © 2016 RTE Réseau de transport d’électricité
dependencies:
- name: combineWidgetStyle
version: 0.1
src: htmlwidgets
stylesheet: combineWidgets.css
manipulateWidget/inst/htmlwidgets/combineWidgets.css 0000644 0001762 0000144 00000002237 13211521412 022536 0 ustar ligges users /* Copyright © 2016 RTE Réseau de transport d’électricité */
.cw-container {
display: flex;
display: -webkit-flex;
flex-direction: column;
-webkit-flex-direction: column;
width: 100%;
height: 100%;
}
.cw-subcontainer {
flex:1;
-webkit-flex:1;
display: flex;
display: -webkit-flex;
flex-direction: row;
-webkit-flex-direction: row;
}
.cw-title {
text-align: center;
margin: 5px 0;
font-family: sans-serif;
font-weight: normal;
}
.cw-content {
flex:1;
-webkit-flex:1;
display: flex;
display: -webkit-flex;
flex-direction: column;
-webkit-flex-direction: column;
}
.cw-content.cw-by-col {
flex-direction: row;
-webkit-flex-direction: row;
}
.cw-row {
align-items: stretch;
-webkit-align-items: stretch;
display: flex;
display: -webkit-flex;
flex-direction: row;
-webkit-flex-direction: row;
}
.cw-row.cw-by-col {
flex-direction: column;
-webkit-flex-direction: column;
}
.cw-col {
align-items: stretch;
-webkit-align-items: stretch;
position: relative;
margin:5px;
}
.cw-widget {
width:100%;
height:100%;
position:absolute;
}
manipulateWidget/inst/manipulate_widget/ 0000755 0001762 0000144 00000000000 13216502327 020235 5 ustar ligges users manipulateWidget/inst/manipulate_widget/manipulate_widget.js 0000644 0001762 0000144 00000001316 13216502327 024276 0 ustar ligges users function select(el, id) {
el = $(el);
var active = el.hasClass("active");
$(".mw-btn-settings,.mw-btn-area").removeClass("active");
$(".mw-inputs").css("display", "none");
if (!active) {
el.addClass("active");
$("#" + id).css("display", "block");
}
// Resize all widgets
var widgets = HTMLWidgets.findAll(document, ".mw-chart>.html-widget");
var ids = $.map($(".mw-chart>.html-widget"), function(x, i) {return x.id});
var container;
if (widgets) {
for (var i = 0; i < widgets.length; i++) {
container = document.getElementById(ids[i]);
if (widgets[i]) {
HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]);
}
}
}
}
manipulateWidget/inst/manipulate_widget/manipulate_widget.css 0000644 0001762 0000144 00000007773 13216502327 024467 0 ustar ligges users /* MENU */
.mw-menu {
width:50px;
height:100%;
background-color: #e7e8ea;
border-right:solid 1px #e7e8ea;
padding-top: 30px;
}
/* general style for buttons */
.mw-btn {
position: relative;
width:50px;
height:50px;
cursor:pointer;
}
.mw-btn.active {
background-color: #4e9cff;
}
/* Arrow that is displayed when a button is active*/
.right-arrow {
width: 0;
height: 0;
border-style: solid;
border-width: 25px 0 25px 8px;
border-color: transparent transparent transparent #4e9cff;
position: absolute;
top:0;
left: 50px;
display:none;
}
.mw-btn:hover .right-arrow {
border-color: transparent transparent transparent #2b7be2;
}
.active>.right-arrow {
display: block;
}
/* Settings button */
.mw-btn-settings {
margin-bottom: 30px;
padding: 2px;
}
.mw-btn-settings:hover {
color:#fff;
background-color: #2b7be2;
}
.bt1, .btn.bt1 {
color: #4e9cff;
text-align: center;
vertical-align: bottom;
line-height: 44px;
font-size: 30px;
background-color: white;
border: solid 1px #4e9cff;
}
.mw-btn-settings:hover .bt1 {
color:#fff;
border:solid 1px #2b7be2;
background-color: #2b7be2;
}
.mw-btn-settings.active .bt1 {
color: white;
background-color: #4e9cff;
}
.mw-btn-settings.active:hover .bt1 {
color: white;
background-color: #2b7be2;
border: solid 1px #2b7be2;
}
/* Buttons used to display inputs for a specific area */
.mw-btn-area {
padding: 10px 3.3px;
}
.mw-btn-area:hover {
background-color: #2b7be2;
}
.mw-icon-areachart {
position:relative;
background-color: white;
border: solid 1px #4e9cff;
width: 44px;
height: 30px;
}
.mw-icon-chart {
position: absolute;
background-color: #4e9cff;
}
.mw-btn:hover .mw-icon-chart {
background-color: #2b7be2;
}
/* OK and save buttons button */
.btn.mw-btn-ok, .btn.mw-btn-save {
margin: 0 3px;
width: 44px;
height: 44px;
position: absolute;
bottom: 30px;
background-color: #26b48b;
color: white;
text-align: center;
vertical-align: bottom;
line-height: 44px;
border-radius: 5px;
font-size: 20px;
font-weight: bold;
padding:0;
}
.btn.mw-btn-ok:hover, .btn.mw-btn-ok:active, .btn.mw-btn-ok:focus, .btn.mw-btn-save:hover, .btn.mw-btn-save:focus, .btn.mw-btn-save:active {
color: white;
background-color: #0b946c;
}
.mw-btn-update {
padding: 2px;
}
.mw-btn-update .bt1 {
height: 46px;
width: 46px;
padding: 2px;
}
.mw-btn-update .bt1:focus {
color: #4e9cff;
background-color: white;
border-color: #4e9cff;
}
.mw-btn-update>.bt1:hover {
color: white;
background-color: #2b7be2;
border-color: #2b7be2;
}
.mw-btn-update .bt1:active {
color: white;
background-color: #4e9cff;
border-color: #4e9cff;
}
.mw-chart-selection {
margin-bottom: 30px;
}
/* /!\ DO NOT MODIFY THE REST OF THE FILE /!\ */
html, body {
height:100%;
}
.mw-container {
height:100%;
width:100%;
}
.with-border {
padding: 30px 0;
}
.without-ok .mw-btn-ok {
display: none;
}
.without-save .mw-btn-save {
display: none;
}
.with-border > div {
border:solid 1px #ccc;
border-radius: 5px;
}
.mw-input-container {
height:100%;
}
.mw-inputs {
width: 200px;
height:100%;
display:none;
border-right:solid 1px #4e9cff;
padding:10px;
overflow: auto;
}
.mw-chartarea {
flex: 1;
-webkit-flex: 1;
-moz-flex: 1;
-ms-flex: 1;
}
.mw-chart {
width:100%;
height:100%;
}
/* Overhide bootstrap style for some input controls */
.form-control:focus, .selectize-input.focus {
border-color: #4e9cff;
}
/* slider input */
.irs-from, .irs-to, .irs-bar, .irs-bar-edge {
background-color: #4e9cff;
}
.irs-bar {
border-top: solid 1px #4e9cff;
border-bottom: solid 1px #4e9cff;
}
/* Group of inputs */
.panel-default>.panel-heading {
background-color: #f0f0f0;
}
.panel-heading .arrow {
width: 22px;
text-align: center;
}
.panel-heading .arrow::before {
font-family: FontAwesome;
font-size: 20px;
content: "\f0d7";
display: inline-block;
padding-right: 10px;
vertical-align: middle;
}
.panel-heading.collapsed .arrow::before {
content: "\f0da";
}
manipulateWidget/inst/doc/ 0000755 0001762 0000144 00000000000 13256205556 015310 5 ustar ligges users manipulateWidget/inst/doc/manipulateWidgets.Rmd 0000644 0001762 0000144 00000026417 13211521412 021433 0 ustar ligges users ---
title: "Getting started with the manipulateWidget package"
author: "Francois Guillem"
date: "`r Sys.Date()`"
output: rmarkdown::html_vignette
vignette: >
%\VignetteIndexEntry{Getting started with manipulateWidget}
%\VignetteEngine{knitr::rmarkdown}
%\VignetteEncoding{UTF-8}
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(manipulateWidget)
```
The `manipulateWidget` package is largely inspired by the `manipulate` package from Rstudio. It provides the function ``manipulateWidget` that can be used to create in a very easy and quick way a graphical interface that lets the user modify the data or the parameters of an interactive chart. Technically, the function generates a Shiny gadget, but the user does not even have to know what is Shiny.
The package also provides the `combineWidgets` function to easily combine multiple interactive charts in a single view. Of course both functions can be used together: here is an example that uses packages `dygraphs` and `plot_ly` (code at the end of the document).

## Getting started
The main function of the package is `manipulateWidget`. It takes as argument an expression that generates an interactive chart (and more precisely an htmlwidget object. See http://www.htmlwidgets.org/ if you have never heard about it) and a set of input controls created with functions mwSlider, mwCheckbox... which are used to dynamically change values within the expression. Each time the user modifies the value of a control, the expression is evaluated again and the chart is updated. Consider the following code:
```{r eval=FALSE}
manipulateWidget(
myPlotFun(country),
country = mwSelect(c("BE", "DE", "ES", "FR"))
)
```
It generates a graphical interface with a select input on its left with options "BE", "DE", "ES", "FR". The value of this input is mapped to the variable `country` in the expression. By default, at the beginning the value of `country` will be equal to the first choice of the input. So the function will first execute `myPlotFun("BE")` and the result will be displayed in the main panel of the interface. If the user changes the value to "FR", then the expression `myPlotFun("FR")` is evaluated and the new result is displayed.
The interface also contains a button "Done". When the user clicks on it, the last chart is returned. It can be stored in a variable, be modified by the user, saved as a html file with saveWidget from package htmlwidgets or converted to a static image file with package `webshot`.
Of course, one can create as many controls as needed. The interface of the animated example in the introduction was generated with the following code:
```{r eval=FALSE}
manipulateWidget(
myPlotFun(distribution, range, title),
distribution = mwSelect(choices = c("gaussian", "uniform")),
range = mwSlider(2000, 2100, value = c(2000, 2100), label = "period"),
title = mwText()
)
```
To see all available controls that can be added to the UI, take a look at the list of the functions of the package:
```{r eval=FALSE}
help(package = "manipulateWidget")
```
## Combining widgets
The `combineWidgets` function gives an easy way to combine interactive charts (like `par(mfrow = c(...))` or `layout` for static plots). To do it, one has simply to pass to the function the widgets to combine. In the next example, we visualize two random time series with dygraphs and combine them.
```{r combine, warning=FALSE, out.width="100%"}
library(dygraphs)
plotRandomTS <- function(id) {
dygraph(data.frame(x = 1:10, y = rnorm(10)), main = paste("Random plot", id))
}
combineWidgets(plotRandomTS(1), plotRandomTS(2))
```
The functions tries to find the best number of columns and rows. But one can control them with parameters `nrow`and `ncol`. It is also possible to control their relative size with parameters `rowsize` and `colsize`. To achieve complex layouts, it is possible to use nested combined widgets. Here is an example of a complex layout.
```{r combine_complex_layout, , out.width="100%"}
combineWidgets(
ncol = 2, colsize = c(2, 1),
plotRandomTS(1),
combineWidgets(
ncol = 1,
plotRandomTS(2),
plotRandomTS(3),
plotRandomTS(4)
)
)
```
Even if the main use of `combineWidgets` is to combine `htmlwidgets`, it can also display text or html tags. It can be useful to include comments in a chart. Moreover it has arguments to add a title and to add some html content in the sides of the chart.
```{r combine_content, , out.width="100%", out.height=400}
combineWidgets(
plotRandomTS(1),
plotRandomTS(2),
plotRandomTS(3),
plotRandomTS(4),
title = "Four random plots",
header = "Here goes the header content. It can include html code .",
footer = "Here goes the footer content.",
leftCol = "
left column
",
rightCol = "right column
"
)
```
## Advanced usage
### Comparison mode
Sometimes one wants to compare two similar charts to visualize the impact of some parameter or to compare different data sets. `manipulateWidget` has an argument to perform such comparison without writing much code: `.compare`. One just has to write the code to generate one chart and use this argument to specify which parameters should vary between the two charts. Here is a toy example that uses `dygraphs`.
```{r eval=FALSE}
mydata <- data.frame(
timeId = 1:100,
series1 = rnorm(100),
series2 = rnorm(100),
series3 = rnorm(100)
)
manipulateWidget(
dygraph(mydata[range[1]:range[2], c("timeId", series)], main = title),
range = mwSlider(1, 100, c(1, 100)),
series = mwSelect(c("series1", "series2", "series3")),
title = mwText(),
.compare = list(
title = list("First chart", "Second chart"),
series = NULL
)
)
```

### Grouping controls
If you have a large number of inputs, you can easily group them. To do so, simply use function `mwGroup()`. Here is a toy example. Groups are by default collapsed and user can click on their title to display/collapse then.
```{r eval = FALSE}
mydata <- data.frame(x = 1:100, y = rnorm(100))
manipulateWidget(
dygraph(mydata[range[1]:range[2], ],
main = title, xlab = xlab, ylab = ylab),
range = mwSlider(1, 100, c(1, 100)),
"Graphical parameters" = mwGroup(
title = mwText("Fictive time series"),
xlab = mwText("X axis label"),
ylab = mwText("Y axis label")
)
)
```

### Conditional inputs
Sometimes some inputs are relevant only if other inputs have some value. `manipulateWidget`provides a way to show/hide inputs conditionally to the value of the other inputs thanks to parameter `.display` of the input generator functions. This parameter needs to be an expression that evaluates to `TRUE` or `FALSE`. Here is a toy example, using package `plot_ly`. User can choose points or lines to represent some data. If he chooses lines, then an input appears to let him choose the width of the lines.
```{r eval=FALSE}
mydata <- data.frame(x = 1:100, y = rnorm(100))
myPlot <- function(type, lwd) {
if (type == "points") {
plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "markers")
} else {
plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "lines",
line = list(width = lwd))
}
}
manipulateWidget(
myPlot(type, lwd),
type = mwSelect(c("points", "lines"), "points"),
lwd = mwSlider(1, 10, 1, .display = type == "lines")
)
```

### Updating an input control
`manipulateWidget` provides a simple mecanism to dynamically update inputs. Indeed, all input generator functions (`mwSlider()`, `mwSelect()`, etc.) accept as parameters expressions that depend on the value of the other inputs. Thanks to this mechanism, you can dynamically modify an input based on the value. For instance, one can change the available choices of a select input based on the value of another input.
Here is an example that uses package `plotly` to represent with a barchart a car from the `mtcars` dataset. User chooses the number of cylinders and then a car among the ones with this number of cylinders.
```{r dynamic_input, eval=FALSE}
colMax <- apply(mtcars, 2, max)
plotCar <- function(carName) {
carValues <- unlist(mtcars[carName, ])
carValuesRel <- carValues / colMax
plot_ly() %>%
add_bars(x = names(mtcars), y = carValuesRel, text = carValues,
hoverinfo = c("x+text"))
}
carChoices <- split(row.names(mtcars), mtcars$cyl)
str(carChoices)
## $ 4: chr [1:11] "Datsun 710" "Merc 240D" "Merc 230" "Fiat 128" ...
## $ 6: chr [1:7] "Mazda RX4" "Mazda RX4 Wag" "Hornet 4 Drive" "Valiant" ...
## $ 8: chr [1:14] "Hornet Sportabout" "Duster 360" "Merc 450SE" "Merc 450SL" ...
manipulateWidget(
plotCar(car),
cylinders = mwSelect(c("4", "6", "8")),
car = mwSelect(choices = carChoices[[cylinders]])
)
```

### Updating a widget
The "normal" use of `manipulateWidget` is to provide an expression that always return an `htmlwidget`. In such case, every time the user changes the value of an input, the current widget is destroyed and a new one is created and rendered. This behavior is not optimal and sometimes it can be painful for the user: consider for instance an interactive map. Each time user changes an input, the map is destroyed and created again, then zoom and location on the map are lost every time.
Some packages provide functions to update a widget that has already been rendered. This is the case for instance for package `leaflet` with the function `leafletProxy`. To use such functions, `manipulateWidget` evaluates the parameter `.expr` with extra variables:
* `.initial`: `TRUE` if the expression is evaluated for the first time and then the widget has not been rendered yet, `FALSE` if the widget has already been rendered.
* `.session`: A shiny session object.
* `.outputId`: ID of the element containing the widget.
It is quite easy to write an expression that initializes a widget when it is evaluated the first time and then updates this widget. Here is an example using package `leaflet`.
```{r eval=FALSE}
lon <- rnorm(10, sd = 20)
lat <- rnorm(10, sd = 20)
myMapFun <- function(radius, color, initial, session, outputId) {
if (initial) {
# Widget has not been rendered
map <- leaflet() %>% addTiles()
} else {
# widget has already been rendered
map <- leafletProxy(outputId, session) %>% clearMarkers()
}
map %>% addCircleMarkers(lon, lat, radius = radius, color = color)
}
manipulateWidget(myMapFun(radius, color, .initial, .session, .output),
radius = mwSlider(5, 30, 10),
color = mwSelect(c("red", "blue", "green")))
```

### Using `manipulateWidget` in a document
`manipulateWidget` uses Shiny, so it does not work in a "normal" Rmarkdown document. If one uses the function in a code chunck, the htmlwidget will be outputed with the default values of the parameters and there will be no interface to modify the parameters.
Nevertheless, it is possible to include a shiny application in a document with the runtime: shiny (see http://rmarkdown.rstudio.com/authoring_shiny.html). In such setting `manipulateWidget` works normally and the document can be published on a shiny server to let final users play with the parameters of the document.
manipulateWidget/inst/doc/manipulateWidgets.html 0000644 0001762 0000144 00012651712 13256205556 021703 0 ustar ligges users
Getting started with the manipulateWidget package
Getting started with the manipulateWidget package
Francois Guillem
2018-03-26
The manipulateWidget
package is largely inspired by the manipulate
package from Rstudio. It provides the function `manipulateWidget
that can be used to create in a very easy and quick way a graphical interface that lets the user modify the data or the parameters of an interactive chart. Technically, the function generates a Shiny gadget, but the user does not even have to know what is Shiny.
The package also provides the combineWidgets
function to easily combine multiple interactive charts in a single view. Of course both functions can be used together: here is an example that uses packages dygraphs
and plot_ly
(code at the end of the document).
Getting started
The main function of the package is manipulateWidget
. It takes as argument an expression that generates an interactive chart (and more precisely an htmlwidget object. See http://www.htmlwidgets.org/ if you have never heard about it) and a set of input controls created with functions mwSlider, mwCheckbox… which are used to dynamically change values within the expression. Each time the user modifies the value of a control, the expression is evaluated again and the chart is updated. Consider the following code:
manipulateWidget (
myPlotFun (country),
country = mwSelect (c ("BE" , "DE" , "ES" , "FR" ))
)
It generates a graphical interface with a select input on its left with options “BE”, “DE”, “ES”, “FR”. The value of this input is mapped to the variable country
in the expression. By default, at the beginning the value of country
will be equal to the first choice of the input. So the function will first execute myPlotFun("BE")
and the result will be displayed in the main panel of the interface. If the user changes the value to “FR”, then the expression myPlotFun("FR")
is evaluated and the new result is displayed.
The interface also contains a button “Done”. When the user clicks on it, the last chart is returned. It can be stored in a variable, be modified by the user, saved as a html file with saveWidget from package htmlwidgets or converted to a static image file with package webshot
.
Of course, one can create as many controls as needed. The interface of the animated example in the introduction was generated with the following code:
manipulateWidget (
myPlotFun (distribution, range, title),
distribution = mwSelect (choices = c ("gaussian" , "uniform" )),
range = mwSlider (2000 , 2100 , value = c (2000 , 2100 ), label = "period" ),
title = mwText ()
)
To see all available controls that can be added to the UI, take a look at the list of the functions of the package:
help (package = "manipulateWidget" )
Advanced usage
Comparison mode
Sometimes one wants to compare two similar charts to visualize the impact of some parameter or to compare different data sets. manipulateWidget
has an argument to perform such comparison without writing much code: .compare
. One just has to write the code to generate one chart and use this argument to specify which parameters should vary between the two charts. Here is a toy example that uses dygraphs
.
mydata <- data.frame (
timeId = 1 : 100 ,
series1 = rnorm (100 ),
series2 = rnorm (100 ),
series3 = rnorm (100 )
)
manipulateWidget (
dygraph (mydata[range[1 ]: range[2 ], c ("timeId" , series)], main = title),
range = mwSlider (1 , 100 , c (1 , 100 )),
series = mwSelect (c ("series1" , "series2" , "series3" )),
title = mwText (),
.compare = list (
title = list ("First chart" , "Second chart" ),
series = NULL
)
)
Grouping controls
If you have a large number of inputs, you can easily group them. To do so, simply use function mwGroup()
. Here is a toy example. Groups are by default collapsed and user can click on their title to display/collapse then.
mydata <- data.frame (x = 1 : 100 , y = rnorm (100 ))
manipulateWidget (
dygraph (mydata[range[1 ]: range[2 ], ],
main = title, xlab = xlab, ylab = ylab),
range = mwSlider (1 , 100 , c (1 , 100 )),
"Graphical parameters" = mwGroup (
title = mwText ("Fictive time series" ),
xlab = mwText ("X axis label" ),
ylab = mwText ("Y axis label" )
)
)
manipulateWidget/inst/doc/manipulateWidgets.R 0000644 0001762 0000144 00000011576 13256205555 021132 0 ustar ligges users ## ----setup, include=FALSE------------------------------------------------
knitr::opts_chunk$set(echo = TRUE)
library(manipulateWidget)
## ----eval=FALSE----------------------------------------------------------
# manipulateWidget(
# myPlotFun(country),
# country = mwSelect(c("BE", "DE", "ES", "FR"))
# )
## ----eval=FALSE----------------------------------------------------------
# manipulateWidget(
# myPlotFun(distribution, range, title),
# distribution = mwSelect(choices = c("gaussian", "uniform")),
# range = mwSlider(2000, 2100, value = c(2000, 2100), label = "period"),
# title = mwText()
# )
## ----eval=FALSE----------------------------------------------------------
# help(package = "manipulateWidget")
## ----combine, warning=FALSE, out.width="100%"----------------------------
library(dygraphs)
plotRandomTS <- function(id) {
dygraph(data.frame(x = 1:10, y = rnorm(10)), main = paste("Random plot", id))
}
combineWidgets(plotRandomTS(1), plotRandomTS(2))
## ----combine_complex_layout, , out.width="100%"--------------------------
combineWidgets(
ncol = 2, colsize = c(2, 1),
plotRandomTS(1),
combineWidgets(
ncol = 1,
plotRandomTS(2),
plotRandomTS(3),
plotRandomTS(4)
)
)
## ----combine_content, , out.width="100%", out.height=400-----------------
combineWidgets(
plotRandomTS(1),
plotRandomTS(2),
plotRandomTS(3),
plotRandomTS(4),
title = "Four random plots",
header = "Here goes the header content. It can include html code .",
footer = "Here goes the footer content.",
leftCol = "left column
",
rightCol = "right column
"
)
## ----eval=FALSE----------------------------------------------------------
# mydata <- data.frame(
# timeId = 1:100,
# series1 = rnorm(100),
# series2 = rnorm(100),
# series3 = rnorm(100)
# )
# manipulateWidget(
# dygraph(mydata[range[1]:range[2], c("timeId", series)], main = title),
# range = mwSlider(1, 100, c(1, 100)),
# series = mwSelect(c("series1", "series2", "series3")),
# title = mwText(),
# .compare = list(
# title = list("First chart", "Second chart"),
# series = NULL
# )
# )
## ----eval = FALSE--------------------------------------------------------
# mydata <- data.frame(x = 1:100, y = rnorm(100))
# manipulateWidget(
# dygraph(mydata[range[1]:range[2], ],
# main = title, xlab = xlab, ylab = ylab),
# range = mwSlider(1, 100, c(1, 100)),
# "Graphical parameters" = mwGroup(
# title = mwText("Fictive time series"),
# xlab = mwText("X axis label"),
# ylab = mwText("Y axis label")
# )
# )
## ----eval=FALSE----------------------------------------------------------
# mydata <- data.frame(x = 1:100, y = rnorm(100))
#
# myPlot <- function(type, lwd) {
# if (type == "points") {
# plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "markers")
# } else {
# plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "lines",
# line = list(width = lwd))
# }
# }
#
# manipulateWidget(
# myPlot(type, lwd),
# type = mwSelect(c("points", "lines"), "points"),
# lwd = mwSlider(1, 10, 1, .display = type == "lines")
# )
## ----dynamic_input, eval=FALSE-------------------------------------------
# colMax <- apply(mtcars, 2, max)
#
# plotCar <- function(carName) {
# carValues <- unlist(mtcars[carName, ])
# carValuesRel <- carValues / colMax
# plot_ly() %>%
# add_bars(x = names(mtcars), y = carValuesRel, text = carValues,
# hoverinfo = c("x+text"))
# }
#
# carChoices <- split(row.names(mtcars), mtcars$cyl)
#
# str(carChoices)
# ## $ 4: chr [1:11] "Datsun 710" "Merc 240D" "Merc 230" "Fiat 128" ...
# ## $ 6: chr [1:7] "Mazda RX4" "Mazda RX4 Wag" "Hornet 4 Drive" "Valiant" ...
# ## $ 8: chr [1:14] "Hornet Sportabout" "Duster 360" "Merc 450SE" "Merc 450SL" ...
#
# manipulateWidget(
# plotCar(car),
# cylinders = mwSelect(c("4", "6", "8")),
# car = mwSelect(choices = carChoices[[cylinders]])
# )
## ----eval=FALSE----------------------------------------------------------
# lon <- rnorm(10, sd = 20)
# lat <- rnorm(10, sd = 20)
#
# myMapFun <- function(radius, color, initial, session, outputId) {
# if (initial) {
# # Widget has not been rendered
# map <- leaflet() %>% addTiles()
# } else {
# # widget has already been rendered
# map <- leafletProxy(outputId, session) %>% clearMarkers()
# }
#
# map %>% addCircleMarkers(lon, lat, radius = radius, color = color)
# }
#
# manipulateWidget(myMapFun(radius, color, .initial, .session, .output),
# radius = mwSlider(5, 30, 10),
# color = mwSelect(c("red", "blue", "green")))
#
manipulateWidget/tests/ 0000755 0001762 0000144 00000000000 13216502327 014720 5 ustar ligges users manipulateWidget/tests/testthat.R 0000644 0001762 0000144 00000000114 13211521412 016666 0 ustar ligges users library(testthat)
library(manipulateWidget)
test_check("manipulateWidget")
manipulateWidget/tests/testthat/ 0000755 0001762 0000144 00000000000 13256207253 016564 5 ustar ligges users manipulateWidget/tests/testthat/test-on_done.R 0000644 0001762 0000144 00000002541 13216502327 021303 0 ustar ligges users context("onDone")
describe("onDone", {
it ("stops the shiny gadget and returns a htmlwidget", {
with_mock(
`shiny::stopApp` = function(x) {
print("Stop gadget")
x
},
{
inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)))
expr <- expression(combineWidgets(paste(x1, x2)))
controller <- MWController(expr, inputs)$init()
expect_output(res <- onDone(controller), "Stop gadget")
expect_is(res, "htmlwidget")
expect_equal(length(res$widgets), 1)
expect_equal(res$widgets[[1]], "value1 1")
}
)
})
it ("returns a combined widget if comparison", {
suppressWarnings({with_mock(
`shiny::stopApp` = function(x) {
print("Stop gadget")
x
},
{
compare <- list(x2 = list(1, 2, 3))
inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)),
compare = compare, ncharts = 3)
expr <- expression(paste(x1, x2))
controller <- MWController(expr, inputs)$init()
expect_output(res <- onDone(controller), "Stop gadget")
expect_is(res, "combineWidgets")
expect_equal(length(res$widgets), 3)
for (i in 1:3) {
expect_equal(res$widgets[[i]]$widgets[[1]], paste("value1", compare$x2[[i]]))
}
}
)})
})
})
manipulateWidget/tests/testthat/test-get_output_and_render_func.R 0000644 0001762 0000144 00000001542 13216502327 025255 0 ustar ligges users context("getOutputAndRenderFunc")
describe("getOutputAndRenderFunc", {
if(require("leaflet")){
it ("returns output and render functions of a widget", {
widget <- leaflet()
res <- getOutputAndRenderFunc(widget)
expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets"))
expect_equal(res$outputFunc, leaflet::leafletOutput)
expect_equal(res$renderFunc, leaflet::renderLeaflet)
expect_equal(res$useCombineWidgets, FALSE)
})
it ("returns combineWidgets output and render functions if x is not an htmlwidget", {
res <- getOutputAndRenderFunc("test")
expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets"))
expect_equal(res$outputFunc, combineWidgetsOutput)
expect_equal(res$renderFunc, renderCombineWidgets)
expect_equal(res$useCombineWidgets, TRUE)
})
}
})
manipulateWidget/tests/testthat/test-input_utils.R 0000644 0001762 0000144 00000007650 13216502327 022247 0 ustar ligges users context("Input utils")
describe("filterAndInitInputs", {
it ("returns a filtered list of initialized inputs", {
inputs <- list(a = mwText(), b = mwText(), c = mwText())
# Keep inputs
filteredInputs <- filterAndInitInputs(inputs, c("a", "b"))
expect_is(filteredInputs, "list")
expect_length(filteredInputs, 2)
expect_equal(names(filteredInputs), c("a", "b"))
for (i in filteredInputs) {
expect_is(i, "Input")
expect_initialized(i)
}
# Drop inputs
filteredInputs <- filterAndInitInputs(inputs, c("a", "b"), drop = TRUE)
expect_is(filteredInputs, "list")
expect_length(filteredInputs, 1)
expect_equal(names(filteredInputs), c("c"))
for (i in filteredInputs) {
expect_is(i, "Input")
expect_initialized(i)
}
})
it ("filters grouped inputs", {
inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
# Keep inputs
filteredInputs <- filterAndInitInputs(inputs, c("a", "c"))
expect_is(filteredInputs, "list")
expect_length(filteredInputs, 2)
expect_equal(names(filteredInputs), c("grp", "c"))
for (i in filteredInputs) {
expect_initialized(i)
}
expect_is(filteredInputs$grp$value, "list")
expect_length(filteredInputs$grp$value, 1)
expect_equal(names(filteredInputs$grp$value), "a")
expect_initialized(filteredInputs$grp$value$a)
# Drop inputs
filteredInputs <- filterAndInitInputs(inputs, c("a", "c"), drop = TRUE)
expect_is(filteredInputs, "list")
expect_length(filteredInputs, 1)
expect_equal(names(filteredInputs), c("grp"))
for (i in filteredInputs) {
expect_is(i, "Input")
expect_initialized(i)
}
expect_is(filteredInputs$grp$value, "list")
expect_length(filteredInputs$grp$value, 1)
expect_equal(names(filteredInputs$grp$value), "b")
expect_initialized(filteredInputs$grp$value$b)
})
it ("removes empty groups", {
inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
filteredInputs <- filterAndInitInputs(inputs, c("c"))
expect_is(filteredInputs, "list")
expect_length(filteredInputs, 1)
expect_equal(names(filteredInputs), c("c"))
})
it ("selects/removes a whole group", {
inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
filteredInputs <- filterAndInitInputs(inputs, c("grp"))
expect_is(filteredInputs, "list")
expect_length(filteredInputs, 1)
expect_equal(names(filteredInputs), c("grp"))
expect_is(filteredInputs$grp$value, "list")
expect_length(filteredInputs$grp$value, 2)
expect_equal(names(filteredInputs$grp$value), c("a", "b"))
expect_initialized(filteredInputs$grp$value$a)
expect_initialized(filteredInputs$grp$value$b)
filteredInputs <- filterAndInitInputs(inputs, c("grp"), TRUE)
expect_is(filteredInputs, "list")
expect_length(filteredInputs, 1)
expect_equal(names(filteredInputs), c("c"))
})
it ("updates initial value of an input", {
inputs <- list(a = mwText(), b = mwText(), c = mwText())
filteredInputs <- filterAndInitInputs(inputs, "a", newValues = list(a = "test"))
expect_equal(filteredInputs$a$value, "test")
expect_equal(filteredInputs$a$env$a, "test")
})
})
describe("flattenInputs", {
it ("flattens grouped inputs", {
inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
inputs <- filterAndInitInputs(inputs, c(), TRUE)
inputList <- flattenInputs(inputs)
expect_is(inputList, "list")
expect_length(inputList, 4)
expect_true(all(c("a", "b", "c", "grp") %in% names(inputList)))
for (i in inputList) expect_initialized(i)
})
it("returns a list that can be used to create an InputList object", {
inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
inputs <- filterAndInitInputs(inputs, c(), TRUE, env = initEnv(parent.frame(), 1))
inputList <- flattenInputs(inputs)
expect_silent(InputList(inputs = inputList))
})
})
manipulateWidget/tests/testthat/test-inputs.R 0000644 0001762 0000144 00000005132 13216502327 021203 0 ustar ligges users context("Shiny inputs")
# Slider
test_input(mwSlider(0, 10, 0), c(5, -20, 20), c(5, 0, 10))
# Slider with two values
test_input(
mwSlider(0, 10, 0),
list(c(5, 7), c(-20, 20), c(-20, 5), c(5, 20)),
list(c(5, 7), c(0, 10), c(0, 5), c(5, 10))
)
# Text
test_input(mwText(), list("1", 1, NULL), list("1", "1", ""))
# Numeric
test_input(mwNumeric(0), list(5, -20, 20, NULL, "a"), list(5, -20, 20, NULL, NULL))
test_input(mwNumeric(0, min = 0, max = 10), c(5, -20, 20), c(5, 0, 10))
# Password
test_input(mwPassword(), list("1", 1, NULL), list("1", "1", ""))
# Select
test_input(mwSelect(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1))
test_input(
mwSelect(1:4, multiple = TRUE),
list(1, 5, NULL, 3:5),
list(1, integer(0), integer(0), 3:4)
)
# Select where choices have distinct label and values
test_input(
mwSelect(list(a = 1, b = 2)),
list(1, 2, 5, NULL),
list(1, 2, 1, 1)
)
test_input(
mwSelect(list(a = 1, b = 2), multiple = TRUE),
list(1, 2, 5, NULL, 1:3),
list(1, 2, integer(0), integer(0), 1:2)
)
# Checkbox
test_input(
mwCheckbox(),
list(TRUE, FALSE, NULL, NA, "test"),
list(TRUE, FALSE, FALSE, FALSE, FALSE)
)
# Radio buttons
test_input(mwRadio(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1))
test_input(
mwRadio(list(a = 1, b = 2)),
list(1, 2, 5, NULL),
list(1, 2, 1, 1)
)
# Date picker
test_input(
mwDate(),
list(Sys.Date(), "2017-01-01", NULL),
list(Sys.Date(), as.Date("2017-01-01"), Sys.Date())
)
# Date with min and max dates
test_input(
mwDate(min = "2017-01-01", max = "2017-12-31"),
list("2017-06-01", "2016-06-01", "2018-06-01"),
list(as.Date("2017-06-01"), as.Date("2017-01-01"), as.Date("2017-12-31"))
)
# Date range
defaultRange <- c(Sys.Date(), Sys.Date())
test_input(
mwDateRange(),
list(defaultRange, as.character(defaultRange), NULL),
list(defaultRange, defaultRange, defaultRange)
)
# Date range with min and max dates
test_input(
mwDateRange(min = "2017-01-01", max = "2017-12-31"),
list(c("2016-01-01", "2018-01-01")),
list(as.Date(c("2017-01-01", "2017-12-31")))
)
# Checkbox group
test_input(
mwCheckboxGroup(1:4),
list(1, 5, NULL, 3:5),
list(1, integer(0), integer(0), 3:4)
)
test_input(
mwCheckboxGroup(list(a = 1, b = 2)),
list(1, 2, 5, NULL, 1:3),
list(1, 2, integer(0), integer(0), 1:2)
)
# Groups of input
test_input(mwGroup(a = mwText(), b = mwText()))
test_that("mwGroup throws an error if an argument is not named", {
expect_error(mwGroup(mwText()), "All arguments need to be named.")
})
test_that("mwGroup throws an error if an argument is not an input", {
expect_error(mwGroup(a = 1), "All arguments need to be Input objects.")
})
manipulateWidget/tests/testthat/test-staticPlot.R 0000644 0001762 0000144 00000001202 13216502327 022001 0 ustar ligges users context("Static plot & image")
describe("Static plot & image", {
it("returns a combineWidget with both static plot and image", {
tmp_png <- tempfile(fileext = ".png")
png(file = tmp_png, bg = "transparent")
plot(1:10)
dev.off()
c <- combineWidgets(
staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300),
staticImage(tmp_png)
)
expect_is(c, "combineWidgets")
expect_length(c$widgets, 2)
# # check saveWidget and so preRenderCombinedWidgets
# tmp_html <- tempfile(fileext = ".html")
# htmlwidgets::saveWidget(c, tmp_html)
# expect_true(file.exists(tmp_html))
})
})
manipulateWidget/tests/testthat/test-input_list_class.R 0000644 0001762 0000144 00000007743 13216502327 023252 0 ustar ligges users context("InputList class")
describe("InputList", {
it ("correctly updates values when an input value changes", {
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
inputList <- InputList(inputs)$init()
expect_equal(inputList$inputs$output_1_y$value, 5)
inputList$setValue(inputId = "output_1_x", value = 7)
expect_equal(inputList$inputs$output_1_y$value, 7)
})
it("detects dependencies between inputs", {
inputs <- list(
x = mwSlider(0, 10, 5),
y = mwSlider(x, 10, 0, .display = z > 3),
z = mwSlider(0, x, 0)
)
inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
inputList <- InputList(inputs)$init()
expect_equal(inputList$getDeps(inputList$inputs$output_1_x),
list(params = character(), display = character()))
expect_length(inputList$inputs$output_1_y$revDeps, 0)
expect_equal(inputList$getDeps(inputList$inputs$output_1_y),
list(params = "output_1_x", display = "output_1_z"))
expect_equal(inputList$inputs$output_1_x$revDeps, c("output_1_y", "output_1_z"))
expect_equal(inputList$inputs$output_1_z$displayRevDeps, c("output_1_y"))
})
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(0, 10, 0))
inputs2 <- list(x = mwSlider(0, 10, 6), y = mwSlider(0, 10, 1))
inputs <- c(
filterAndInitInputs(list(shared = mwText("test")), c(), TRUE,
initEnv(parent.frame(), 0)),
filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1)),
filterAndInitInputs(inputs2, c(), TRUE, initEnv(parent.frame(), 2))
)
inputList <- InputList(inputs)$init()
it ("gets and updates an input by name and chartId", {
# Get Input
# Individual inputs
expect_equal(inputList$getInput("x", 1)$value, 5)
expect_equal(inputList$getInput("x", 2)$value, 6)
# Shared inputs
expect_equal(inputList$getInput("shared", 1)$value, "test")
expect_equal(inputList$getInput("shared", 2)$value, "test")
# Get input value
# Individual inputs
expect_equal(inputList$getValue("x", 1), 5)
expect_equal(inputList$getValue("x", 2), 6)
# Shared inputs
expect_equal(inputList$getValue("shared", 1), "test")
expect_equal(inputList$getValue("shared", 2), "test")
# Update input value
# Individual inputs
expect_equal(inputList$setValue("x", 4, 1), 4)
expect_equal(inputList$setValue("x", 5, 2), 5)
expect_equal(inputList$getValue("x", 1), 4)
expect_equal(inputList$getValue("x", 2), 5)
# Shared inputs
expect_equal(inputList$setValue("shared", "test1", 1), "test1")
expect_equal(inputList$getValue("shared", 1), "test1")
expect_equal(inputList$setValue("shared", "test2", 1), "test2")
expect_equal(inputList$getValue("shared", 2), "test2")
it ("gets all values for one chart", {
for (i in 1:2) {
values <- inputList$getValues(i)
expect_is(values, "list")
expect_named(values, c("shared", "x", "y"), ignore.order = TRUE)
for (n in c("shared", "x", "y")) {
expect_equal(values[[n]], inputList$getValue(n, i))
}
}
})
it ("indicates if an input is shared or not", {
expect_true(inputList$isShared("shared"))
expect_true(! inputList$isShared("x"))
expect_true(! inputList$isShared("y"))
})
it ("does not modify values until it is initialized", {
inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
inputList <- InputList(inputs)
expect_equal(inputList$inputs$output_1_y$value, 0)
inputList$setValue(inputId = "output_1_x", value = 7)
expect_equal(inputList$inputs$output_1_y$value, 0)
inputList$init()
expect_equal(inputList$inputs$output_1_y$value, 7)
inputList$setValue(inputId = "output_1_x", value = 8)
expect_equal(inputList$inputs$output_1_y$value, 8)
})
})
})
manipulateWidget/tests/testthat/test-init_inputs.R 0000644 0001762 0000144 00000004470 13216502327 022232 0 ustar ligges users context("initInputs")
# Helper function that checks the structure of the object returned by initInputs.
# It returns the said object for further testing
test_structure <- function(inputs, compare = NULL, ncharts = 1) {
res <- initInputs(inputs, compare = compare, ncharts = ncharts)
inputList <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
inputList <- flattenInputs(inputList)
expect_is(res, "list")
expect_named(res, c("envs", "inputs", "inputList", "ncharts"))
expect_is(res$envs, "list")
expect_named(res$envs, c("shared", "ind"))
expect_is(res$envs$ind, "list")
expect_length(res$envs$ind, ncharts)
expect_is(res$inputs, "list")
expect_named(res$inputs, c("shared", "ind"))
expect_is(res$inputs$ind, "list")
expect_length(res$inputs$ind, ncharts)
expect_is(res$inputList, "InputList")
expectedLength <- length(inputList) + length(compare) * (ncharts - 1)
# inexact when one tries to compare grouped inputs
expect_length(res$inputList$inputs, expectedLength)
sharedInputs <- setdiff(names(inputList), names(compare))
expected_names <- paste0("shared_", sharedInputs)
if (length(compare) > 0) {
for (i in seq_len(ncharts)) {
expected_names <- append(
expected_names,
paste0("output_", i, "_", names(compare))
)
}
}
expect_true(all(expected_names %in% names(res$inputList$inputs)))
res
}
describe("initInputs", {
it("generates correct structure", {
test_structure(list(a = mwText(), b = mwText()))
})
it("handles grouped inputs", {
test_structure(list(grp = mwGroup(a = mwText(), b = mwText())))
})
it("still works if ncharts > 1", {
test_structure(list(grp = mwGroup(a = mwText(), b = mwText())), ncharts = 2)
})
it("prepares inputs for comparison", {
test_structure(list(a = mwText(), b = mwText()), ncharts = 2,
compare = list(a = NULL))
})
it("prepares inputs for comparison with different initial values", {
res <- test_structure(list(a = mwText(), b = mwText()), ncharts = 2,
compare = list(a = c("a", "b")))
})
it("throws errors if inputs are not inputs or not named", {
expect_error(initInputs(list(mwText())), "All arguments need to be named.")
expect_error(initInputs(list(a = 1)), "All arguments need to be Input objects.")
})
})
manipulateWidget/tests/testthat/test-manipulate_widget.R 0000644 0001762 0000144 00000007517 13216502327 023374 0 ustar ligges users context("manipulateWidget")
describe("manipulateWidget", {
it("returns an uninitialized MWController in a non interactive situation", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = "a", .runApp = FALSE
)
expect_true(!c$initialized)
})
it("creates two charts when .compare is a character vector", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = "a", .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 2)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "a")
})
it("creates two charts when .compare is a named list with null values", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = list(a = NULL), .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 2)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "a")
})
it("sets different values when .compare is a named list with non null values", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = list(a = list("a", "b")), .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 2)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "b")
expect_equal(c$charts[[1]]$widgets[[1]], "a test")
expect_equal(c$charts[[2]]$widgets[[1]], "b test")
})
it ("creates more than two charts", {
c <- manipulateWidget(
paste(a, b),
a = mwSelect(c("a", "b", "c")),
b = mwText("test"),
.compare = list(a = list("a", "b", "c")),
.compareOpts = compareOptions(ncharts = 3), .runApp = FALSE
)
c$init()
expect_equal(c$ncharts, 3)
expect_equal(c$getValue("a", 1), "a")
expect_equal(c$getValue("a", 2), "b")
expect_equal(c$getValue("a", 2), "b")
expect_equal(c$charts[[1]]$widgets[[1]], "a test")
expect_equal(c$charts[[2]]$widgets[[1]], "b test")
expect_equal(c$charts[[3]]$widgets[[1]], "c test")
})
it ("updates dynamic inputs", {
c <- manipulateWidget(
x + y,
x = mwSlider(0, 10, 5),
y = mwSlider(0, x, 4), .runApp = FALSE
)
c$init()
expect_equal(c$getParams("y")$max, 5)
c$setValue("x", 3)
expect_equal(c$getParams("y")$max, 3)
expect_equal(c$getValue("y"), 3)
})
it ("conditionally shows/hides inputs", {
c <- manipulateWidget(
x + y,
x = mwSlider(0, 10, 0),
y = mwSlider(0, 10, 0, .display = x < 5), .runApp = FALSE
)
c$init()
expect_true(c$isVisible("y"))
c$setValue("x", 6)
expect_true(!c$isVisible("y"))
})
it ("shares values between inputs and outputs", {
c <- manipulateWidget(
x2 + y,
x = mwSlider(0, 10, 5),
x2 = mwSharedValue(x * 2),
y = mwSlider(0, x2, 0), .runApp = FALSE
)
c$init()
expect_equal(c$getParams("y")$max, 10)
expect_equal(c$charts[[1]]$widgets[[1]], 10)
c$setValue("x", 8)
expect_equal(c$getValue("x2"), 16)
expect_equal(c$getParams("y")$max, 16)
expect_equal(c$charts[[1]]$widgets[[1]], 16)
})
it ("modifies a sharedInput when it is not dynamic", {
c <- manipulateWidget(
x2 + y,
x = mwSlider(0, 10, 5),
x2 = mwSharedValue(1),
x3 = mwSharedValue(x + x2),
y = mwSlider(0, x2, 0), .runApp = FALSE
)
c$init()
expect_equal(c$getParams("y")$max, 1)
expect_equal(c$charts[[1]]$widgets[[1]], 1)
c$setValue("x2", 8)
expect_equal(c$getValue("x2"), 8)
expect_equal(c$getValue("x3"), 13)
expect_equal(c$getParams("y")$max, 8)
expect_equal(c$charts[[1]]$widgets[[1]], 8)
c$setValue("x3", 10) # Dynamic shared input. Should not have any effect
expect_equal(c$getValue("x3"), 13)
})
})
manipulateWidget/tests/testthat/helper-input_class.R 0000644 0001762 0000144 00000001750 13216502327 022507 0 ustar ligges users test_input <- function(input, values = NULL, expectedValues = NULL, name = "myInput") {
describe(paste("input", input$type), {
it ("is correctly initialized", {
env <- initEnv(parent.frame(), 1)
input$init(name, env)
expect_initialized(input)
expect_equal(input$env, env)
expect_equal(input$label, name)
if(!"call" %in% class(input$value)){
expect_equal(input$value, get(name, envir = env))
} else {
expect_equal(evalValue(input$value, parent.frame()), get(name, envir = env))
}
expect_is(input$params, "list")
})
it ("sets valid values", {
for (i in seq_along(values)) {
input$setValue(values[[i]])
expect_equal(input$value, expectedValues[[i]])
expect_equal(get(name, envir = input$env), expectedValues[[i]])
}
})
})
}
expect_initialized <- function(input) {
expect_is(input, "Input")
expect(!emptyField(input$name) & !emptyField(input$env), "Input unitialized")
}
manipulateWidget/tests/testthat/test-mwModuleUI.R 0000644 0001762 0000144 00000001244 13216502327 021710 0 ustar ligges users context("mwModuleUI function")
describe("mwModuleUI function", {
it("Correct mwModuleUI", {
# missing id
expect_error(mwModuleUI())
# default
def_mw_ui <- mwModuleUI(id = "def")
expect_is(def_mw_ui, "shiny.tag.list")
expect_equal(def_mw_ui[[2]]$name, "div")
expect_equal(def_mw_ui[[2]]$attribs$id, "def-ui")
expect_true(grepl("border", def_mw_ui[[2]]$attribs$class))
# parameters
def_mw_ui <- mwModuleUI(id = "def", border = FALSE)
expect_false(grepl("border", def_mw_ui[[2]]$attribs$class))
def_mw_ui <- mwModuleUI(id = "def", height = "100%")
expect_true(grepl("height:100%", def_mw_ui[[2]]$attribs$style))
})
})
manipulateWidget/tests/testthat/test-input_class.R 0000644 0001762 0000144 00000002103 13216502327 022200 0 ustar ligges users context("Input class")
describe("Input", {
inputTPL <- Input(
type = "test",
value = 0,
params = list(
min = expression(0),
max = expression(10)
),
display = expression(TRUE),
validFunc = function(x, params) {
min(max(params$min, x), params$max)
},
htmlFunc = htmlFuncFactory(shiny::numericInput)
)
# Basic check
test_input(inputTPL$copy(), c(5, -20, 20), c(5, 0, 10))
it("correctly updates value when environment changes", {
myInput <- inputTPL$copy()
myInput$params$min <- expression(minx)
env <- initEnv(parent.frame(), 1)
assign("minx", 0, envir = env)
myInput$init("x", env)
expect_equal(myInput$value, 0)
assign("minx", 5, envir = env)
expect_equal(myInput$updateValue(), 5)
expect_equal(myInput$value, 5)
expect_equal(get("x", envir = env), 5)
})
it("returns a valid ID (in a JS point of view)", {
myInput <- inputTPL$copy()
env <- initEnv(parent.frame(), 1)
myInput$init("invalid.name", env)
expect_equal(myInput$getID(), "output_1_invalid_name")
})
})
manipulateWidget/tests/testthat/test-controller.R 0000644 0001762 0000144 00000007563 13243026421 022052 0 ustar ligges users context("MWController class")
describe("MWController", {
it("can be created with the result of initInputs()", {
inputs <- initInputs(list(a = mwText("a"), b = mwText("b")))
expr <- expression(paste(a, b))
controller <- MWController(expr, inputs)$init()
controller$updateCharts()
expect_is(controller$charts, "list")
expect_length(controller$charts, 1)
expect_equal(controller$charts[[1]]$widgets[[1]], "a b")
})
it("creates multiple charts in comparison mode", {
inputs <- initInputs(list(a = mwText("a"), b = mwText("b")), compare = "b",
ncharts = 3)
expr <- expression(paste(a, b))
controller <- MWController(expr, inputs)$init()
controller$updateCharts()
expect_is(controller$charts, "list")
expect_length(controller$charts, 3)
for (o in controller$charts) expect_equal(o$widgets[[1]], "a b")
})
it ("does not update charts if values do not change", {
inputs <- initInputs(list(a = mwText("a"), b = mwText("b")))
expr <- expression(print("chart updated"))
expect_output(controller <- MWController(expr, inputs)$init(), "chart updated")
expect_output(controller$updateCharts(), "chart updated")
# Update a with different value
expect_output(controller$setValue("a", "b"), "chart updated")
# Update a with same value
expect_silent(controller$setValue("a", "b"))
})
it("creates a copy that is completely autonomous", {
inputs <- initInputs(list(a = mwText("a"), b = mwText("b")))
expr <- expression(paste(a, b))
controller1 <- MWController(expr, inputs)$init()
controller2 <- controller1$clone()
controller1$setValue("a", "test")
expect_equal(controller1$getValue("a"), "test")
expect_equal(controller2$getValue("a"), "a")
expect_true(controller2$initialized)
expect_true(controller2$inputList$initialized)
})
it("accesses parameters of a given input", {
inputs <- initInputs(list(a = mwSelect(c("a", "b", "c")), b = mwText("b")))
expr <- expression(paste(a, b))
controller <- MWController(expr, inputs)$init()
expect_equal(controller$getParams("a")$choices, c("a", "b", "c"))
})
it("generates server and ui functions", {
inputs <- initInputs(list(a = mwSelect(c("a", "b", "c")), b = mwText("b")))
expr <- expression(paste(a, b))
controller <- MWController(expr, inputs)$init()
ui <- controller$getModuleUI()
server <- controller$getModuleServer()
expect_is(ui, "function")
expect_is(server, "function")
expect_true(all(c("input", "output", "session", "...") %in% names(formals(server))))
})
it("does not update values or create charts until it is initialized", {
inputs <- initInputs(list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)))
expr <- expression(paste(x, y))
controller <- MWController(expr, inputs)
expect_length(controller$charts, 0)
expect_equal(controller$getValue("y"), 0)
controller$setValue("x", 3)
expect_length(controller$charts, 0)
expect_equal(controller$getValue("y"), 0)
controller$init()
expect_length(controller$charts, 1)
expect_equal(controller$charts[[1]]$widgets[[1]], "3 3")
expect_equal(controller$getValue("y"), 3)
})
})
describe("summary.MWController", {
it("prints information about controller", {
controller <- manipulateWidget(
d$value,
a = mwSelect(c("a", "b", "c")),
b = mwSelect(c("a", "b", "c"), "b"),
c = mwSelect(c("a", "b", "c"), c("a", "b"), multiple = TRUE),
d = mwSharedValue(data.frame(value = 1)),
.runApp = FALSE
)
expect_output(summary(controller), "List of inputs")
# Indicates NULL values
expect_output(summary(controller), "NULL")
# paste values if multiple values
expect_output(summary(controller), "a, b")
# for complicated objects, indicates the class of object
controller$init()
expect_output(summary(controller), "data.frame")
})
})
manipulateWidget/NAMESPACE 0000644 0001762 0000144 00000002501 13243026421 014767 0 ustar ligges users # Generated by roxygen2: do not edit by hand
S3method(summary,MWController)
export(combineWidgets)
export(combineWidgetsOutput)
export(compareOptions)
export(knit_print.MWController)
export(manipulateWidget)
export(mwCheckbox)
export(mwCheckboxGroup)
export(mwDate)
export(mwDateRange)
export(mwGroup)
export(mwModule)
export(mwModuleUI)
export(mwNumeric)
export(mwPassword)
export(mwRadio)
export(mwSelect)
export(mwSelectize)
export(mwSharedValue)
export(mwSlider)
export(mwText)
export(renderCombineWidgets)
export(staticImage)
export(staticPlot)
exportClasses(MWController)
importFrom(grDevices,dev.off)
importFrom(grDevices,png)
importFrom(htmltools,tagGetAttribute)
importFrom(htmlwidgets,getDependency)
importFrom(methods,is)
importFrom(methods,new)
importFrom(methods,setRefClass)
importFrom(miniUI,gadgetTitleBar)
importFrom(miniUI,miniContentPanel)
importFrom(miniUI,miniPage)
importFrom(miniUI,miniTabPanel)
importFrom(miniUI,miniTabstripPanel)
importFrom(shiny,fillPage)
importFrom(shiny,fillRow)
importFrom(shiny,icon)
importFrom(shiny,isolate)
importFrom(shiny,observe)
importFrom(shiny,observeEvent)
importFrom(shiny,reactive)
importFrom(shiny,tagAppendChild)
importFrom(shiny,tagAppendChildren)
importFrom(shiny,tags)
importFrom(stats,runif)
importFrom(utils,getFromNamespace)
manipulateWidget/NEWS.md 0000644 0001762 0000144 00000014121 13256125542 014657 0 ustar ligges users
# manipulateWidget 0.9.0 (2018-01-29)
## New features
* Can add a label to `mwGroup`
* new ``mwSelectize`` input
* add ``.showCompare``
## Bugfixes
* Loss of scrollbar using `shiny` with `fluidPage` and `manipulateWidget`
* Fix Handle shiny tag objects with HTML dependencies
* Preserve the class of widgets that are passed to combineWidgets
# manipulateWidget 0.8.0 (2017-11-27)
## New features
* `manipulateWidget()` has a new parameter `.updateBtnInit`. In case of update button `.updateBtn`, you can decide to render graphics on init or not.
* UI has now a button to save the current chart in an HTML file (thanks to Benoit Thieurmel).`manipulateWidget`gains a new parameter ".saveBtn" to show or hide this button.
* `manipulateWidget()` has a new parameter ".runApp". If it is false, then the function returns an object of class `MWController` that can be modified using command line instructions. This is useful to write tests for UIs created with `manipulateWidget()`.
* `manipulateWidget` interfaces can now be included in shiny applications thanks to the two new functions `mwModule()` and `mwModuleUI()`.
* A new virtual input called `mwSharedValue` has been introduced. It can be used to avoid repeating the same computations when inputs and output use a common intermediary value. It can also be used when
`manipulateWidget()` is used in a shiny application to send data from the main application to the module.
* `manipulateWidget()` now only updates the dependant inputs and outputs when user changes the value of an input. This can lead to important performance improvement in complicated applications.
* `mwModule()` now return `controller` value, with possibility to use new `clear()` method
* add `header`, `footer` and `fluidRow` arguments to `mwModuleUI()`
## Bugfixes
* When a UI contained dynamic inputs, output was sometimes updated before inputs, which could lead to some errors.
* Opening the same application in two browsers (or tabs) resulted in strange results.
# manipulateWidget 0.7.0 (2017-06-08)
## Breaking changes
* `manipulateWidget()` has lost all arguments that were used to customize the UI. Parameters `.controlPos`, `.tabColumns` and `.compareLayout` do not exist anymore.
## New features
* `manipulateWidget()` now creates a more compact and elegant user interface.
* It is now possible to compare more than two charts. `manipulateWidget()` has a new argument `.compareOpts` to control the number of charts and their position.
* Argument `.compare` of `manipulateWidget` can now be a character vector.
# manipulateWidget 0.6.0 (2017-05-24)
## Breaking changes
* `manipulateWidget()` now has a simpler API to show, hide and update inputs dynamically. Parameters `.display` and `.updateInputs` have been removed.
* Functions `mwUI()` and `mwControlsUI()` have been removed.
## New Features
* `manipulateWidget()` gains a new parameter `.return` to modify the object returned by the function.
* `manipulateWidget()` has two new arguments `.width` and `.height` to control size of the UI in Rmarkdown documents with option `runtime: shiny`
* New function `mwGroup` can be used to create groups of input.
## Bug fixes
* Select inputs have had a buggy behavior in some settings.
* Labels of inputs were incorrect in comparison mode.
# manipulateWidget 0.5.1 (2017-01-23)
## New Features
* Variable `.id` is now available when evaluating the initial properties of the input controls. This can be useful in comparison mode, for instance to set different choices for a select input.
## Bug fixes
* Fixed a scope problem occuring when manipulateWidget was used inside a function and parameter `.updateInputs` was used.
* Fixed a crash that could occur when parameters `.compare` and `.updateInputs` were used together.
# manipulateWidget 0.5.0 (2017-01-18)
## New Features
* `manipulateWidget()` can now be used in a R Markdown document with shiny runtime. Input controls are included in the final document so end users can play with their values directly. (contribution by JJ. Allaire)
* `manipulateWidget()` has two new arguments `.compare` and `.compareLayout` to create a comparison interface. When `.compare` is set, two charts are outputed with some common and some individual input controls (see vignette).
* Now, input controls generated by `manipulateWidget()` can be dynamically updated thanks to the new argument ".updateInputs".
* New functions `staticImage()` and `staticPlot()` to include in a combine widget a static image or a static plot created with base functions, ggplot2, etc.
* In `combinedWidgets`objects, individual widgets are stored in a property called `widgets`, so users can now access them and modify them.
# manipulateWidget 0.4 (2016-12-16)
## Breaking changes
* Function `combineWidgets()` has been entirely rewritten and now produces a htmlwidget that can be included as is in documents or shiny applications. The general behavior is the same, but some parameters have changed.
## New features
* `manipulateWidget()` can now update an already rendered widget instead of overwriting it each time the user changes an input. This leads to better performance and user experience. Look at the documentation of manipulateWidget for further information.
## Bug fixes
* `manipulateWidget()` now preserves the order of the initial value of select inputs.
* `manipulateWidget()` now automatically finds the correct render and output functions. This solves in particular sizing problems.
# manipulateWidget 0.3 (2016-10-06)
* add a file LICENSE and copyright to sources files
# manipulateWidget 0.2 (2016-09-27)
## New features
* New functions `mwUI()` and `mwControlsUI()` have been added to let the user easily reuse the user interface generated by the package but with different server logic.
* User can now easily create group of inputs in function manipulate widget. In the UI, these inputs are grouped in a panel that can be collapsed/opened by clicking on its name.
## Bug fixes
* Many useless but worrying warning messages have been removed.
manipulateWidget/R/ 0000755 0001762 0000144 00000000000 13256176767 014002 5 ustar ligges users manipulateWidget/R/inputs.R 0000644 0001762 0000144 00000054573 13256177603 015453 0 ustar ligges users #' Private function that converts ... in a list of expressions. This is
#' similar to "substitute" but for the dots argument.
#' @noRd
dotsToExpr <- function() {
eval(substitute(alist(...), parent.frame()))
}
#' Private function that generates functions that generate HTML corresponding
#' to a shiny input.
#'
#' @param func shiny function that generate the HTML of an input
#' @param valueArgName name of the parameter of 'func' corresponding to the
#' value of the input.
#'
#' @return
#' A function that takes arguments id, label, value, params and returns
#' shiny tag.
#' @noRd
htmlFuncFactory <- function(func, valueArgName = "value") {
function(id, label, value, params, ns = NULL) {
params$inputId <- id
params$label <- label
params[valueArgName] <- list(value)
do.call(func, params)
}
}
changeValueParam <- function(func, valueArgName) {
function(...) {
params <- list(...)
if ("value" %in% names(params)) {
params[[valueArgName]] <- params$value
params$value <- NULL
}
do.call(shiny::updateSelectInput, params)
}
}
#' Add a Slider to a manipulateWidget gadget
#'
#' @param min
#' The minimum value that can be selected.
#' @param max
#' The maximum value that can be selected.
#' @param value
#' Initial value of the slider A numeric vector of length one will create a
#' regular slider; a numeric vector of length two will create a double-ended
#' range slider
#' @param label
#' Display label for the control. If \code{NULL}, the name of the corresponding
#' variable is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{sliderInput}}
#' @param .display expression that evaluates to TRUE or FALSE, indicating when
#' the input control should be shown/hidden.
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#'
#' if (require(plotly)) {
#'
#' myWidget <- manipulateWidget(
#' plot_ly(data.frame(x = 1:n, y = rnorm(n)), x=~x, y=~y, type = "scatter", mode = "markers"),
#' n = mwSlider(1, 100, 10, label = "Number of values")
#' )
#'
#' Sys.sleep(0.5)
#'
#' # Create a double ended slider to choose a range instead of a single value
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' manipulateWidget(
#' plot_ly(mydata[n[1]:n[2], ], x=~x, y=~y, type = "scatter", mode = "markers"),
#' n = mwSlider(1, 100, c(1, 10), label = "Number of values")
#' )
#'
#' }
#'
#' @export
#' @family controls
mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
params$min <- substitute(min)
params$max <- substitute(max)
value <- substitute(value)
Input(
type = "slider", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if (is.null(x) || is.na(x)) return(c(params$min, params$max))
pmin(pmax(params$min, x, na.rm = TRUE), params$max, na.rm = TRUE)
},
htmlFunc = htmlFuncFactory(function(...) {
tags$div(style = "padding:0 5px;", shiny::sliderInput(...))
}),
htmlUpdateFunc = shiny::updateSliderInput
)
}
#' Add a text input to a manipulateWidget gadget
#'
#' @param value
#' Initial value of the text input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{textInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#' manipulateWidget({
#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = "markers") %>%
#' layout(title = mytitle)
#' },
#' mytitle = mwText("Awesome title !")
#' )
#' }
#'
#' @export
#' @family controls
mwText <- function(value = "", label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "text", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if(length(x) == 0) return("")
as.character(x)[1]
},
htmlFunc = htmlFuncFactory(shiny::textInput),
htmlUpdateFunc = shiny::updateTextInput
)
}
#' Add a numeric input to a manipulateWidget gadget
#'
#' @param value
#' Initial value of the numeric input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{numericInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#'
#' if (require(plotly)) {
#' manipulateWidget({
#' plot_ly(data.frame(x = 1:10, y = rnorm(10, mean, sd)), x=~x, y=~y,
#' type = "scatter", mode = "markers")
#' },
#' mean = mwNumeric(0),
#' sd = mwNumeric(1, min = 0, step = 0.1)
#' )
#' }
#'
#' @export
#' @family controls
mwNumeric <- function(value, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "numeric", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if (is.null(x) || !is.numeric(x)) return(NULL)
min(max(params$min, x), params$max)
},
htmlFunc = htmlFuncFactory(shiny::numericInput),
htmlUpdateFunc = shiny::updateNumericInput
)
}
#' Add a password to a manipulateWidget gadget
#'
#' @param value
#' Default value of the input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{passwordInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' manipulateWidget(
#' {
#' if (passwd != 'abc123') {
#' plot_ly(type = "scatter", mode="markers") %>%
#' layout(title = "Wrong password. True password is 'abc123'")
#' } else {
#' plot_ly(data.frame(x = 1:10, y = rnorm(10)), x=~x, y=~y, type = "scatter", mode = "markers")
#' }
#' },
#' user = mwText(label = "Username"),
#' passwd = mwPassword(label = "Password")
#' )
#' }
#'
#' @export
#' @family controls
mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "password", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if(length(x) == 0) return("")
as.character(x)[1]
},
htmlFunc = htmlFuncFactory(shiny::passwordInput),
htmlUpdateFunc = shiny::updateTextInput
)
}
#' Add a Select list input to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Initial value of the input. If not specified, the first choice is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{selectInput}}.
#' @param multiple
#' Is selection of multiple items allowed?
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' manipulateWidget(
#' {
#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
#' },
#' type = mwSelect(c("points", "lines", "both"))
#' )
#'
#' Sys.sleep(0.5)
#'
#' # Select multiple values
#' manipulateWidget(
#' {
#' if (length(species) == 0) mydata <- iris
#' else mydata <- iris[iris$Species %in% species,]
#'
#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~droplevels(Species), type = "scatter", mode = "markers")
#' },
#' species = mwSelect(levels(iris$Species), multiple = TRUE)
#' )
#' }
#'
#' @export
#' @family controls
mwSelect <- function(choices = value, value = NULL, label = NULL, ...,
multiple = FALSE, .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
params$multiple <- substitute(multiple)
value <- substitute(value)
Input(
type = "select", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
x <- intersect(x, unlist(params$choices))
if (params$multiple) return(x)
else if (length(x) > 0) return(x[1])
else return(params$choices[[1]])
},
htmlFunc = htmlFuncFactory(shiny::selectInput, "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateSelectInput, "selected")
)
}
#' Add a Select list input to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Initial value of the input. If not specified, the first choice is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{selectInput}}.
#' @param multiple
#' Is selection of multiple items allowed?
#' @param options
#' A list of options. See the documentation of selectize.js for possible options
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' # Select multiple values
#' manipulateWidget(
#' {
#' if (length(species) == 0) mydata <- iris
#' else mydata <- iris[iris$Species %in% species,]
#'
#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~droplevels(Species), type = "scatter", mode = "markers")
#' },
#' species = mwSelectize(c("Select one or two species : " = "", levels(iris$Species)),
#' multiple = TRUE, options = list(maxItems = 2))
#' )
#' }
#'
#' @export
#' @family controls
mwSelectize <- function(choices = value, value = NULL, label = NULL, ...,
multiple = FALSE, options = NULL, .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
params$multiple <- substitute(multiple)
params$options <- substitute(options)
value <- substitute(value)
Input(
type = "select", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
x <- intersect(x, unlist(params$choices))
if (params$multiple) return(x)
else if (length(x) > 0) return(x[1])
else return(params$choices[[1]])
},
htmlFunc = htmlFuncFactory(shiny::selectizeInput, "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateSelectizeInput, "selected")
)
}
#' Add a checkbox to a manipulateWidget gadget
#'
#' @param value
#' Initial value of the input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{checkboxInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#'
#' if(require(plotly)) {
#' manipulateWidget(
#' {
#' plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~Species, type = "scatter", mode = "markers") %>%
#' layout(showlegend = legend)
#' },
#' legend = mwCheckbox(TRUE, "Show legend")
#' )
#' }
#'
#' @export
#' @family controls
mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "checkbox", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if (is.null(x)) return(FALSE)
x <- as.logical(x)
if (is.na(x)) x <- FALSE
x
},
htmlFunc = htmlFuncFactory(shiny::checkboxInput),
htmlUpdateFunc = shiny::updateCheckboxInput
)
}
#' Add radio buttons to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Initial value of the input. If not specified, the first choice is used.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{radioButtons}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#'
#' manipulateWidget(
#' {
#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
#' },
#' type = mwRadio(c("points", "lines", "both"))
#' )
#' }
#'
#' @export
#' @family controls
mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
value <- substitute(value)
Input(
type = "radio", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if (length(params$choices) == 0) return(NULL)
if (is.null(x) || !x %in% unlist(params$choices)) return(params$choices[[1]])
x
},
htmlFunc = htmlFuncFactory(shiny::radioButtons, valueArgName = "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateRadioButtons, "selected")
)
}
#' Add a date picker to a manipulateWidget gadget
#'
#' @param value
#' Default value of the input.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{dateInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(dygraphs) && require(xts)) {
#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
#'
#' manipulateWidget(
#' dygraph(mydata) %>% dyEvent(date, "Your birthday"),
#' date = mwDate("2017-03-27", label = "Your birthday date",
#' min = "2017-01-01", max = "2017-12-31")
#' )
#' }
#'
#' @export
#' @family controls
mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "date", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if (length(x) == 0) x <- Sys.Date()
x <- as.Date(x)
if (!is.null(params$min)) params$min <- as.Date(params$min)
if (!is.null(params$max)) params$max <- as.Date(params$max)
x <- min(max(x, params$min), params$max)
},
htmlFunc = htmlFuncFactory(shiny::dateInput),
htmlUpdateFunc = shiny::updateDateInput
)
}
#' Add a date range picker to a manipulateWidget gadget
#'
#' @param value
#' Vector containing two dates (either Date objects pr a string in yyy-mm-dd
#' format) representing the initial date range selected.
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{dateRangeInput}}
#' @inheritParams mwSlider
#'
#' @return
#' An Input object
#'
#' @examples
#' if (require(dygraphs) && require(xts)) {
#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
#'
#' manipulateWidget(
#' dygraph(mydata) %>% dyShading(from=period[1], to = period[2], color = "#CCEBD6"),
#' period = mwDateRange(c("2017-03-01", "2017-04-01"),
#' min = "2017-01-01", max = "2017-12-31")
#' )
#' }
#'
#' @export
#' @family controls
mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...,
.display = TRUE) {
params <- dotsToExpr()
value <- substitute(value)
Input(
type = "dateRange", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
if (length(x) == 0) x <- c(Sys.Date(), Sys.Date())
else if (length(x) == 1) x <- c(x, Sys.Date())
x <- as.Date(x)
x[is.na(x)] <- Sys.Date()
if (!is.null(params$min)) {
params$min <- as.Date(params$min)
if(x[1] == Sys.Date()){
x[1] <- params$min
}
}
if (!is.null(params$max)) {
params$max <- as.Date(params$max)
if(x[2] == Sys.Date()){
x[2] <- params$max
}
}
x <- sapply(x, function(d) min(max(d, params$min), params$max))
as.Date(x, origin = "1970-01-01")
},
htmlFunc = function(id, label, value, params, ns) {
params$inputId <- id
params$label <- label
params$start <- value[[1]]
params$end <- value[[2]]
do.call(shiny::dateRangeInput, params)
},
htmlUpdateFunc = function(...) {
params <- list(...)
if ("value" %in% names(params)) {
params$start <- params$value[[1]]
params$end <- params$value[[2]]
params$value <- NULL
}
do.call(shiny::updateDateRangeInput, params)
}
)
}
#' Add a group of checkboxes to a manipulateWidget gadget
#'
#' @param choices
#' Vector or list of choices. If it is named, then the names rather than the
#' values are displayed to the user.
#' @param value
#' Vector containing the values initially selected
#' @param ...
#' Other arguments passed to function\code{\link[shiny]{checkboxGroupInput}}
#' @inheritParams mwSlider
#'
#' @return
#' A function that will generate the input control.
#'
#' @examples
#' if (require(plotly)) {
#' manipulateWidget(
#' {
#' if (length(species) == 0) mydata <- iris
#' else mydata <- iris[iris$Species %in% species,]
#'
#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
#' color = ~droplevels(Species), type = "scatter", mode = "markers")
#' },
#' species = mwCheckboxGroup(levels(iris$Species))
#' )
#' }
#'
#' @export
#' @family controls
mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = TRUE) {
params <- dotsToExpr()
params$choices <- substitute(choices)
value <- substitute(value)
Input(
type = "checkboxGroup", value = value, label = label, params = params,
display = substitute(.display),
validFunc = function(x, params) {
intersect(x, unlist(params$choices))
},
htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected"),
htmlUpdateFunc = changeValueParam(shiny::updateCheckboxGroupInput, "selected")
)
}
#' Shared Value
#'
#' This function creates a virtual input that can be used to store a dynamic
#' shared variable that is accessible in inputs as well as in output.
#'
#' @param expr Expression used to compute the value of the input.
#'
#' @return An Input object of type "sharedValue".
#'
#' @examples
#'
#' if (require(plotly)) {
#' # Plot the characteristics of a car and compare with the average values for
#' # cars with same number of cylinders.
#' # The shared variable 'subsetCars' is used to avoid subsetting multiple times
#' # the data: this value is updated only when input 'cylinders' changes.
#' colMax <- apply(mtcars, 2, max)
#'
#' plotCar <- function(cardata, carName) {
#' carValues <- unlist(cardata[carName, ])
#' carValuesRel <- carValues / colMax
#'
#' avgValues <- round(colMeans(cardata), 2)
#' avgValuesRel <- avgValues / colMax
#'
#' plot_ly() %>%
#' add_bars(x = names(cardata), y = carValuesRel, text = carValues,
#' hoverinfo = c("x+text"), name = carName) %>%
#' add_bars(x = names(cardata), y = avgValuesRel, text = avgValues,
#' hoverinfo = c("x+text"), name = "average") %>%
#' layout(barmode = 'group')
#' }
#'
#' c <- manipulateWidget(
#' plotCar(subsetCars, car),
#' cylinders = mwSelect(c("4", "6", "8")),
#' subsetCars = mwSharedValue(subset(mtcars, cylinders == cyl)),
#' car = mwSelect(choices = row.names(subsetCars))
#' )
#' }
#'
#' @export
#' @family controls
mwSharedValue <- function(expr = NULL) {
params <- list(expr = substitute(expr))
params$dynamic <- is.language(params$expr)
if (!params$dynamic) value <- params$expr
else value <- NULL
Input(
type = "sharedValue", value = value, label = NULL, params = params,
display = FALSE,
validFunc = function(x, params) {
if(params$dynamic) params$expr
else x
}
)
}
#' Group inputs in a collapsible box
#'
#' This function generates a collapsible box containing inputs. It can be useful
#' when there are a lot of inputs and one wants to group them.
#'
#' @param ... inputs that will be grouped in the box
#' @param .display expression that evaluates to TRUE or FALSE, indicating when
#' the group should be shown/hidden.
#' @param label label of the group inputs
#' @return Input of type "group".
#'
#' @examples
#' if(require(dygraphs)) {
#' mydata <- data.frame(x = 1:100, y = rnorm(100))
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2], ],
#' main = title, xlab = xlab, ylab = ylab),
#' range = mwSlider(1, 100, c(1, 100)),
#' "Graphical parameters" = mwGroup(
#' title = mwText("Fictive time series"),
#' xlab = mwText("X axis label"),
#' ylab = mwText("Y axis label")
#' )
#' )
#' }
#'
#' @export
#' @family controls
mwGroup <- function(..., label = NULL, .display = TRUE) {
inputs <- list(...)
if (is.null(names(inputs))) stop("All arguments need to be named.")
for (i in inputs) if (!inherits(i, "Input")) stop("All arguments need to be Input objects.")
Input(
type = "group", value = list(...), params = list(),
label = label, display = substitute(.display),
htmlFunc = function(id, label, value, params, ns) {
htmlElements <- lapply(value, function(x) x$getHTML(ns))
tags$div(
class="panel panel-default",
tags$div(
class="panel-heading collapsed",
style = "cursor: pointer;",
"data-toggle"="collapse",
"data-target"=paste0("#panel-body-", id),
tags$table(
tags$tbody(
tags$tr(
tags$td(class = "arrow"),
tags$td(label)
)
)
)
),
tags$div(
class="panel-body collapse",
id=paste0("panel-body-", id),
shiny::tagList(htmlElements)
)
)
}
)
}
manipulateWidget/R/debug.R 0000644 0001762 0000144 00000000425 13216502327 015171 0 ustar ligges users mwDebug <- function() {
options(mwDebug = TRUE)
}
mwUndebug <- function() {
options(mwDebug = FALSE)
}
mwDebugMode <- function() {
res <- getOption("mwDebug")
if (is.null(res)) res <- FALSE
res
}
catIfDebug <- function(...) {
if (mwDebugMode()) cat(..., "\n")
}
manipulateWidget/R/input_utils.R 0000644 0001762 0000144 00000004127 13216502327 016465 0 ustar ligges users #' Private function that creates a filtered list of initialised inputs.
#'
#' @param inputs list of uninitialized inputs
#' @param names names of inputs to keep or drop
#' @param drop should inputs that appear in argument "names" be dropped or keepped?
#' @param env environment used to initilize parameters
#'
#' @return a list of inputs
#' @noRd
filterAndInitInputs <- function(inputs, names, drop = FALSE,
env = parent.frame(), newValues = list()) {
res <- list()
for (n in names(inputs)) {
i <- inputs[[n]]$copy()
if (n %in% names(newValues)) i$value <- newValues[[n]]
if (inputs[[n]]$type == "group") {
if (drop) {
if (n %in% names) next # Remove the whole group
else {
i$value <- filterAndInitInputs(inputs[[n]]$value, names, drop, env)
if (length(i$value) == 0) next
}
} else {
if (n %in% names) {
# Keep the whole group
i$value <- filterAndInitInputs(inputs[[n]]$value, names(i$value), drop, env)
} else {
i$value <- filterAndInitInputs(inputs[[n]]$value, names, drop, env)
if (length(i$value) == 0) next
}
}
} else {
if (!drop && ! n %in% names) next
if (drop && n %in% names) next
}
i$init(n, env)
res[[n]] <- i
}
res
}
#' Private function that flattens a list of inputs
#'
#' @param inputs list of initialized inputs
#'
#' @return
#' List of initialized inputs. The difference with the input is that
#' inputs that belong to groups are placed in top of the list, so it is easier
#' to iterate over all the inputs. Specifically, the result of this function
#' can be used to create in InputList object.
#' @noRd
flattenInputs <- function(inputs) {
res <- list()
if (is.null(names(inputs))) names(inputs) <- as.character(seq_along(inputs))
for (n in names(inputs)) {
if (is.list(inputs[[n]])) {
res <- append(res, flattenInputs(inputs[[n]]))
next
}
if (inputs[[n]]$type == "group") {
res <- append(res, flattenInputs(inputs[[n]]$value))
}
res[[n]] <- inputs[[n]]
}
res
}
manipulateWidget/R/compare_options.R 0000644 0001762 0000144 00000003156 13216502327 017310 0 ustar ligges users #' Options for comparison mode
#'
#' This function generates a list of options that are used by
#' \code{\link{manipulateWidget}} to compare multiple charts.
#'
#' @param ncharts Number of charts to generate.
#' @param nrow Number of rows. If \code{NULL}, the function tries to pick the
#' best number of rows given the number of charts and columns.
#' @param ncol Number of columns. If \code{NULL}, the function tries to pick the
#' best number of columns given the number of charts and rows.
#'
#' @return List of options
#'
#' @examples
#' if (require(dygraphs)) {
#'
#' mydata <- data.frame(
#' year = 2000+1:100,
#' series1 = rnorm(100),
#' series2 = rnorm(100),
#' series3 = rnorm(100)
#' )
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' series = mwSelect(c("series1", "series2", "series3")),
#' title = mwText("Fictive time series"),
#' .compare = list(title = NULL, series = NULL),
#' .compareOpts = compareOptions(ncharts = 4)
#' )
#'
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' series = mwSelect(c("series1", "series2", "series3")),
#' title = mwText("Fictive time series"),
#' .compare = list(title = NULL, series = NULL),
#' .compareOpts = compareOptions(ncharts = 3, nrow = 3)
#' )
#' }
#'
#' @export
compareOptions <- function(ncharts = NULL, nrow = NULL, ncol = NULL) {
list(
ncharts = ncharts,
nrow = nrow,
ncol = ncol
)
}
manipulateWidget/R/controller.R 0000644 0001762 0000144 00000032765 13256125307 016305 0 ustar ligges users #' Controller object of a manipulateWidget application
#'
#' @description
#' \code{MWController} is a reference class that is used to manage interaction
#' with data and update of the view created by manipulateWidget. Only users who
#' desire to create automatic tests for applications created with
#' \code{\link{manipulateWidget}} should care about this object.
#'
#' @section Testing a manipulateWidget application:
#' When \code{\link{manipulateWidget}} is used in a test script, it returns a
#' \code{MWController} object instead of starting a shiny gadget. This object has
#' methods to modify inputs values and check the state of the application. This
#' can be useful to automatically checks if your application behaves like desired.
#' Here is some sample code that uses package \code{testthat}:
#'
#' \preformatted{
#' library("testthat")
#'
#' controller <- manipulateWidget(
#' x + y,
#' x = mwSlider(0, 10, 5),
#' y = mwSlider(0, x, 0),
#' .compare = "y"
#' )
#'
#' test_that("Two charts are created", {
#' expect_equal(controller$ncharts, 2)
#' })
#'
#' test_that("Parameter 'max' of 'y' is updated when 'x' changes", {
#' expect_equal(controller$getParams("y", 1)$max, 5)
#' expect_equal(controller$getParams("y", 2)$max, 5)
#' controller$setValue("x", 3)
#' expect_equal(controller$getParams("y", 1)$max, 3)
#' expect_equal(controller$getParams("y", 2)$max, 3)
#' })
#'
#' }
#'
#' @field ncharts Number of charts in the application
#' @field nrow Number of rows.
#' @field ncol Number of columns.
#' @field autoUpdate Boolean indicating if charts should be automatically
#' updated when a value changes. list with \code{value} and \code{initBtn} (not autoUpdate, if want first charts on init)
#'
#' @export
MWController <- setRefClass(
"MWController",
fields = c("inputList", "uiSpec", "envs", "session", "shinyOutput", "expr", "ncharts", "charts",
"autoUpdate", "renderFunc", "outputFunc", "useCombineWidgets", "nrow", "ncol",
"returnFunc", "initialized"),
methods = list(
initialize = function(expr, inputs, autoUpdate = list(value = TRUE, initBtn = FALSE, showCompare = TRUE), nrow = NULL,
ncol = NULL, returnFunc = function(widget, envs) {widget}) {
expr <<- expr
inputList <<- inputs$inputList
uiSpec <<- inputs
ncharts <<- inputs$ncharts
envs <<- inputs$envs
autoUpdate <<- autoUpdate
outputFunc <<- NULL
renderFunc <<- NULL
session <<- NULL
shinyOutput <<- NULL
useCombineWidgets <<- FALSE
nrow <<- nrow
ncol <<- ncol
returnFunc <<- returnFunc
charts <<- list()
initialized <<- FALSE
},
init = function() {
catIfDebug("Controller initialization")
if (!initialized) {
inputList$init()
updateCharts()
if (is.null(renderFunc) || is.null(outputFunc) || is.null(useCombineWidgets)) {
outputAndRender <- getOutputAndRenderFunc(charts[[1]])
renderFunc <<- outputAndRender$renderFunc
outputFunc <<- outputAndRender$outputFunc
useCombineWidgets <<- outputAndRender$useCombineWidgets
if (useCombineWidgets) {
charts <<- lapply(charts, combineWidgets)
}
}
initialized <<- TRUE
}
invisible(.self)
},
clear = function(){
rm(list = ls(envir = .self, all.names = TRUE), envir = .self, inherits = TRUE)
},
setShinySession = function(output, session) {
catIfDebug("Set shiny session")
session <<- session
shinyOutput <<- output
inputList$session <<- session
for (env in envs$ind) {
assign(".initial", FALSE, envir = env)
assign(".session", session, envir = env)
}
# also on shared env
assign(".initial", FALSE, envir = envs$shared)
assign(".session", session, envir = envs$shared)
},
getValue = function(name, chartId = 1) {
"Get the value of a variable for a given chart."
inputList$getValue(name, chartId)
},
getValueById = function(id) {
inputList$getValue(inputId = id)
},
setValue = function(name, value, chartId = 1, reactive = FALSE) {
"Update the value of a variable for a given chart."
oldValue <- getValue(name, chartId)
newValue <- inputList$setValue(name, value, chartId, reactive = reactive)
if (!initialized) return()
if (autoUpdate$value && !identical(oldValue, newValue)) {
if (inputList$isShared(name)) updateCharts()
else updateChart(chartId)
}
},
setValueById = function(id, value) {
oldValue <- getValueById(id)
newValue <- inputList$setValue(inputId = id, value = value)
if (!initialized) return()
if (autoUpdate$value && !identical(oldValue, newValue)) {
if (grepl("^shared_", id)) updateCharts()
else {
chartId <- get(".id", envir = inputList$inputs[[id]]$env)
updateChart(chartId)
}
}
},
getValues = function(chartId = 1) {
"Get all values for a given chart."
inputList$getValues(chartId)
},
getParams = function(name, chartId = 1) {
"Get parameters of an input for a given chart"
inputList$getInput(name, chartId)$getParams()
},
isVisible = function(name, chartId = 1) {
"Indicates if a given input is visible"
inputList$isVisible(name, chartId = 1)
},
updateChart = function(chartId = 1) {
catIfDebug("Update chart", chartId)
if(!is.null(envs)){
e <- new.env(parent = envs$ind[[chartId]]) # User can set values in expr without messing environments
charts[[chartId]] <<- eval(expr, envir = e)
if (useCombineWidgets) {
charts[[chartId]] <<- combineWidgets(charts[[chartId]])
}
renderShinyOutput(chartId)
}
},
returnCharts = function() {
"Return all charts."
if (length(charts) == 1) {
finalWidget <- charts[[1]]
} else {
finalWidget <- combineWidgets(list = charts, nrow = nrow, ncol = ncol)
}
returnFunc(finalWidget, envs$ind)
},
show = function() {
if (!initialized) {
message("Nothing to display because controller has not been initialized. Use 'ctrl$init()' where 'ctrl' is the variable created with manipulateWidget()")
}
print(returnCharts())
},
updateCharts = function() {
"Update all charts."
for (i in seq_len(ncharts)) updateChart(i)
},
renderShinyOutput = function(chartId) {
if (!is.null(renderFunc) & !is.null(shinyOutput) &
is(charts[[chartId]], "htmlwidget")) {
catIfDebug("Render shiny output")
outputId <- get(".output", envir = envs$ind[[chartId]])
shinyOutput[[outputId]] <<- renderFunc(charts[[chartId]])
}
},
renderShinyOutputs = function() {
for (i in seq_len(ncharts)) renderShinyOutput(i)
},
clone = function(env = parent.frame()) {
res <- MWController(
expr,
cloneUISpec(uiSpec, session),
autoUpdate
)
res$charts <- charts
res$nrow <- nrow
res$ncol <- ncol
res$outputFunc <- outputFunc
res$renderFunc <- renderFunc
res$useCombineWidgets <- useCombineWidgets
res$initialized <- initialized
res$inputList$initialized <- initialized
res
},
getModuleUI = function(gadget = TRUE, saveBtn = TRUE, addBorder = !gadget) {
function(ns, okBtn = gadget, width = "100%", height = "400px", fillPage = TRUE) {
#ns <- shiny::NS(id)
mwUI(ns, uiSpec, nrow, ncol, outputFunc,
okBtn = okBtn, updateBtn = !autoUpdate$value, saveBtn = saveBtn,
areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder,
width = width, height = height, fillPage = fillPage,
showCompare = autoUpdate$showCompare)
}
},
render = function(output, session, fillPage) {
if (initialized) return()
ns <- session$ns
tryCatch({
init()
setShinySession(output, session)
output$ui <- renderUI(getModuleUI()(ns, height = "100%", fillPage = fillPage))
lapply(inputList$inputs, function(input) {
# Update input visibility
catIfDebug("Update visibility of", input$getID())
shiny::updateCheckboxInput(
session,
paste0(input$getID(), "_visible"),
value = eval(input$display, envir = input$env)
)
# Hack to fix https://github.com/rstudio/shiny/issues/1490
if (input$type == "select" && identical(input$lastParams$multiple, TRUE)) {
input$valueHasChanged <- TRUE
input$updateHTML(session)
}
})
if (autoUpdate$value) renderShinyOutputs()
}, error = function(e) {catIfDebug("Initialization error"); print(e)})
},
getModuleServer = function() {
function(input, output, session, fillPage = TRUE, ...) {
controller <- .self$clone()
reactiveValueList <- list(...)
observe({
for (n in names(reactiveValueList)) {
controller$setValue(n, reactiveValueList[[n]](), reactive = TRUE)
}
controller$render(output, session, fillPage = fillPage)
})
lapply(names(controller$inputList$inputs), function(id) {
if (controller$inputList$inputs[[id]]$type != "sharedValue") {
# When shiny starts, this code is executed but input[[id]] is not defined yet.
# The code is designed to skip this first useless update.
e <- environment()
e$shinyInitialisation <- TRUE
observe({
shinyValue <- input[[id]]
if (e$shinyInitialisation) {
assign("shinyInitialisation", FALSE, envir = e)
} else {
controller$setValueById(id, value = shinyValue)
controller$render(output, session)
}
})
}
})
observeEvent(input$.update, controller$updateCharts(), ignoreNULL = !autoUpdate$initBtn)
observeEvent(input$done, onDone(controller))
output$save <- shiny::downloadHandler(
filename = function() {
paste('mpWidget-', Sys.Date(), '.html', sep='')
},
content = function(con) {
htmlwidgets::saveWidget(widget = onDone(controller, stopApp = FALSE),
file = con, selfcontained = TRUE)
}
)
return(controller)
}
}
)
)
cloneEnv <- function(env, parentEnv = parent.env(env)) {
res <- as.environment(as.list(env, all.names = TRUE))
parent.env(res) <- parentEnv
res
}
cloneUISpec <- function(uiSpec, session) {
newSharedEnv <- cloneEnv(uiSpec$envs$shared)
newEnvs <- lapply(uiSpec$envs$ind, cloneEnv, parentEnv = newSharedEnv)
newInputs <- lapply(seq_along(uiSpec$inputList$inputs), function(i) {
x <- uiSpec$inputList$inputs[[i]]$copy()
chartId <- uiSpec$inputList$chartIds[i]
if (chartId == 0) x$env <- newSharedEnv
else x$env <- newEnvs[[chartId]]
x
})
names(newInputs) <- names(uiSpec$inputList$inputs)
newSpec <- replaceInputs(uiSpec$inputs, newInputs, c(list(newSharedEnv), newEnvs))
list(
envs = list(shared = newSharedEnv, ind = newEnvs),
inputs = newSpec,
inputList = InputList(newInputs, session),
ncharts = uiSpec$ncharts
)
}
replaceInputs <- function(inputs, newInputs, envs) {
lapply(inputs, function(el) {
if (is.list(el)) return(replaceInputs(el, newInputs, envs))
else if (el$type == "group") {
params <- replaceInputs(el$value, newInputs, envs)
params$.display <- el$display
params$label <- el$label
newGroup <- do.call(mwGroup, params)
env <- envs[[1 + get(".id", envir = el$env)]]
newGroup$init(el$name, env)
return(newGroup)
}
else return(newInputs[[el$getID()]])
})
}
#' knit_print method for MWController object
#'
#' @param x MWController object
#' @param ... arguments passed to function knit_print
#'
#' @export
knit_print.MWController <- function(x, ...) {
x$init()
knitr::knit_print(x$returnCharts(), ...)
}
#' summary method for MWController object
#'
#' @param object MWController object
#' @param ... Not use
#'
#' @export
summary.MWController <- function(object, ...) {
cat("Initialized :", object$initialized, "\n")
cat("Number of chart(s) :", object$ncharts, "\n")
cat("Number of row(s) :", object$nrow, "\n")
cat("Number of column(s) :", object$ncol, "\n")
cat("\nList of inputs : \n\n")
infos <- lapply(names(object$inputList$inputs), function(n){
input <- object$inputList$inputs[[n]]
if (is.atomic(input$value)) {
if (is.null(input$value)) value <- "NULL"
else if (length(input$value) == 0) value <- ""
else value <- paste(input$value, collapse = ", ")
} else {
if(is.call(input$value) | is.name(input$value)){
value <- evalValue(input$value, parent.frame())
if (is.null(value)) value <- sprintf("<%s>", class(input$value[1]))
else if (length(value) == 0) value <- ""
else value <- paste(value, collapse = ", ")
} else {
value <- sprintf("<%s>", class(input$value[1]))
}
}
chartId <- as.character(get(".id", envir = input$env))
if (chartId == "0") chartId <- "shared"
visible <- object$inputList$isVisible(inputId = n)
data.frame(inputId = n, type = input$type, variable = input$name,
chart = chartId, value = value, visible = visible,
stringsAsFactors = FALSE)
})
infos$stringsAsFactors <- FALSE
infos <- do.call(rbind, infos)
print(infos)
}
manipulateWidget/R/on_done.R 0000644 0001762 0000144 00000001077 13216502327 015530 0 ustar ligges users #' Function called when user clicks on the "Done" button. It stops the shiny
#' gadget and returns the final htmlwidget
#'
#' @param .expr Expression that generates a htmlwidget
#' @param controls Object created with function preprocessControls
#'
#' @return a htmlwidget
#' @noRd
onDone <- function(controller, stopApp = TRUE) {
for (env in controller$envs$ind) {
assign(".initial", TRUE, envir = env)
assign(".session", NULL, envir = env)
}
controller$updateCharts()
res <- controller$returnCharts()
if (stopApp) shiny::stopApp(res)
else return(res)
}
manipulateWidget/R/mw_ui.R 0000644 0001762 0000144 00000013137 13256125307 015232 0 ustar ligges users #' Private function that generates the general layout of the application
#'
#' @param ns namespace function created with shiny::NS(). Useful to create
#' modules.
#' @param inputs Object returned by preprocessInputs
#' @param ncol Number of columns in the chart area.
#' @param nrow Number of rows in the chart area.
#' @param outputFun Function that generates the html elements that will contain
#' a given widget
#' @param okBtn Should the OK Button be added to the UI ?
#' @param saveBtn Should the Save Button be added to the UI ?
#' @param updateBtn Should the updateBtn be added to the UI ? Currently unused.
#' @param width, height Must be a valid CSS unit (like "100%", "400px", "auto") or a number,
#' which will be coerced to a string and have "px" appended. Default to "100%" & "400px"
#'
#' @return shiny tags
#'
#' @noRd
mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL,
okBtn = TRUE, saveBtn = TRUE, updateBtn = FALSE,
areaBtns = TRUE, border = FALSE, width = "100%", height = "400px",
fillPage = TRUE, showCompare = TRUE) {
htmldep <- htmltools::htmlDependency(
"manipulateWidget",
"0.7.0",
system.file("manipulate_widget", package = "manipulateWidget"),
script = "manipulate_widget.js",
style = "manipulate_widget.css"
)
showSettings <- inputs$ncharts == 1 || length(inputs$inputs$shared) > 0
if (border) class <- "mw-container with-border"
else class <- "mw-container"
if(fillPage){
container <- fillPage(
tags$div(
class = class,
style = paste("width:", width, ";height:", height, ";"),
fillRow(
flex = c(NA, NA, 1),
.uiMenu(ns, inputs$ncharts, nrow, ncol, showSettings, okBtn, saveBtn, updateBtn, areaBtns, showCompare),
.uiInputs(ns, inputs),
.uiChartarea(ns, inputs$ncharts, nrow, ncol, outputFun)
)
)
)
} else {
container <- tags$div(
class = class,
fillRow(
flex = c(NA, NA, 1),
width = width, height = height,
.uiMenu(ns, inputs$ncharts, nrow, ncol, showSettings, okBtn, saveBtn, updateBtn, areaBtns, showCompare),
.uiInputs(ns, inputs),
.uiChartarea(ns, inputs$ncharts, nrow, ncol, outputFun)
)
)
}
htmltools::attachDependencies(container, htmldep, TRUE)
}
.uiInputs <- function(ns, inputs) {
inputs <- c(list(inputs$inputs$shared), inputs$inputs$ind)
ids <- ns(c("mw-shared-inputs", paste0("mw-ind-inputs-", 1:(length(inputs) - 1))))
inputs <- mapply(function(x, id) {
if (length(x) == 0) return(NULL)
content <- lapply(x, function(i) i$getHTML(ns))
tags$div(class = "mw-inputs", id = id, shiny::tagList(content))
}, x = inputs, id = ids, USE.NAMES = FALSE, SIMPLIFY = FALSE)
inputs$class <- "mw-input-container"
do.call(tags$div, inputs)
}
.uiChartarea <- function(ns, ncharts, nrow, ncol, outputFun) {
outputEls <- lapply(seq_len(nrow * ncol), function(i) {
if (i > ncharts) return(tags$div())
outputId <- ns(paste0("output_", i))
if (is.null(outputFun)) {
el <- combineWidgetsOutput(outputId, width = "100%", height = "100%")
} else {
el <- outputFun(outputId, width = "100%", height = "100%")
}
style <- sprintf("float:left;width:%s%%;height:%s%%",
floor(100 / ncol), floor(100 / nrow))
tags$div(class="mw-chart", el, style = style)
})
tags$div(
style = "height:100%;width:100%",
shiny::tagList(outputEls)
)
}
.uiMenu <- function(ns, ncharts, nrow, ncol, settingsBtn, okBtn, saveBtn, updateBtn, areaBtns, showCompare = TRUE) {
container <- tags$div(
class="mw-menu"
)
if (settingsBtn) {
settingsBtn <- tags$div(
class = "mw-btn mw-btn-settings",
onclick = sprintf("select(this, '%s')", ns("mw-shared-inputs")),
tags$div(
class = "bt1",
icon("gears")
),
tags$div(class="right-arrow")
)
container <- tagAppendChild(container, settingsBtn)
}
if ((areaBtns && ncharts > 1) & showCompare){
container <- tagAppendChild(container, .uiChartBtns(ns, ncharts, nrow, ncol))
}
if (updateBtn) {
updateBtn <- tags$div(
class = "mw-btn mw-btn-update",
shiny::actionButton(ns(".update"), "", icon = shiny::icon("refresh"), class = "bt1")
)
container <- tagAppendChild(container, updateBtn)
}
if (okBtn) {
okBtnInput <- shiny::actionButton(ns("done"), "OK", class = "mw-btn mw-btn-ok")
container <- tagAppendChild(container, okBtnInput)
}
if (saveBtn) {
bottom_px <- ifelse(okBtn, "bottom: 80px;", "bottom: 30px;")
saveBtnInput <- shiny::downloadButton(ns("save"), label = "", class = "mw-btn mw-btn-save",
style = bottom_px)
container <- tagAppendChild(container, saveBtnInput)
}
container
}
.uiChartBtns <- function(ns, ncharts, nrow, ncol) {
ids <- ns(paste0("mw-ind-inputs-", seq_len(ncharts)))
btns <- lapply(seq_len(ncharts), function(i) {
tags$div(
class = "mw-btn mw-btn-area",
onclick = sprintf("select(this,'%s')", ids[i]),
.uiChartIcon(i, nrow, ncol),
tags$div(class="right-arrow")
)
})
btns$class <- "mw-chart-selection"
do.call(tags$div, btns)
}
.uiChartIcon <- function(i, nrow, ncol) {
WIDTH <- 42
HEIGHT <- 28
PAD <- 2
i <- i - 1
w <- (WIDTH - 2 * PAD) / ncol
h <- (HEIGHT - 2 * PAD) / nrow
chartIconStyle <- sprintf("width:%spx;height:%spx;left:%spx;top:%spx;",
w, h, w * (i%%ncol) + PAD, h * (i %/% ncol) + PAD)
tags$div(
class = "mw-icon-areachart",
tags$div(class="mw-icon-chart", style=chartIconStyle)
)
}
manipulateWidget/R/input_list_class.R 0000644 0001762 0000144 00000010213 13216502327 017456 0 ustar ligges users extractVarsFromExpr <- function(expr) {
f <- function() {}
body(f) <- expr
codetools::findGlobals(f, merge = FALSE)$variables
}
# Private reference class used to update value and params of a set of inputs
# when the value of an input changes.
InputList <- setRefClass(
"InputList",
fields = c("inputs", "session", "names", "chartIds", "initialized"),
methods = list(
initialize = function(inputs, session = NULL) {
"args:
- inputs: list of initialized inputs
- session: shiny session"
inputList <- flattenInputs(unname(inputs))
inputs <<- inputList
names(inputs) <<- sapply(inputList, function(x) {x$getID()})
names <<- sapply(inputList, function(x) x$name)
chartIds <<- sapply(inputList, function(x) get(".id", envir = x$env))
session <<- session
initialized <<- FALSE
# Set dependencies
for (input in inputList) {
inputId <- input$getID()
deps <- getDeps(input)
for (d in deps$params) {
inputs[[d]]$revDeps <<- union(.self$inputs[[d]]$revDeps, inputId)
}
for (d in deps$display) {
inputs[[d]]$displayRevDeps <<- union(.self$inputs[[d]]$displayRevDeps, inputId)
}
}
},
init = function() {
if (!initialized) {
update(forceDeps = TRUE)
initialized <<- TRUE
}
return(.self)
},
isShared = function(name) {
idx <- which(names == name)
if (length(idx) == 0) stop("cannot find input ", name)
any(chartIds[idx] == 0)
},
isVisible = function(name, chartId = 1, inputId = NULL) {
i <- getInput(name, chartId, inputId)
eval(i$display, envir = i$env)
},
updateHTMLVisibility = function(name, chartId = 1, inputId = NULL) {
if (!is.null(session)) {
input <- getInput(name, chartId, inputId)
catIfDebug("Update visibility of", input$getID())
shiny::updateCheckboxInput(
session,
paste0(input$getID(), "_visible"),
value = eval(input$display, envir = input$env)
)
}
},
getDeps = function(input) {
deps <- lapply(input$params, extractVarsFromExpr)
deps <- do.call(c, deps)
displayDeps <- extractVarsFromExpr(input$display)
list(
params = names(inputs)[names %in% deps],
display = names(inputs)[names %in% displayDeps]
)
},
getInput = function(name, chartId = 1, inputId = NULL) {
if (!is.null(inputId)) {
if (!inputId %in% names(inputs)) stop("cannot find input with id", inputId)
return(inputs[[inputId]])
}
idx <- which(names == name & chartIds %in% c(0, chartId))
if (length(idx) == 0) stop("cannot find input with name", name)
inputs[[idx]]
},
getValue = function(name, chartId = 1, inputId = NULL) {
getInput(name, chartId, inputId)$value
},
getValues = function(chartId = 1) {
idx <- which(chartIds %in% c(0, chartId))
res <- lapply(names[idx], function(n) getValue(n, chartId))
names(res) <- names[idx]
res
},
setValue = function(name, value, chartId = 1, inputId = NULL, reactive = FALSE) {
input <- getInput(name, chartId, inputId)
oldValue <- input$value
res <- input$setValue(value, reactive = reactive)
if (!identical(oldValue, res)) updateRevDeps(input)
res
},
updateRevDeps = function(input, force = FALSE) {
if (!initialized && !force) return()
for (inputId in input$revDeps) {
revDepInput <- getInput(inputId = inputId)
if(!identical(revDepInput$value, revDepInput$updateValue())) {
updateRevDeps(revDepInput)
}
}
for (inputId in input$displayRevDeps) {
updateHTMLVisibility(inputId = inputId)
}
updateHTML()
},
update = function(forceDeps = FALSE) {
"Update all inputs"
for (input in inputs) {
if (!identical(input$value, input$updateValue())) updateRevDeps(input, force = forceDeps)
}
updateHTML()
},
updateHTML = function() {
if (!is.null(session)) {
for (input in inputs) {
input$updateHTML(session)
}
}
}
)
)
manipulateWidget/R/get_output_and_render_func.R 0000644 0001762 0000144 00000001726 13216502327 021503 0 ustar ligges users #' Private function that gets shiny output and render functions for a given htmlWidget
#'
#' @param x Object, generally a htmlwidget.
#'
#' @return A list with the following elements
#' - outputFunc
#' - renderFunc
#' - useCombineWidgets TRUE only if x is not an htmlwidget
#' @noRd
getOutputAndRenderFunc <- function(x) {
# Get shiny output and render functions
if (inherits(x, "htmlwidget")) {
cl <- class(x)
pkg <- attr(x, "package")
renderFunName <- ls(getNamespace(pkg), pattern = "^render")
renderFunction <- getFromNamespace(renderFunName, pkg)
outputFunName <- ls(getNamespace(pkg), pattern = "Output$")
outputFunction <- getFromNamespace(outputFunName, pkg)
useCombineWidgets <- FALSE
} else {
renderFunction <- renderCombineWidgets
outputFunction <- combineWidgetsOutput
useCombineWidgets <- TRUE
}
list(
outputFunc = outputFunction,
renderFunc = renderFunction,
useCombineWidgets = useCombineWidgets
)
}
manipulateWidget/R/static_image.R 0000644 0001762 0000144 00000003650 13216502327 016537 0 ustar ligges users #' Include a static image in a combinedWidgets
#'
#' \code{staticPlot} is a function that generates a static plot and then return
#' the HTML code needed to include the plot in a combinedWidgets.
#' \code{staticImage} is a more general function that generates the HTML code
#' necessary to include any image file.
#'
#' @param expr Expression that creates a static plot.
#' @param width Width of the image to create.
#' @param height Height of the image to create.
#' @param file path of the image to include.
#' @param style CSS style to apply to the image.
#'
#' @return a \code{shiny.tag} object containing the HTML code required to include
#' the image or the plot in a \code{combinedWidgets} object.
#'
#' @examples
#' staticPlot(hist(rnorm(100)))
#'
#' if (require(plotly)) {
#' data(iris)
#'
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
#' )
#'
#' # You can also embed static images in the header, footer, left or right
#' # columns of a combinedWidgets. The advantage is that the space allocated
#' # to the static plot will be constant when the window is resized.
#'
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' footer = staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
#' )
#' }
#'
#' @importFrom grDevices dev.off png
#' @export
staticPlot <- function(expr, width = 600, height = 400) {
expr <- substitute(expr)
file <- tempfile(fileext = ".png")
png(file, width, height)
eval(expr)
dev.off()
staticImage(file)
}
#' @rdname staticPlot
#' @export
#'
staticImage <- function(file, style = "max-width:100%%;max-height:100%%") {
data <- base64enc::base64encode(readBin(file, "raw", file.info(file)[1, "size"]))
ext <- tools::file_ext(file)
tags$img(
src = sprintf("data:image/%s;base64,%s", ext, data),
style = style
)
}
manipulateWidget/R/get_row_and_cols.R 0000644 0001762 0000144 00000001250 13216502327 017410 0 ustar ligges users # Copyright © 2016 RTE Réseau de transport d’électricité
# Private function that compute the "ideal" number of rows and columns given the
# number of widgets to display.
.getRowAndCols <- function(n, nrow = NULL, ncol = NULL) {
if (!is.null(nrow) && !is.null(ncol) && nrow * ncol < n) {
stop("There are too much widgets compared to the number of rows and columns")
} else if (is.null(nrow) && !is.null(ncol)) {
nrow <- ceiling(n / ncol)
} else if (!is.null(nrow) && is.null(ncol)) {
ncol <- ceiling(n / nrow)
} else if (is.null(nrow) && is.null(ncol)) {
nrow <- ceiling(sqrt(n))
ncol <- ceiling(n / nrow)
}
list(nrow = nrow, ncol = ncol)
}
manipulateWidget/R/input_class.R 0000644 0001762 0000144 00000017511 13216502327 016433 0 ustar ligges users controlValueAndParams <- function(value, params, name, env){
# have another variable name in env
if(exists(name, envir = env)){
# get value
value_name <- get(name, envir = env)
control <- function(value, name, env){
# case of value / params of type name
if(is.name(value)){
# change name to new_name and assign current value
new_name <- paste0(".tmp_mw_", name)
assign(new_name, value_name, envir = env)
# modify expr
value <- eval(parse(text = paste0("substitute(", new_name, ")")))
# case of value / params of type call
} else if(is.call(value)){
# change name to new_name and assign current value
new_name <- paste0(".tmp_mw_", name)
assign(new_name, value_name, envir = env)
# modify expr
char_call <- paste0(deparse(value), collapse = "\n")
m <- gregexpr(paste0("((_.)[[:punct:]]|[[:space:]]|^){1}(",
name,
")((_.)[[:punct:]]|[[:space:]]|$){1}"), char_call)
if(m[[1]][1] != -1){
matches_values <- unlist(regmatches(char_call, m))
mlength <- attr(m[[1]], "match.length")
mstart <- m[[1]][1:length(mlength)]
if(mstart[1] != 1){
final_value <- substring(char_call, 1, mstart[1]-1)
} else {
final_value <- ""
}
for(i in 1:length(mlength)){
tmp <- matches_values[i]
if(nchar(tmp) == (nchar(name) + 2)){
final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i]), new_name,
substring(char_call, mstart[i] + mlength[i] - 1, mstart[i] + mlength[i] - 1))
} else if(nchar(tmp) == nchar(name)){
final_value <- paste0(final_value, new_name)
} else if(nchar(tmp) > (nchar(name) + 2)){
final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i] + mlength[i] - 1))
} else {
if(substring(tmp, 1, nchar(name)) == name){
final_value <- paste0(final_value, new_name,
substring(char_call, mstart[i] + mlength[i] - 1, mstart[i] + mlength[i] - 1))
} else {
final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i]), new_name)
}
}
if(i != length(mlength)){
if((mstart[i] + mlength[i]) != mstart[i+1]){
final_value <- paste0(final_value, substring(char_call, mstart[i] + mlength[i], mstart[i+1] - 1))
}
} else if((mstart[i] + mlength[i] - 1) != nchar(char_call)){
final_value <- paste0(final_value, substring(char_call, mstart[i] + mlength[i], nchar(char_call)))
}
}
} else {
final_value <- char_call
}
value <- eval(parse(text = paste0("substitute(", final_value, ")")))
} else {
value
}
return(value)
}
# control value
value <- control(value, name, env)
# control params
params <- lapply(params, function(x){control(x, name, env)})
}
return(list(value = value, params = params))
}
emptyField <- function(x) inherits(x, "uninitializedField")
evalParams <- function(params, env) {
lapply(params, function(x) {
tryCatch(eval(x, envir = env), silent = TRUE, error = function(e) {
if(mwDebugMode()) message(e$message)
NULL
})
})
}
evalValue <- function(value, env) {
tryCatch(eval(value, envir = env), silent = TRUE, error = function(e) {
if(mwDebugMode()) message(e$message);
NULL
})
}
# Private reference class representing an input.
Input <- setRefClass(
"Input",
fields = c("type", "name", "idFunc", "label", "value", "display", "params", "env",
"validFunc", "htmlFunc", "htmlUpdateFunc",
"lastParams", "changedParams", "valueHasChanged",
"revDeps", "displayRevDeps", "value_expr"),
methods = list(
init = function(name, env) {
"Set environment and default values"
name <<- name
env <<- env
valueHasChanged <<- FALSE
changedParams <<- list()
revDeps <<- character()
displayRevDeps <<- character()
if (emptyField(label) || is.null(label)) label <<- name
if (emptyField(idFunc)) {
idFunc <<- function(oid, name) paste(oid, name, sep = "_")
}
ctrl_vp <- controlValueAndParams(value, params, name, env)
value <<- ctrl_vp$value
params <<- ctrl_vp$params
if(is.call(value) | is.name(value)){
assign(name, evalValue(value, parent.frame()), envir = env)
value_expr <<- value
} else {
assign(name, value, envir = env)
value_expr <<- NULL
}
lastParams <<- NULL
},
getID = function() {
"Get the id of the input for the UI"
gsub("[^a-zA-Z0-9]", "_", idFunc(get(".output", envir = env), name))
},
setValue = function(newValue, reactive = FALSE) {
"Modify value of the input. If newValue is invalid, it sets a valid value"
catIfDebug("Set value of ", getID())
if(reactive & type == "sharedValue"){
params$dynamic <<- FALSE
}
if (!emptyField(validFunc)) value <<- validFunc(evalValue(newValue, env), getParams())
assign(name, value, envir = env)
valueHasChanged <<- FALSE
value
},
updateValue = function() {
"Update value after a change in environment"
catIfDebug("Update value of ", getID())
oldValue <- value
if (!emptyField(validFunc)){
if(is.call(value_expr) | is.name(value_expr)){
tmp_value <- evalValue(value_expr, env)
if(is.null(tmp_value) & !is.call(oldValue) & !is.name(oldValue)) tmp_value <- oldValue
value <<- validFunc(tmp_value, getParams())
} else {
tmp_value <- evalValue(value, env)
if(is.null(tmp_value) & !is.call(oldValue) & !is.name(oldValue)) tmp_value <- oldValue
value <<- validFunc(tmp_value, getParams())
}
}
if (!identical(value, oldValue)) {
valueHasChanged <<- TRUE
assign(name, value, envir = env)
}
value
},
getParams = function() {
"Get parameter values"
oldParams <- lastParams
lastParams <<- evalParams(params, env)
for (n in names(lastParams)) {
if (!is.null(oldParams[[n]]) &&
!identical(lastParams[[n]], oldParams[[n]])) {
changedParams[[n]] <<- lastParams[[n]]
}
}
lastParams
},
getHTML = function(ns = NULL) {
"Get the input HTML"
if (emptyField(htmlFunc)) return(NULL)
id <- getID()
if (!is.null(ns)) id <- ns(id)
shiny::conditionalPanel(
condition = sprintf("input['%s_visible']", id),
tags$div(
style="display:none;",
shiny::checkboxInput(paste0(id, "_visible"), "", value = evalValue(display, env))
),
htmlFunc(id, label, value, lastParams, ns)
)
},
updateHTML = function(session) {
"Update the input HTML."
if (emptyField(htmlUpdateFunc)) return()
if (valueHasChanged || length(changedParams) > 0) {
catIfDebug("Update HTML of ", getID(), "\n")
htmlParams <- changedParams
if (valueHasChanged) htmlParams$value <- value
else if(length(changedParams) > 0){
htmlParams$value <- validFunc(value, getParams())
}
htmlParams$session <- session
htmlParams$inputId <- getID()
do.call(htmlUpdateFunc, htmlParams)
valueHasChanged <<- FALSE
changedParams <<- list()
}
},
show = function() {
"print method"
cat("input of class", type, "\n")
if (type == "group") {
for (n in names(value)) {
cat("$", n, ": ", sep = "")
value[[n]]$show()
}
}
}
)
)
manipulateWidget/R/module_ui.R 0000644 0001762 0000144 00000007447 13243026421 016074 0 ustar ligges users #' Add a manipulateWidget to a shiny application
#'
#' These two functions can be used to include a manipulateWidget object in a shiny application.
#' \code{mwModuleUI} must be used in the UI to generate the required HTML elements and add
#' javascript and css dependencies. \code{mwModule} must be called once in the server function
#' of the application.
#'
#' @param id A unique string that identifies the module
#' @param controller Object of class \code{\link{MWController}} returned by
#' \code{\link{manipulateWidget}} when parameter \code{.runApp} is
#' \code{FALSE}.
#' @param fillPage : \code{logical}. Render in a fillPage or not ? Defaut to FALSE
#' @param ... named arguments containing reactive values. They can be used to send data from
#' the main shiny application to the module.
#'
#' @return \code{mwModuleUI} returns the required HTML elements for the module. mwModule is only
#' used for its side effects.
#'
#' @examples
#' if (interactive() & require("dygraphs")) {
#' require("shiny")
#' ui <- fillPage(
#' fillRow(
#' flex = c(NA, 1),
#' div(
#' textInput("title", label = "Title", value = "glop"),
#' selectInput("series", "series", choices = c("series1", "series2", "series3"))
#' ),
#' mwModuleUI("ui", height = "100%")
#' ))
#'
#' server <- function(input, output, session) {
#' mydata <- data.frame(
#' year = 2000+1:100,
#' series1 = rnorm(100),
#' series2 = rnorm(100),
#' series3 = rnorm(100)
#' )
#'
#' c <- manipulateWidget(
#' {
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title)
#' },
#' range = mwSlider(2001, 2100, c(2001, 2050)),
#' series = mwSharedValue(),
#' title = mwSharedValue(), .runApp = FALSE,
#' .compare = "range"
#' )
#' #
#' mwModule("ui", c, title = reactive(input$title), series = reactive(input$series))
#' }
#'
#' shinyApp(ui, server)
#'
#'
#' }
#'
#' @export
mwModule <- function(id, controller, fillPage = FALSE, ...) {
shiny::callModule(controller$getModuleServer(), id, fillPage = fillPage, ...)
}
#' @param border Should a border be added to the module?
#' @param okBtn Should the UI contain the OK button?
#' @param saveBtn Should the UI contain the save button?
#' @param margin Margin to apply around the module UI. Should be one two or four valid css
#' units.
#' @param width Width of the module UI.
#' @param height Height of the module UI.
#' @param header Tag or list of tags to display as a common header above all tabPanels.
#' @param footer Tag or list of tags to display as a common footer below all tabPanels
#'
#' @rdname mwModule
#' @export
mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin = 0,
width = "100%", height = 400, header = NULL, footer = NULL) {
ns <- shiny::NS(id)
for (i in seq_along(margin)) {
margin[i] <- shiny::validateCssUnit(margin[i])
}
margin <-paste(margin, collapse = " ")
class <- ""
if (border) class <- c(class, "with-border")
if(!okBtn) class <- c(class, "without-ok")
if(!saveBtn) class <- c(class, "without-save")
class <- paste(class, collapse = " ")
res <- shiny::tagList(
header,
shiny::uiOutput(ns("ui"), container = function(...) {
tags$div(style=sprintf("width:%s;height:%s;padding:%s",
shiny::validateCssUnit(width),
shiny::validateCssUnit(height),
margin),
class = class,
...)
}),
footer
)
htmldep <- htmltools::htmlDependency(
"manipulateWidget",
"0.7.0",
system.file("manipulate_widget", package = "manipulateWidget"),
script = "manipulate_widget.js",
style = "manipulate_widget.css"
)
htmltools::attachDependencies(res, htmldep, TRUE)
}
manipulateWidget/R/combine_widgets.R 0000644 0001762 0000144 00000031467 13256176767 017302 0 ustar ligges users #Copyright © 2016 RTE Réseau de transport d’électricité
#' Combine several interactive plots
#'
#' This function combines different htmlwidgets in a unique view.
#'
#' @param ... htmlwidgets to combine. If this list contains objects that are not
#' htmlwidgets, the function tries to convert them into a character string which
#' is interpreted as html content.
#' @param list Instead of directly passing htmlwidgets to the function, one can
#' pass a list of htmlwidgets and objects coercible to character. In particular,
#' it can be usefull if multiple htmlwidgets have been generated using a loop
#' function like \code{\link[base]{lapply}}.
#' @param nrow Number of rows of the layout. If \code{NULL}, the function will
#' automatically take a value such that are at least as many cells in the
#' layout as the number of htmlwidgets.
#' @param ncol Number of columns of the layout.If \code{NULL}, the function will
#' automatically take a value such that are at least as many cells in the
#' layout as the number of htmlwidgets.
#' @param title Title of the view.
#' @param rowsize This argument controls the relative size of each row. For
#' instance, if the layout has two rows and \code{rowsize = c(2,1)}, then the
#' width of the first row will be twice the one of the second one. This
#' argument is recycled to fit the number of rows.
#' @param colsize Same as rowsize but for the height of the columns of the
#' layout.
#' @param byrow If \code{TRUE}, then the layout is filled by row. Else it is
#' filled by column.
#' @param titleCSS A character containing css properties to modify the
#' appearance of the title of the view.
#' @param header Content to display between the title and the combined widgets.
#' It can be a single character string or html tags.
#' @param footer Content to display under the combined widgets. It can be a
#' single character string or html tags.
#' @param leftCol Content to display on the left of the combined widgets. It can
#' be a single character string or html tags.
#' @param rightCol Content to display on the right the combined widgets. It can
#' be a single character string or html tags.
#'
#' @param width Total width of the layout (optional, defaults to automatic
#' sizing).
#' @param height Total height of the layout (optional, defaults to automatic
#' sizing).
#' @return A htmlwidget object of class \code{combineWidget}. Individual widgets
#' are stored in element \code{widgets} and can be extracted or updated. This
#' is useful when a function returns a \code{combineWidgets} object but user
#' wants to keep only one widget or to update one of them (see examples).
#'
#' @details The function only allows table like layout : each row has the same
#' number of columns and reciprocally. But it is possible to create more complex
#' layout by nesting combined htmlwidgets. (see examples)
#'
#' @examples
#' if (require(plotly)) {
#' data(iris)
#'
#' combineWidgets(title = "The Iris dataset",
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Petal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Petal.Width, type = "histogram", nbinsx = 20)
#' )
#'
#' # Create a more complex layout by nesting combinedWidgets
#' combineWidgets(title = "The iris data set: sepals", ncol = 2, colsize = c(2,1),
#' plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width, type = "scatter",
#' mode = "markers", color = ~Species),
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20)
#' )
#' )
#'
#' # combineWidgets can also be used on a single widget to easily add to it a
#' # title and a footer.
#' require(shiny)
#' comments <- tags$div(
#' "Wow this plot is so ",
#' tags$span("amazing!!", style = "color:red;font-size:36px")
#' )
#'
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' title = "Distribution of Sepal Length",
#' footer = comments
#' )
#'
#' # It is also possible to combine htmlwidgets with text or other html elements
#' myComment <- tags$div(
#' style="height:100%;background-color:#eee;padding:10px;box-sizing:border-box",
#' tags$h2("Comment"),
#' tags$hr(),
#' "Here is a very clever comment about the awesome graphics you just saw."
#' )
#' combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Petal.Length, type = "histogram", nbinsx = 20),
#' myComment
#' )
#'
#' # Updating individual widgets.
#' myWidget <- combineWidgets(
#' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
#' plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20),
#' ncol = 2
#' )
#' myWidget
#'
#'
#' myWidget$widgets[[1]] <- myWidget$widgets[[1]] %>%
#' layout(title = "Histogram of Sepal Length")
#'
#' myWidget$widgets[[2]] <- myWidget$widgets[[2]] %>%
#' layout(title = "Histogram of Sepal Width")
#'
#' myWidget
#'
#'
#' # Instead of passing directly htmlwidgets to the function, one can pass
#' # a list containing htmlwidgets. This is especially useful when the widgets
#' # are generated using a loop function like "lapply" or "replicate".
#' #
#' # The following code generates a list of 12 histograms and use combineWidgets
#' # to display them.
#' samples <- replicate(12, plot_ly(x = rnorm(100), type = "histogram", nbinsx = 20),
#' simplify = FALSE)
#' combineWidgets(list = samples, title = "12 samples of the same distribution")
#' }
#'
#' @export
#' @importFrom htmltools tagGetAttribute
combineWidgets <- function(..., list = NULL, nrow = NULL, ncol = NULL, title = NULL,
rowsize = 1, colsize = 1, byrow = TRUE,
titleCSS = "",
header = NULL, footer = NULL,
leftCol = NULL, rightCol = NULL,
width = NULL, height = NULL) {
widgets <- c(list(...), list)
if (length(widgets) == 0) return(combineWidgets(""))
# create empty widget
res <- htmlwidgets::createWidget(
name = 'combineWidgets',
x = NULL,
width = width,
height = height,
package = 'manipulateWidget',
sizingPolicy = htmlwidgets::sizingPolicy(
browser.fill = TRUE
),
preRenderHook = preRenderCombinedWidgets
)
# Add dependencies of embedded widgets or shiny tags
# This works through the widgets recursively, in case
# we were passed a shiny.tag.list or other list of
# non-widgets.
getDeps <- function(x) {
if (!is.null(attr(x, "package")))
append(tryCatch(getDependency(class(x)[1], attr(x, "package")),
error = function(e) NULL), x$dependencies)
else if (!is.null(attr(x, "html_dependencies")))
attr(x, "html_dependencies")
else if (is.list(x))
do.call(c, lapply(x, getDeps))
}
deps <- c(getDeps(widgets),
getDeps(header),
getDeps(footer),
getDeps(leftCol),
getDeps(rightCol))
res$dependencies <- deps
# Add widget list and parameters
res$widgets <- widgets
res$params <- list(
nrow = nrow,
ncol = ncol,
title = title,
rowsize = rowsize,
colsize = colsize,
byrow = byrow,
titleCSS = titleCSS,
header = header,
footer = footer,
leftCol = leftCol,
rightCol = rightCol,
width = width,
height = height
)
res
}
#' Shiny bindings for combineWidgets
#'
#' Output and render functions for using combineWidgets within Shiny
#' applications and interactive Rmd documents.
#'
#' @param outputId output variable to read from
#' @param width,height Must be a valid CSS unit (like \code{'100\%'},
#' \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a
#' string and have \code{'px'} appended.
#' @param expr An expression that generates a combineWidgets
#' @param env The environment in which to evaluate \code{expr}.
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#' is useful if you want to save an expression in a variable.
#'
#' @name combineWidgets-shiny
#'
#' @export
combineWidgetsOutput <- function(outputId, width = '100%', height = '400px'){
htmlwidgets::shinyWidgetOutput(outputId, 'combineWidgets', width, height, package = 'manipulateWidget')
}
#' @rdname combineWidgets-shiny
#' @export
renderCombineWidgets <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) { expr <- substitute(expr) } # force quoted
htmlwidgets::shinyRenderWidget(expr, combineWidgetsOutput, env, quoted = TRUE)
}
# Private function used to prerender a combinedWidgets object
preRenderCombinedWidgets <- function(x) {
hasCrosstalkInputs <- any(unlist(lapply(x$widgets, isCrosstalkInput)))
widgets <- lapply(unname(x$widgets), function(w) {
if (is.atomic(w)) return(structure(list(x = as.character(w)), class = "html"))
if (is.null(w$preRenderHook)) {
if (is(w, "htmlwidget")) return(w)
else return(structure(list(x = as.character(w)), class = "html"))
}
w$preRenderHook(w)
})
nwidgets <- length(x$widgets)
# Get number of rows and cols
dims <- .getRowAndCols(nwidgets, x$params$nrow, x$params$ncol)
nrow <- dims$nrow
ncol <- dims$ncol
ncells <- nrow * ncol
# Relative size of rows and cols
rowsize <- rep(x$params$rowsize, length.out = nrow)
colsize <- rep(x$params$colsize, length.out = ncol)
# Get the html ID of each widget
if (!is.null(names(x$widgets))) {
elementId <- names(x$widgets)
elementId[elementId == ""] <- "widget"
elementId <- make.unique(elementId)
} else {
elementId <- sapply(widgets[1:ncells], function(w) {
if (is.null(w)) res <- NULL
else res <- w$elementId
if (is.null(res)) res <- paste0("widget", floor(stats::runif(1, max = 1e9)))
res
})
}
# Get the HTML class for each widget, plus "cw-widget"
elementClass <- sapply(widgets[1:ncells], function(w) {
result <- NULL
if (inherits(w, "htmlwidget"))
result <- class(w)[1]
else if (inherits(w, "shiny.tag"))
result <- tagGetAttribute(w, "class")
paste(result, "cw-widget")
})
# Construct the html of the combined widget
dirClass <- ifelse(x$params$byrow, "cw-by-row", "cw-by-col")
widgetEL <- mapply(
function(id, size, class) {
sprintf('',
size, size, id, class)
},
id = elementId,
size = rep(colsize, length.out = ncells),
class = elementClass
)
rowsEl <- lapply(1:nrow, function(i) {
content <- widgetEL[((i-1) * ncol + 1):(i * ncol)]
sprintf('%s
',
dirClass, rowsize[i], rowsize[i], paste(content, collapse = ""))
})
content <- sprintf('%s
',
dirClass, paste(rowsEl, collapse = ""))
if(!is.null(x$params$title) && !x$params$title == "") {
titleEl <- sprintf('
%s ',
x$params$titleCSS, x$params$title)
} else {
titleEl <- ""
}
if (is.null(x$params$footer)) footer <- ""
else footer <- paste0("", x$params$footer, "
")
if (is.null(x$params$header)) header <- ""
else header <- paste0("", x$params$header, "
")
if (is.null(x$params$leftCol)) leftCol <- ""
else leftCol <- paste0("", x$params$leftCol, "
")
if (is.null(x$params$rightCol)) rightCol <- ""
else rightCol <- paste0("", x$params$rightCol, "
")
html <- sprintf('',
titleEl, header, leftCol, content, rightCol, footer)
data <- lapply(widgets, function(w) w$x)
widgetType <- sapply(widgets, function(w) class(w)[1])
x$x <- list(data = data, widgetType = widgetType, elementId = elementId, html = html,
hasCrosstalkInputs = hasCrosstalkInputs);
x
}
# Check whether a widget is a crosstalk-package input, which will need special
# initialization within combineWidgets()
isCrosstalkInput <- function(w) {
inherits(w, "shiny.tag") &&
!is.null(w$attribs) &&
grepl("crosstalk-input", w$attribs$class)
}
manipulateWidget/R/manipulate_widget.R 0000644 0001762 0000144 00000027607 13256125307 017623 0 ustar ligges users #Copyright © 2016 RTE Réseau de transport d’électricité
#' Add Controls to Interactive Plots
#'
#' @description
#' This function permits to add controls to an interactive plot created with
#' packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order
#' to change the input data or the parameters of the plot.
#'
#' Technically, the function starts a shiny gadget. The R session is bloqued
#' until the user clicks on "cancel" or "done". If he clicks on "done", then the
#' the function returns the last displayed plot so the user can modify it and/or
#' save it.
#'
#' @param .expr expression to evaluate that returns an interactive plot of class
#' \code{htmlwidget}. This expression is re-evaluated each time a control is
#' modified.
#' @param ... One or more named control arguments created with functions
#' \code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control
#' is the name of the variable the controls modifies in the expression. One
#' can also create a group of inputs by passing a list of such control
#' arguments. for instance \code{mygroup = list(txt = mwText(""), nb =
#' mwNumeric(0))} creates a group of inputs named mygroup with two inputs
#' named "txt" and "nb".
#' @param .updateBtn Should an update button be added to the controls ? If
#' \code{TRUE}, then the graphic is updated only when the user clicks on the
#' update button.
#' @param .saveBtn Should an save button be added to the controls ?
#' @param .updateBtnInit In case of update button. Do you want to render graphics on init ?
#' @param .viewer Controls where the gadget should be displayed. \code{"pane"}
#' corresponds to the Rstudio viewer, \code{"window"} to a dialog window, and
#' \code{"browser"} to an external web browser.
#' @param .compare Sometimes one wants to compare the same chart but with two
#' different sets of parameters. This is the purpose of this argument. It can
#' be a character vector of input names or a named list whose names are the
#' names of the inputs that should vary between the two charts. Each element
#' of the list must be a vector or a list of length equal to the number of
#' charts with the initial values of the corresponding parameter for each
#' chart. It can also be \code{NULL}. In this case, the parameter is
#' initialized with the default value for the two charts.
#' @param .compareOpts List of options created \code{\link{compareOptions}}.
#' These options indicate the number of charts to create and their disposition.
#' @param .showCompare \code{logical}. In case of \code{.compare}. Show windows selection on menu ?
#' @param .return A function that can be used to modify the output of
#' \code{manipulateWidget}. It must take two parameters: the first one is the
#' final widget, the second one is a list of environments containing the input
#' values of each individual widget. The length of this list is one if .compare
#' is null, two or more if it has been defined.
#' @param .width Width of the UI. Used only on Rmarkdown documents with option
#' \code{runtime: shiny}.
#' @param .height Height of the UI. Used only on Rmarkdown documents with option
#' \code{runtime: shiny}.
#' @param .runApp (advanced usage) If true, a shiny gadget is started. If false,
#' the function returns a \code{\link{MWController}} object. This object can be
#' used to check with command line instructions the behavior of the application.
#' (See help page of \code{\link{MWController}}). Notice that this parameter is
#' always false in a non-interactive session (for instance when running tests of
#' a package).
#'
#'
#' @return
#' The result of the expression evaluated with the last values of the controls.
#' It should be an object of class \code{htmlWidget}.
#'
#' @section Advanced Usage:
#' The "normal" use of the function is to provide an expression that always
#' return an \code{htmlwidget}. In such case, every time the user changes the
#' value of an input, the current widget is destroyed and a new one is created
#' and rendered.
#'
#' Some packages provide functions to update a widget that has already been
#' rendered. This is the case for instance for package \code{leaflet} with the
#' function \code{\link[leaflet]{leafletProxy}}. To use such functions,
#' \code{manipulateWidget} evaluates the parameter \code{.expr} with four extra
#' variables:
#'
#' \itemize{
#' \item{\code{.initial}:}{
#' \code{TRUE} if the expression is evaluated for the first time and then
#' the widget has not been rendered yet, \code{FALSE} if the widget has
#' already been rendered.
#' }
#' \item{\code{.session}:}{
#' A shiny session object.
#' }
#' \item{\code{.output}:}{
#' ID of the output in the shiny interface.
#' }
#' \item{\code{.id}:}{
#' Id of the chart. It can be used in comparison mode to make further
#' customization without the need to create additional input controls.
#' }
#' }
#'
#' You can take a look at the last example to see how to use these two
#' variables to update a leaflet widget.
#'
#' @section Modify the returned widget:
#' In some specific situations, a developer may want to use
#' \code{manipulateWidget} in a function that waits the user to click on the
#' "Done" button and modifies the widget returned by \code{manipulateWidget}.
#' In such situation, parameter \code{.return} should be used so that
#' \code{manipulateWidget} is the last function called. Indeed, if other code
#' is present after, the custom function will act very weird in a Rmarkdown
#' document with "runtime: shiny".
#'
#' @examples
#' if (require(dygraphs)) {
#'
#' mydata <- data.frame(year = 2000+1:100, value = rnorm(100))
#' manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' title = mwText("Fictive time series"))
#'
#' }
#'
#' # Comparison mode
#' if (require(dygraphs)) {
#'
#' mydata <- data.frame(
#' year = 2000+1:100,
#' series1 = rnorm(100),
#' series2 = rnorm(100),
#' series3 = rnorm(100)
#' )
#'
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' series = mwSelect(c("series1", "series2", "series3")),
#' title = mwText("Fictive time series"),
#' .compare = c("title", "series")
#' )
#'
#' # Setting different initial values for each chart
#' manipulateWidget(
#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' series = mwSelect(c("series1", "series2", "series3")),
#' title = mwText(),
#' .compare = list(
#' title = list("First chart", "Second chart"),
#' series = NULL
#' )
#' )
#' }
#'
#' # Grouping inputs
#' if (require(dygraphs)) {
#'
#' mydata <- data.frame(year = 2000+1:100, value = rnorm(100))
#' manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ],
#' main = title, xlab = xlab, ylab = ylab),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
#' "Graphical parameters" = mwGroup(
#' title = mwText("Fictive time series"),
#' xlab = mwText("X axis label"),
#' ylab = mwText("Y axis label")
#' )
#' )
#'
#' }
#'
#' # Example of conditional input controls
#' #
#' # In this example, we plot a x series against a y series. User can choose to
#' # use points or lines. If he chooses lines, then an additional input is displayed
#' # to let him control the width of the lines.
#' if (require("plotly")) {
#'
#' dt <- data.frame (
#' x = sort(runif(100)),
#' y = rnorm(100)
#' )
#'
#' myPlot <- function(type, lwd) {
#' if (type == "points") {
#' plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers")
#' } else {
#' plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd))
#' }
#' }
#'
#' manipulateWidget(
#' myPlot(type, lwd),
#' type = mwSelect(c("points", "lines"), "points"),
#' lwd = mwSlider(1, 10, 1, .display = type == "lines")
#' )
#'
#' }
#'
#' # Advanced Usage
#' #
#' # .expr is evaluated with extra variables .initial, .outputId and .session
#' # that can be used to update an already rendered widget instead of replacing
#' # it each time an input value is modified.
#' #
#' # Here we generate a UI that permits to change color and size of arbitrary
#' # points on a map generated with leaflet.
#'
#' if (require(leaflet)) {
#' lon <- rnorm(10, sd = 20)
#' lat <- rnorm(10, sd = 20)
#'
#' myMapFun <- function(radius, color, initial, session, output) {
#' if (initial) {
#' # Widget has not been rendered
#' map <- leaflet() %>% addTiles()
#' } else {
#' # widget has already been rendered
#' map <- leafletProxy(output, session) %>% clearMarkers()
#' }
#'
#' map %>% addCircleMarkers(lon, lat, radius = radius, color = color)
#' }
#'
#' manipulateWidget(myMapFun(radius, color, .initial, .session, .output),
#' radius = mwSlider(5, 30, 10),
#' color = mwSelect(c("red", "blue", "green")))
#'
#' }
#'
#' @export
#'
manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE,
.updateBtnInit = FALSE,
.viewer = c("pane", "window", "browser"),
.compare = NULL,
.compareOpts = compareOptions(),
.showCompare = TRUE,
.return = function(widget, envs) {widget},
.width = NULL, .height = NULL, .runApp = TRUE) {
# check if we are in runtime shiny
isRuntimeShiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny")
.expr <- substitute(.expr)
.viewer <- match.arg(.viewer)
.env <- parent.frame()
.compareOpts <- do.call(compareOptions, .compareOpts)
if (is.null(.compare)) {
.compareOpts$ncharts <- 1
} else {
if (is.character(.compare)) {
.compare <- sapply(.compare, function(x) NULL,
simplify = FALSE, USE.NAMES = TRUE)
}
if (is.null(.compareOpts$ncharts) || .compareOpts$ncharts < 2) {
.compareOpts$ncharts <- 2
}
}
dims <- .getRowAndCols(.compareOpts$ncharts, .compareOpts$nrow, .compareOpts$ncol)
# Initialize inputs
inputs <- initInputs(list(...), env = .env, compare = .compare,
ncharts = .compareOpts$ncharts)
# Initialize controller
controller <- MWController(.expr, inputs,
autoUpdate = list(value = !.updateBtn, initBtn = .updateBtnInit, showCompare = .showCompare),
nrow = dims$nrow, ncol = dims$ncol,
returnFunc = .return)
if (.runApp & interactive()) {
# We are in an interactive session so we start a shiny gadget
.viewer <- switch(
.viewer,
pane = shiny::paneViewer(),
window = shiny::dialogViewer("manipulateWidget"),
browser = shiny::browserViewer()
)
ui <- mwModuleUI("ui", border = FALSE, okBtn = TRUE, saveBtn = .saveBtn,
width = "100%", height = "100%")
server <- function(input, output, session) {
mwModule("ui", controller, fillPage = TRUE)
}
shiny::runGadget(ui, server, viewer = .viewer)
} else if (.runApp & isRuntimeShiny) {
# We are in Rmarkdown document with shiny runtime. So we start a shiny app
ui <- mwModuleUI("ui", margin = c("20px", 0), width = "100%", height = "100%")
server <- function(input, output, session) {
mwModule("ui", controller, fillPage = TRUE)
}
shiny::shinyApp(ui = ui, server = server, options = list(width = .width, height = .height))
} else {
# Other cases (Rmarkdown or non interactive execution). We return the controller
# to not block the R execution.
controller
}
}
manipulateWidget/R/init_inputs.R 0000644 0001762 0000144 00000004240 13216502327 016447 0 ustar ligges users #' Private function that initialize an environment for a given chart.
#'
#' @param parentEnv an environment to be used as the enclosure of the environment
#' created.
#' @param id index of the chart
#'
#' @return Environment
#' @noRd
initEnv <- function(parentEnv, id) {
res <- new.env(parent = parentEnv)
res$.initial <- TRUE
res$.session <- NULL
res$.id <- id
if (id == 0) res$.output <- "shared"
else res$.output <- paste0("output_", id)
res
}
#' Private function that initializes environments and inputs
#'
#' @param inputs list of uninitialized inputs
#' @param env parent environement
#' @param compare character vector with the name of the inputs to compare
#' @param ncharts number of charts that will be created
#'
#' @return A list with the following elements:
#' - envs: list with elements
#' - shared: shared environment
#' - ind: list of individual environments. Length is equal to ncharts
#' - inputs: list with elements:
#' - shared: shared inputs (initialized)
#' -ind: list of individual inputs (initialized) for each chart. Length is
#' equal to ncharts
#' - inputList: same as inputs but flattened to facilitate looping.
#' - ncharts: number of charts
#' @noRd
initInputs <- function(inputs, env = parent.frame(), compare = NULL, ncharts = 1) {
if (is.null(names(inputs))) stop("All arguments need to be named.")
for (i in inputs) if (!inherits(i, "Input")) stop("All arguments need to be Input objects.")
sharedEnv <- initEnv(env, 0)
indEnvs <- lapply(seq_len(ncharts), function(i) initEnv(sharedEnv, i))
sharedInputs <- filterAndInitInputs(inputs, names(compare), drop = TRUE, sharedEnv)
indInputs <- lapply(seq_len(ncharts), function(i) {
newValues <- list()
for (n in names(compare)) {
if(!is.null(compare[[n]])) newValues[[n]] <- compare[[n]][[i]]
}
filterAndInitInputs(inputs, names(compare), env = indEnvs[[i]], newValues = newValues)
})
inputList <- InputList(list(sharedInputs, indInputs))
list(
envs = list(
shared = sharedEnv,
ind = indEnvs
),
inputs = list(
shared = sharedInputs,
ind = indInputs
),
inputList = inputList,
ncharts = ncharts
)
}
manipulateWidget/R/zzz.R 0000644 0001762 0000144 00000007322 13216502327 014743 0 ustar ligges users # Copyright © 2016 RTE Réseau de transport d’électricité
#' @name manipulateWidget-package
#'
#' @title Add even more interactivity to interactive charts
#'
#' @description
#' This package is largely inspired by the \code{manipulate} package from
#' Rstudio. It can be used to easily create graphical interface that let the
#' user modify the data or the parameters of an interactive chart. It also
#' provides the \code{\link{combineWidgets}} function to easily combine multiple
#' interactive charts in a single view.
#'
#' @details
#' \code{\link{manipulateWidget}} is the main function of the package. It
#' accepts an expression that generates an interactive chart (and more precisely
#' an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you
#' have never heard about it) and a set of controls created with functions
#' \code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change
#' values within the expression. Each time the user modifies the value of a
#' control, the expression is evaluated again and the chart is updated. Consider
#' the following code:
#'
#' \code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))}
#'
#' It will generate a graphical interface with a select input on its left with
#' options "BE", "DE", "ES", "FR". By default, at the beginning the value of the
#' variable \code{country} will be equal to the first choice of the
#' corresponding input. So the function will first execute
#' \code{myPlotFun("BE")} and the result will be displayed in the main panel of
#' the interface. If the user changes the value to "FR", then the expression
#' \code{myPlotFun("FR")} is evaluated and the new result is displayed.
#'
#' The interface also contains a button "Done". When the user clicks on it, the
#' last chart is returned. It can be stored in a variable, be modified by the
#' user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package
#' \code{htmlwidgets} or converted to a static image file with package
#' \code{webshot}.
#'
#' Finally one can easily create complex layouts thanks to function
#' \code{\link{combineWidgets}}. For instance, assume we want to see a map that
#' displays values of some variable for a given year, but on its right side we also
#' want to see the distributions of three variables. Then we could write:
#'
#' \preformatted{
#' myPlotFun <- function(year, variable) {
#' combineWidgets(
#' ncol = 2, colSize = c(3, 1),
#' myMap(year, variable),
#' combineWidgets(
#' ncol = 1,
#' myHist(year, "V1"),
#' myHist(year, "V2"),
#' myHist(year, "V3"),
#' )
#' )
#' }
#'
#' manipulateWidget(
#' myPlotFun(year, variable),
#' year = mwSlider(2000, 2016, value = 2000),
#' variable = mwSelect(c("V1", "V2", "V3"))
#' )
#' }
#'
#' Of course, \code{\link{combineWidgets}} can be used outside of
#' \code{\link{manipulateWidget}}. For instance, it can be used in an
#' Rmarkdown document to easily put together interactive charts.
#'
#' For more concrete examples of usage, you should look at the documentation and
#' especially the examples of \code{\link{manipulateWidget}} and
#' \code{\link{combineWidgets}}.
#'
#' @seealso \code{\link{manipulateWidget}}, \code{\link{combineWidgets}}
#'
#' @rdname manipulateWidget-package
#' @docType package
#' @importFrom shiny tags observe observeEvent reactive isolate icon tagAppendChild
#' @importFrom shiny tagAppendChildren fillPage fillRow
#' @importFrom miniUI miniContentPanel miniPage miniTabPanel miniTabstripPanel gadgetTitleBar
#' @importFrom htmlwidgets getDependency
#' @importFrom methods is new setRefClass
#' @importFrom utils getFromNamespace
#' @importFrom stats runif
NULL
#
globalVariables(c("mod", "multiple", "name", "type"))
manipulateWidget/vignettes/ 0000755 0001762 0000144 00000000000 13256205556 015576 5 ustar ligges users manipulateWidget/vignettes/fancy-example.gif 0000644 0001762 0000144 00001062372 13211521412 021010 0 ustar ligges users GIF89aXj ޱٱԹӰͦǜÝּܾ˽ɻѲߧٜϟΙ̒ɐǍljņÄ|yvtrojgb`]YSQPPPONNNNNNQX]beiptuw|ěǙ|smfz^kRdKbJeOgZqorwquucpniojelg_ef_eh[aaVf^P_ZDLV=BP59F.48,2.)5-(:0.M08]8Cf>Nw?VB[@aAj2z""!%''*2:>?BE>/~!wwvwvvv!NETSCAPE2.0 ! , Xj H@ȰA-e8H3N1 _9d"OHhH͛8sɳϟ@
Q #@ kcc/FhLaiQbҥM1,O`'\:43_yAFP `p1cŐ*˘3k̹N3طi$ dQՅt#,\#fMوWMOc6A?PMPO7|S yEpn.Y[4+b5oǁyA㹾S\a8sOk|p9k$8j@G7\7߄6߄3b'PYٶ.xN.S&N/#/|#Zp-09*'!s9wa8(
W_=6c3 "\~c Q8(s؆G||MŠZc.#5BA
$=i|8#X<Eƈ7L=ݠw4sip8tslT1nb#iWH9$#!.#4ܢ7tsO230IxioeRE1NA6D":otllu8Ȉ)k|x(80BބS[qt
9Ɍ*$z
:<ב)t$s3L1tWJC18pH0/M6Ԅl=Px0p-iqx
r~7XzĩHZڍxt{hc[A"wL8D*7xs29D)qpGxA?7-ˌs@
d
* 9K`6Gʄ1݈n=B@
cM/?NY`S|ŷC~i׀ERB1;8C!d(w!H9Km$ _$fp7At1\ BoZZażG-"w"6G'4sH2
?`AT7R2#o-J t-Q&2^HH\#H*бUnB!x8 V@d(Mb}H"GT+s@ 4h4"x) At gf:B <@jVSkB/sl'{P2M:Y H`|';xӞg>i{A@4MhBMAAJ9wML4'=~jGGj(M)P@`
S&ЛEqNvԧ$hPC
RHMjExԦr QpSmZg7),vn_*Wz4Rֶp\JP^JW-
`p(\X,ֱ_l XʮUƀz
hGKҚMjWWGlgKͭnwd
nd{YbvZo:ЍtKZ؝