├── codecov.yml ├── revdep ├── failures.md ├── problems.md └── README.md ├── LICENSE ├── tests ├── testthat.R └── testthat │ ├── test-staticPlot.R │ ├── test-mwModuleUI.R │ ├── test-get_output_and_render_func.R │ ├── test-input_class.R │ ├── helper-input_class.R │ ├── test-on_done.R │ ├── test-mwGroup.R │ ├── test-inputs.R │ ├── test-controller.R │ ├── test-manipulate_widget.R │ └── test-input_list_class.R ├── data └── worldEnergyUse.rda ├── vignettes ├── comparison.gif ├── fancy-example.gif ├── groups-inputs.gif ├── update-widget.gif ├── dynamic_inputs.gif ├── example-kmeans.gif └── conditional-inputs.gif ├── .gitignore ├── README_files └── figure-gfm │ ├── plotevouse-1.png │ ├── plotshareuse-1.png │ └── combinewidgets-1.png ├── inst ├── htmlwidgets │ ├── combineWidgets.yaml │ ├── combineWidgets.css │ └── combineWidgets.js ├── lib │ └── export │ │ ├── Blob │ │ ├── README.md │ │ ├── LICENSE.md │ │ └── Blob.js │ │ ├── canvas-toBlob │ │ ├── README.md │ │ ├── LICENSE.md │ │ └── canvas-toBlob.js │ │ └── FileSaver │ │ ├── LICENSE.md │ │ ├── README.md │ │ └── FileSaver.min.js ├── examples │ ├── example-reactive_values.R │ ├── example-mwSharedValue.R │ ├── example-two_mods_one_app.R │ ├── energy_consumption.R │ ├── example-runtime_shiny.Rmd │ └── manipulate_widget.R └── manipulate_widget │ ├── manipulate_widget.js │ └── manipulate_widget.css ├── .Rbuildignore ├── .travis.yml ├── cran-comments.md ├── R ├── debug.R ├── on_done.R ├── get_row_and_cols.R ├── get_output_and_render_func.R ├── shiny_module.R ├── translations.R ├── compare_options.R ├── shiny_module_grid.R ├── static_image.R ├── module_ui.R ├── shiny_module_compare_inputs.R ├── shiny_module_inputarea.R ├── mw_ui.R ├── zzz.R ├── shiny_module_menu.R ├── input_env.R └── input_list_class.R ├── man ├── summary.MWController.Rd ├── knit_print.MWController.Rd ├── combineWidgets-shiny.Rd ├── mwText.Rd ├── mwNumeric.Rd ├── mwCheckbox.Rd ├── mwGroup.Rd ├── mwDate.Rd ├── mwTranslations.Rd ├── worldEnergyUse.Rd ├── mwPassword.Rd ├── mwDateRange.Rd ├── staticPlot.Rd ├── mwRadio.Rd ├── mwCheckboxGroup.Rd ├── compareOptions.Rd ├── mwSlider.Rd ├── mwSharedValue.Rd ├── mwSelectize.Rd ├── mwSelect.Rd ├── MWController-class.Rd ├── manipulateWidget-package.Rd ├── mwModule.Rd └── combineWidgets.Rd ├── newUI ├── manipulate_widget.js └── manipulate_widget.css ├── manipulateWidget.Rproj ├── appveyor.yml ├── DESCRIPTION ├── NAMESPACE ├── data-raw └── world_energy_use.R ├── NEWS.md └── README.Rmd /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | -------------------------------------------------------------------------------- /revdep/failures.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /revdep/problems.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | COPYRIGHT HOLDER: RTE Réseau de transport d’électricité 2 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(manipulateWidget) 3 | 4 | test_check("manipulateWidget") 5 | -------------------------------------------------------------------------------- /data/worldEnergyUse.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/data/worldEnergyUse.rda -------------------------------------------------------------------------------- /vignettes/comparison.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/vignettes/comparison.gif -------------------------------------------------------------------------------- /vignettes/fancy-example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/vignettes/fancy-example.gif -------------------------------------------------------------------------------- /vignettes/groups-inputs.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/vignettes/groups-inputs.gif -------------------------------------------------------------------------------- /vignettes/update-widget.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/vignettes/update-widget.gif -------------------------------------------------------------------------------- /vignettes/dynamic_inputs.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/vignettes/dynamic_inputs.gif -------------------------------------------------------------------------------- /vignettes/example-kmeans.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/vignettes/example-kmeans.gif -------------------------------------------------------------------------------- /vignettes/conditional-inputs.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/vignettes/conditional-inputs.gif -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | inst/doc 6 | revdep/checks/ 7 | revdep/data.sqlite 8 | revdep/library/ 9 | -------------------------------------------------------------------------------- /README_files/figure-gfm/plotevouse-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/README_files/figure-gfm/plotevouse-1.png -------------------------------------------------------------------------------- /README_files/figure-gfm/plotshareuse-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/README_files/figure-gfm/plotshareuse-1.png -------------------------------------------------------------------------------- /README_files/figure-gfm/combinewidgets-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rte-antares-rpackage/manipulateWidget/HEAD/README_files/figure-gfm/combinewidgets-1.png -------------------------------------------------------------------------------- /inst/htmlwidgets/combineWidgets.yaml: -------------------------------------------------------------------------------- 1 | #Copyright © 2016 RTE Réseau de transport d’électricité 2 | dependencies: 3 | - name: combineWidgetStyle 4 | version: 0.1 5 | src: htmlwidgets 6 | stylesheet: combineWidgets.css 7 | 8 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | README.rmd 4 | README.md 5 | img 6 | README_files 7 | ^appveyor\.yml$ 8 | ^\.travis\.yml$ 9 | ^codecov\.yml$ 10 | newUI 11 | ^inst/examples 12 | ^revdep$ 13 | ^cran-comments\.md$ 14 | ^data-raw 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | sudo: false 5 | cache: packages 6 | 7 | r_packages: 8 | - covr 9 | 10 | after_success: 11 | - Rscript -e 'covr::codecov()' 12 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Test environments 2 | * local OS X install, R 3.6.2 3 | * ubuntu 14.04 (on travis-ci), R 3.6.2 4 | * win-builder (devel and release) 5 | 6 | ## R CMD check results 7 | 8 | 0 errors | 0 warnings | 1 note 9 | 10 | * There's a new maintainer to the package. 11 | Thanks! 12 | -------------------------------------------------------------------------------- /inst/lib/export/Blob/README.md: -------------------------------------------------------------------------------- 1 | Blob.js 2 | ============== 3 | 4 | Blob.js implements the W3C [`Blob`][1] interface in browsers that do 5 | not natively support it. 6 | 7 | ![Tracking image](https://in.getclicky.com/212712ns.gif) 8 | 9 | [1]: https://developer.mozilla.org/en-US/docs/Web/API/Blob 10 | -------------------------------------------------------------------------------- /R/debug.R: -------------------------------------------------------------------------------- 1 | mwDebug <- function() { 2 | options(mwDebug = TRUE) 3 | } 4 | 5 | mwUndebug <- function() { 6 | options(mwDebug = FALSE) 7 | } 8 | 9 | mwDebugMode <- function() { 10 | res <- getOption("mwDebug") 11 | if (is.null(res)) res <- FALSE 12 | res 13 | } 14 | 15 | catIfDebug <- function(...) { 16 | if (mwDebugMode()) cat(..., "\n") 17 | } 18 | -------------------------------------------------------------------------------- /man/summary.MWController.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/controller.R 3 | \name{summary.MWController} 4 | \alias{summary.MWController} 5 | \title{summary method for MWController object} 6 | \usage{ 7 | \method{summary}{MWController}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{MWController object} 11 | 12 | \item{...}{Not use} 13 | } 14 | \description{ 15 | summary method for MWController object 16 | } 17 | -------------------------------------------------------------------------------- /man/knit_print.MWController.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/controller.R 3 | \name{knit_print.MWController} 4 | \alias{knit_print.MWController} 5 | \title{knit_print method for MWController object} 6 | \usage{ 7 | knit_print.MWController(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{MWController object} 11 | 12 | \item{...}{arguments passed to function knit_print} 13 | } 14 | \description{ 15 | knit_print method for MWController object 16 | } 17 | -------------------------------------------------------------------------------- /newUI/manipulate_widget.js: -------------------------------------------------------------------------------- 1 | $(".mw-btn-settings,.mw-btn-area") 2 | .click(select) 3 | .each(function(i) { 4 | $(this).data("index", i); 5 | }); 6 | 7 | function select(e) { 8 | var el = $(e.currentTarget); 9 | var active = el.hasClass("active"); 10 | $(".mw-btn-settings,.mw-btn-area").removeClass("active"); 11 | $(".mw-inputs").css("display", "none"); 12 | if (!active) { 13 | el.addClass("active"); 14 | var i = el.data("index"); 15 | $(".mw-inputs").eq(i).css("display", "block"); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /manipulateWidget.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --as-cran 22 | PackageRoxygenize: rd,collate,namespace 23 | -------------------------------------------------------------------------------- /R/on_done.R: -------------------------------------------------------------------------------- 1 | #' Function called when user clicks on the "Done" button. It stops the shiny 2 | #' gadget and returns the final htmlwidget 3 | #' 4 | #' @param .expr Expression that generates a htmlwidget 5 | #' @param controls Object created with function preprocessControls 6 | #' 7 | #' @return a htmlwidget 8 | #' @noRd 9 | onDone <- function(controller, stopApp = TRUE) { 10 | for (env in controller$envs$ind) { 11 | assign(".initial", TRUE, envir = env) 12 | assign(".session", NULL, envir = env) 13 | } 14 | controller$updateCharts() 15 | res <- controller$returnCharts() 16 | 17 | if (stopApp) shiny::stopApp(res) 18 | else return(res) 19 | } 20 | -------------------------------------------------------------------------------- /revdep/README.md: -------------------------------------------------------------------------------- 1 | # Platform 2 | 3 | |field |value | 4 | |:--------|:----------------------------| 5 | |version |R version 3.6.2 (2019-12-12) | 6 | |os |Windows 10 x64 | 7 | |system |x86_64, mingw32 | 8 | |ui |RStudio | 9 | |language |(EN) | 10 | |collate |French_France.1252 | 11 | |ctype |French_France.1252 | 12 | |tz |Europe/Berlin | 13 | |date |2020-02-24 | 14 | 15 | # Dependencies 16 | 17 | |package |old |new | | 18 | |:----------------|:------|:------|:--| 19 | |manipulateWidget |0.10.0 |0.10.1 |* | 20 | 21 | # Revdeps 22 | 23 | -------------------------------------------------------------------------------- /R/get_row_and_cols.R: -------------------------------------------------------------------------------- 1 | # Copyright © 2016 RTE Réseau de transport d’électricité 2 | 3 | # Private function that compute the "ideal" number of rows and columns given the 4 | # number of widgets to display. 5 | .getRowAndCols <- function(n, nrow = NULL, ncol = NULL) { 6 | if (!is.null(nrow) && !is.null(ncol) && nrow * ncol < n) { 7 | stop("There are too much widgets compared to the number of rows and columns") 8 | } else if (is.null(nrow) && !is.null(ncol)) { 9 | nrow <- ceiling(n / ncol) 10 | } else if (!is.null(nrow) && is.null(ncol)) { 11 | ncol <- ceiling(n / nrow) 12 | } else if (is.null(nrow) && is.null(ncol)) { 13 | nrow <- ceiling(sqrt(n)) 14 | ncol <- ceiling(n / nrow) 15 | } 16 | 17 | list(nrow = nrow, ncol = ncol, n = n) 18 | } 19 | -------------------------------------------------------------------------------- /inst/lib/export/canvas-toBlob/README.md: -------------------------------------------------------------------------------- 1 | canvas-toBlob.js 2 | ================ 3 | 4 | canvas-toBlob.js implements the standard HTML5 [`canvas.toBlob()`][1] and 5 | `canvas.toBlobHD()` methods in browsers that do not natively support it. canvas-toBlob.js 6 | requires `Blob` support to function, which is not present in all browsers. [Blob.js][2] 7 | is a cross-browser `Blob` implementation that solves this. 8 | 9 | Supported browsers 10 | ------------------ 11 | 12 | canvas-toBlob.js has [the same browser support as FileSaver.js][3]. 13 | 14 | ![Tracking image](https://in.getclicky.com/212712ns.gif) 15 | 16 | [1]: http://www.w3.org/TR/html5/the-canvas-element.html 17 | [2]: https://github.com/eligrey/Blob.js 18 | [3]: https://github.com/eligrey/FileSaver.js#supported-browsers -------------------------------------------------------------------------------- /tests/testthat/test-staticPlot.R: -------------------------------------------------------------------------------- 1 | context("Static plot & image") 2 | 3 | describe("Static plot & image", { 4 | it("returns a combineWidget with both static plot and image", { 5 | 6 | tmp_png <- tempfile(fileext = ".png") 7 | png(file = tmp_png, bg = "transparent") 8 | plot(1:10) 9 | dev.off() 10 | 11 | c <- combineWidgets( 12 | staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300), 13 | staticImage(tmp_png) 14 | ) 15 | 16 | expect_is(c, "combineWidgets") 17 | expect_length(c$widgets, 2) 18 | 19 | # # check saveWidget and so preRenderCombinedWidgets 20 | # tmp_html <- tempfile(fileext = ".html") 21 | # htmlwidgets::saveWidget(c, tmp_html) 22 | # expect_true(file.exists(tmp_html)) 23 | 24 | }) 25 | }) 26 | -------------------------------------------------------------------------------- /tests/testthat/test-mwModuleUI.R: -------------------------------------------------------------------------------- 1 | context("mwModuleUI function") 2 | 3 | describe("mwModuleUI function", { 4 | 5 | it("Correct mwModuleUI", { 6 | # missing id 7 | expect_error(mwModuleUI()) 8 | 9 | # default 10 | def_mw_ui <- mwModuleUI(id = "def") 11 | expect_is(def_mw_ui, "shiny.tag.list") 12 | expect_equal(def_mw_ui[[2]]$name, "div") 13 | expect_equal(def_mw_ui[[2]]$attribs$id, "def-ui") 14 | expect_true(grepl("border", def_mw_ui[[2]]$attribs$class)) 15 | 16 | # parameters 17 | def_mw_ui <- mwModuleUI(id = "def", border = FALSE) 18 | expect_false(grepl("border", def_mw_ui[[2]]$attribs$class)) 19 | 20 | def_mw_ui <- mwModuleUI(id = "def", height = "100%") 21 | expect_true(grepl("height:100%", def_mw_ui[[2]]$attribs$style)) 22 | }) 23 | }) 24 | -------------------------------------------------------------------------------- /tests/testthat/test-get_output_and_render_func.R: -------------------------------------------------------------------------------- 1 | context("getOutputAndRenderFunc") 2 | 3 | describe("getOutputAndRenderFunc", { 4 | if(require("leaflet")){ 5 | it ("returns output and render functions of a widget", { 6 | widget <- leaflet() 7 | res <- getOutputAndRenderFunc(widget) 8 | expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets")) 9 | expect_equal(res$outputFunc, leaflet::leafletOutput) 10 | expect_equal(res$renderFunc, leaflet::renderLeaflet) 11 | expect_equal(res$useCombineWidgets, FALSE) 12 | }) 13 | 14 | it ("returns combineWidgets output and render functions if x is not an htmlwidget", { 15 | res <- getOutputAndRenderFunc("test") 16 | expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets")) 17 | expect_equal(res$outputFunc, combineWidgetsOutput) 18 | expect_equal(res$renderFunc, renderCombineWidgets) 19 | expect_equal(res$useCombineWidgets, TRUE) 20 | }) 21 | } 22 | }) 23 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | 3 | # Download script file from GitHub 4 | init: 5 | ps: | 6 | $ErrorActionPreference = "Stop" 7 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 8 | Import-Module '..\appveyor-tool.ps1' 9 | 10 | install: 11 | ps: Bootstrap 12 | 13 | # Adapt as necessary starting from here 14 | 15 | build_script: 16 | - travis-tool.sh install_deps 17 | 18 | test_script: 19 | - travis-tool.sh run_tests 20 | 21 | on_failure: 22 | - 7z a failure.zip *.Rcheck\* 23 | - appveyor PushArtifact failure.zip 24 | 25 | artifacts: 26 | - path: '*.Rcheck\**\*.log' 27 | name: Logs 28 | 29 | - path: '*.Rcheck\**\*.out' 30 | name: Logs 31 | 32 | - path: '*.Rcheck\**\*.fail' 33 | name: Logs 34 | 35 | - path: '*.Rcheck\**\*.Rout' 36 | name: Logs 37 | 38 | - path: '\*_*.tar.gz' 39 | name: Bits 40 | 41 | - path: '\*_*.zip' 42 | name: Bits 43 | -------------------------------------------------------------------------------- /inst/lib/export/FileSaver/LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright © 2015 [Eli Grey][1]. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | 9 | [1]: http://eligrey.com 10 | -------------------------------------------------------------------------------- /inst/examples/example-reactive_values.R: -------------------------------------------------------------------------------- 1 | require(manipulateWidget) 2 | require(dygraphs) 3 | mydata <- data.frame( 4 | year = 2000+1:100, 5 | series1 = rnorm(100), 6 | series2 = rnorm(100), 7 | series3 = rnorm(100) 8 | ) 9 | 10 | 11 | 12 | ui <- fillPage( 13 | fillRow( 14 | flex = c(NA, 1), 15 | div( 16 | textInput("title", label = "Title", value = "glop"), 17 | selectInput("series", "series", choices = c("series1", "series2", "series3")) 18 | ), 19 | mwModuleUI("ui", height = "400px") 20 | ) 21 | ) 22 | 23 | Range = 2001 24 | server <- function(input, output, session) { 25 | 26 | c <- manipulateWidget( 27 | { 28 | dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title) 29 | }, 30 | range = mwSlider(Range, 2100, c(2010, 2050)), 31 | series = mwSharedValue(), 32 | title = mwSharedValue( 33 | {"init"} 34 | ), .runApp = FALSE, 35 | .compare = "range" 36 | ) 37 | 38 | titre <- reactive({ 39 | input$title 40 | }) 41 | 42 | mwModule("ui", c, title = titre, series = reactive(input$series)) 43 | } 44 | 45 | shinyApp(ui, server) 46 | -------------------------------------------------------------------------------- /R/get_output_and_render_func.R: -------------------------------------------------------------------------------- 1 | #' Private function that gets shiny output and render functions for a given htmlWidget 2 | #' 3 | #' @param x Object, generally a htmlwidget. 4 | #' 5 | #' @return A list with the following elements 6 | #' - outputFunc 7 | #' - renderFunc 8 | #' - useCombineWidgets TRUE only if x is not an htmlwidget 9 | #' @noRd 10 | getOutputAndRenderFunc <- function(x) { 11 | # Get shiny output and render functions 12 | if (inherits(x, "htmlwidget")) { 13 | cl <- class(x) 14 | pkg <- attr(x, "package") 15 | 16 | renderFunName <- ls(getNamespace(pkg), pattern = "^render") 17 | renderFunction <- getFromNamespace(renderFunName, pkg) 18 | 19 | outputFunName <- ls(getNamespace(pkg), pattern = "Output$") 20 | outputFunction <- getFromNamespace(outputFunName, pkg) 21 | useCombineWidgets <- FALSE 22 | } else { 23 | renderFunction <- renderCombineWidgets 24 | outputFunction <- combineWidgetsOutput 25 | useCombineWidgets <- TRUE 26 | } 27 | 28 | list( 29 | outputFunc = outputFunction, 30 | renderFunc = renderFunction, 31 | useCombineWidgets = useCombineWidgets 32 | ) 33 | } 34 | -------------------------------------------------------------------------------- /man/combineWidgets-shiny.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/combine_widgets.R 3 | \name{combineWidgets-shiny} 4 | \alias{combineWidgets-shiny} 5 | \alias{combineWidgetsOutput} 6 | \alias{renderCombineWidgets} 7 | \title{Shiny bindings for combineWidgets} 8 | \usage{ 9 | combineWidgetsOutput(outputId, width = "100\%", height = "400px") 10 | 11 | renderCombineWidgets(expr, env = parent.frame(), quoted = FALSE) 12 | } 13 | \arguments{ 14 | \item{outputId}{output variable to read from} 15 | 16 | \item{width, height}{Must be a valid CSS unit (like \code{'100\%'}, 17 | \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a 18 | string and have \code{'px'} appended.} 19 | 20 | \item{expr}{An expression that generates a combineWidgets} 21 | 22 | \item{env}{The environment in which to evaluate \code{expr}.} 23 | 24 | \item{quoted}{Is \code{expr} a quoted expression (with \code{quote()})? This 25 | is useful if you want to save an expression in a variable.} 26 | } 27 | \description{ 28 | Output and render functions for using combineWidgets within Shiny 29 | applications and interactive Rmd documents. 30 | } 31 | -------------------------------------------------------------------------------- /inst/lib/export/Blob/LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright © 2014 [Eli Grey][1]. 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | 25 | [1]: http://eligrey.com 26 | -------------------------------------------------------------------------------- /tests/testthat/test-input_class.R: -------------------------------------------------------------------------------- 1 | context("Input class") 2 | 3 | describe("Input", { 4 | inputTPL <- Input( 5 | type = "test", 6 | value = 0, 7 | params = list( 8 | min = expression(0), 9 | max = expression(10) 10 | ), 11 | display = expression(TRUE), 12 | validFunc = function(x, params) { 13 | min(max(params$min, x), params$max) 14 | }, 15 | htmlFunc = htmlFuncFactory(shiny::numericInput) 16 | ) 17 | 18 | # Basic check 19 | test_input(inputTPL$copy(), c(5, -20, 20), c(5, 0, 10)) 20 | 21 | it("correctly updates value when environment changes", { 22 | myInput <- inputTPL$copy() 23 | myInput$params$min <- expression(minx) 24 | 25 | env <- initEnv(parent.frame(), 1) 26 | assign("minx", 0, envir = env) 27 | myInput$init("x", env) 28 | expect_equal(myInput$value, 0) 29 | 30 | assign("minx", 5, envir = env) 31 | expect_equal(myInput$updateValue(), 5) 32 | expect_equal(myInput$value, 5) 33 | expect_equal(get("x", envir = env), 5) 34 | }) 35 | 36 | it("returns a valid ID (in a JS point of view)", { 37 | myInput <- inputTPL$copy() 38 | env <- initEnv(parent.frame(), 1) 39 | myInput$init("invalid.name", env) 40 | 41 | expect_equal(myInput$getID(), "output_1_invalid_name") 42 | }) 43 | 44 | }) 45 | -------------------------------------------------------------------------------- /tests/testthat/helper-input_class.R: -------------------------------------------------------------------------------- 1 | test_input <- function(input, values = NULL, expectedValues = NULL, name = "myInput") { 2 | describe(paste("input", input$type), { 3 | it ("is correctly initialized", { 4 | env <- initEnv(parent.frame(), 1) 5 | input$init(name, env) 6 | 7 | expect_initialized(input) 8 | expect_equal(input$env, env) 9 | expect_equal(input$label, name) 10 | if(!"call" %in% class(input$value)){ 11 | expect_equal(input$value, get(name, envir = env)) 12 | } else { 13 | expect_equal(evalValue(input$value, parent.frame()), get(name, envir = env)) 14 | } 15 | expect_is(input$params, "list") 16 | }) 17 | 18 | it ("sets valid values", { 19 | for (i in seq_along(values)) { 20 | input$setValue(values[[i]]) 21 | expect_equal(input$value, expectedValues[[i]]) 22 | expect_equal(get(name, envir = input$env), expectedValues[[i]]) 23 | } 24 | }) 25 | }) 26 | } 27 | 28 | expect_initialized <- function(input) { 29 | expect_is(input, "Input") 30 | expect(!emptyField(input$name) & !emptyField(input$env), "Input unitialized") 31 | } 32 | 33 | initAllInputs <- function(inputs, env) { 34 | sapply(names(inputs), function(n) { 35 | inputs[[n]]$init(n, env) 36 | inputs[[n]] 37 | }, simplify = FALSE, USE.NAMES = TRUE) 38 | } 39 | 40 | -------------------------------------------------------------------------------- /inst/lib/export/canvas-toBlob/LICENSE.md: -------------------------------------------------------------------------------- 1 | This software is licensed under the MIT license. 2 | 3 | MIT license 4 | ----------- 5 | 6 | Copyright © 2016 [Eli Grey][1] and [Devin Samarin][2]. 7 | 8 | Permission is hereby granted, free of charge, to any person 9 | obtaining a copy of this software and associated documentation 10 | files (the "Software"), to deal in the Software without 11 | restriction, including without limitation the rights to use, 12 | copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the 14 | Software is furnished to do so, subject to the following 15 | conditions: 16 | 17 | The above copyright notice and this permission notice shall be 18 | included in all copies or substantial portions of the Software. 19 | 20 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 21 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 22 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 23 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 24 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 25 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 27 | OTHER DEALINGS IN THE SOFTWARE. 28 | 29 | 30 | [1]: http://eligrey.com 31 | [2]: https://github.com/dsamarin 32 | -------------------------------------------------------------------------------- /inst/htmlwidgets/combineWidgets.css: -------------------------------------------------------------------------------- 1 | /* Copyright © 2016 RTE Réseau de transport d’électricité */ 2 | 3 | .cw-container { 4 | display: flex; 5 | display: -webkit-flex; 6 | flex-direction: column; 7 | -webkit-flex-direction: column; 8 | width: 100%; 9 | height: 100%; 10 | } 11 | 12 | .cw-subcontainer { 13 | flex:1; 14 | -webkit-flex:1; 15 | display: flex; 16 | display: -webkit-flex; 17 | flex-direction: row; 18 | -webkit-flex-direction: row; 19 | } 20 | 21 | .cw-title { 22 | text-align: center; 23 | margin: 5px 0; 24 | font-family: sans-serif; 25 | font-weight: normal; 26 | } 27 | 28 | .cw-content { 29 | flex:1; 30 | -webkit-flex:1; 31 | display: flex; 32 | display: -webkit-flex; 33 | flex-direction: column; 34 | -webkit-flex-direction: column; 35 | } 36 | 37 | .cw-content.cw-by-col { 38 | flex-direction: row; 39 | -webkit-flex-direction: row; 40 | } 41 | 42 | .cw-row { 43 | align-items: stretch; 44 | -webkit-align-items: stretch; 45 | display: flex; 46 | display: -webkit-flex; 47 | flex-direction: row; 48 | -webkit-flex-direction: row; 49 | } 50 | 51 | .cw-row.cw-by-col { 52 | flex-direction: column; 53 | -webkit-flex-direction: column; 54 | } 55 | 56 | .cw-col { 57 | align-items: stretch; 58 | -webkit-align-items: stretch; 59 | position: relative; 60 | margin:5px; 61 | } 62 | 63 | .cw-widget { 64 | width:100%; 65 | height:100%; 66 | position:absolute; 67 | } 68 | -------------------------------------------------------------------------------- /tests/testthat/test-on_done.R: -------------------------------------------------------------------------------- 1 | context("onDone") 2 | 3 | describe("onDone", { 4 | it ("stops the shiny gadget and returns a htmlwidget", { 5 | with_mock( 6 | `shiny::stopApp` = function(x) { 7 | print("Stop gadget") 8 | x 9 | }, 10 | { 11 | inputs <- initInputEnv(list(x1 = mwText("value1"), x2 = mwSelect(1:3))) 12 | expr <- expression(combineWidgets(paste(x1, x2))) 13 | controller <- MWController(expr, inputs)$init() 14 | 15 | expect_output(res <- onDone(controller), "Stop gadget") 16 | expect_is(res, "htmlwidget") 17 | expect_equal(length(res$widgets), 1) 18 | expect_equal(res$widgets[[1]], "value1 1") 19 | } 20 | ) 21 | }) 22 | 23 | it ("returns a combined widget if comparison", { 24 | suppressWarnings({with_mock( 25 | `shiny::stopApp` = function(x) { 26 | print("Stop gadget") 27 | x 28 | }, 29 | { 30 | compare <- list(x2 = list(1, 2, 3)) 31 | inputs <- initInputEnv(list(x1 = mwText("value1"), x2 = mwSelect(1:3)), 32 | compare = compare, ncharts = 3) 33 | expr <- expression(paste(x1, x2)) 34 | controller <- MWController(expr, inputs)$init() 35 | expect_output(res <- onDone(controller), "Stop gadget") 36 | expect_is(res, "combineWidgets") 37 | expect_equal(length(res$widgets), 3) 38 | for (i in 1:3) { 39 | expect_equal(res$widgets[[i]]$widgets[[1]], paste("value1", compare$x2[[i]])) 40 | } 41 | } 42 | )}) 43 | }) 44 | 45 | }) 46 | -------------------------------------------------------------------------------- /man/mwText.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwText} 4 | \alias{mwText} 5 | \title{Add a text input to a manipulateWidget gadget} 6 | \usage{ 7 | mwText(value = "", label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{value}{Initial value of the text input.} 11 | 12 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 13 | variable is used.} 14 | 15 | \item{...}{Other arguments passed to function\code{\link[shiny]{textInput}}} 16 | 17 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 18 | the input control should be shown/hidden.} 19 | } 20 | \value{ 21 | A function that will generate the input control. 22 | } 23 | \description{ 24 | Add a text input to a manipulateWidget gadget 25 | } 26 | \examples{ 27 | if (require(plotly)) { 28 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 29 | manipulateWidget({ 30 | plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = "markers") \%>\% 31 | layout(title = mytitle) 32 | }, 33 | mytitle = mwText("Awesome title !") 34 | ) 35 | } 36 | 37 | } 38 | \seealso{ 39 | Other controls: 40 | \code{\link{mwCheckboxGroup}()}, 41 | \code{\link{mwCheckbox}()}, 42 | \code{\link{mwDateRange}()}, 43 | \code{\link{mwDate}()}, 44 | \code{\link{mwGroup}()}, 45 | \code{\link{mwNumeric}()}, 46 | \code{\link{mwPassword}()}, 47 | \code{\link{mwRadio}()}, 48 | \code{\link{mwSelectize}()}, 49 | \code{\link{mwSelect}()}, 50 | \code{\link{mwSharedValue}()}, 51 | \code{\link{mwSlider}()} 52 | } 53 | \concept{controls} 54 | -------------------------------------------------------------------------------- /man/mwNumeric.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwNumeric} 4 | \alias{mwNumeric} 5 | \title{Add a numeric input to a manipulateWidget gadget} 6 | \usage{ 7 | mwNumeric(value, label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{value}{Initial value of the numeric input.} 11 | 12 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 13 | variable is used.} 14 | 15 | \item{...}{Other arguments passed to function\code{\link[shiny]{numericInput}}} 16 | 17 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 18 | the input control should be shown/hidden.} 19 | } 20 | \value{ 21 | A function that will generate the input control. 22 | } 23 | \description{ 24 | Add a numeric input to a manipulateWidget gadget 25 | } 26 | \examples{ 27 | 28 | if (require(plotly)) { 29 | manipulateWidget({ 30 | plot_ly(data.frame(x = 1:10, y = rnorm(10, mean, sd)), x=~x, y=~y, 31 | type = "scatter", mode = "markers") 32 | }, 33 | mean = mwNumeric(0), 34 | sd = mwNumeric(1, min = 0, step = 0.1) 35 | ) 36 | } 37 | 38 | } 39 | \seealso{ 40 | Other controls: 41 | \code{\link{mwCheckboxGroup}()}, 42 | \code{\link{mwCheckbox}()}, 43 | \code{\link{mwDateRange}()}, 44 | \code{\link{mwDate}()}, 45 | \code{\link{mwGroup}()}, 46 | \code{\link{mwPassword}()}, 47 | \code{\link{mwRadio}()}, 48 | \code{\link{mwSelectize}()}, 49 | \code{\link{mwSelect}()}, 50 | \code{\link{mwSharedValue}()}, 51 | \code{\link{mwSlider}()}, 52 | \code{\link{mwText}()} 53 | } 54 | \concept{controls} 55 | -------------------------------------------------------------------------------- /man/mwCheckbox.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwCheckbox} 4 | \alias{mwCheckbox} 5 | \title{Add a checkbox to a manipulateWidget gadget} 6 | \usage{ 7 | mwCheckbox(value = FALSE, label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{value}{Initial value of the input.} 11 | 12 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 13 | variable is used.} 14 | 15 | \item{...}{Other arguments passed to function\code{\link[shiny]{checkboxInput}}} 16 | 17 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 18 | the input control should be shown/hidden.} 19 | } 20 | \value{ 21 | A function that will generate the input control. 22 | } 23 | \description{ 24 | Add a checkbox to a manipulateWidget gadget 25 | } 26 | \examples{ 27 | 28 | if(require(plotly)) { 29 | manipulateWidget( 30 | { 31 | plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width, 32 | color = ~Species, type = "scatter", mode = "markers") \%>\% 33 | layout(showlegend = legend) 34 | }, 35 | legend = mwCheckbox(TRUE, "Show legend") 36 | ) 37 | } 38 | 39 | } 40 | \seealso{ 41 | Other controls: 42 | \code{\link{mwCheckboxGroup}()}, 43 | \code{\link{mwDateRange}()}, 44 | \code{\link{mwDate}()}, 45 | \code{\link{mwGroup}()}, 46 | \code{\link{mwNumeric}()}, 47 | \code{\link{mwPassword}()}, 48 | \code{\link{mwRadio}()}, 49 | \code{\link{mwSelectize}()}, 50 | \code{\link{mwSelect}()}, 51 | \code{\link{mwSharedValue}()}, 52 | \code{\link{mwSlider}()}, 53 | \code{\link{mwText}()} 54 | } 55 | \concept{controls} 56 | -------------------------------------------------------------------------------- /man/mwGroup.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwGroup} 4 | \alias{mwGroup} 5 | \title{Group inputs in a collapsible box} 6 | \usage{ 7 | mwGroup(..., label = NULL, .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{...}{inputs that will be grouped in the box} 11 | 12 | \item{label}{label of the group inputs} 13 | 14 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 15 | the group should be shown/hidden.} 16 | } 17 | \value{ 18 | Input of type "group". 19 | } 20 | \description{ 21 | This function generates a collapsible box containing inputs. It can be useful 22 | when there are a lot of inputs and one wants to group them. 23 | } 24 | \examples{ 25 | if(require(dygraphs)) { 26 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 27 | manipulateWidget( 28 | dygraph(mydata[range[1]:range[2], ], 29 | main = title, xlab = xlab, ylab = ylab), 30 | range = mwSlider(1, 100, c(1, 100)), 31 | "Graphical parameters" = mwGroup( 32 | title = mwText("Fictive time series"), 33 | xlab = mwText("X axis label"), 34 | ylab = mwText("Y axis label") 35 | ) 36 | ) 37 | } 38 | 39 | } 40 | \seealso{ 41 | Other controls: 42 | \code{\link{mwCheckboxGroup}()}, 43 | \code{\link{mwCheckbox}()}, 44 | \code{\link{mwDateRange}()}, 45 | \code{\link{mwDate}()}, 46 | \code{\link{mwNumeric}()}, 47 | \code{\link{mwPassword}()}, 48 | \code{\link{mwRadio}()}, 49 | \code{\link{mwSelectize}()}, 50 | \code{\link{mwSelect}()}, 51 | \code{\link{mwSharedValue}()}, 52 | \code{\link{mwSlider}()}, 53 | \code{\link{mwText}()} 54 | } 55 | \concept{controls} 56 | -------------------------------------------------------------------------------- /inst/examples/example-mwSharedValue.R: -------------------------------------------------------------------------------- 1 | controller <- manipulateWidget( 2 | { 3 | dygraph(data[range[1]:range[2] - 2000, c("year", series)], main = title) 4 | }, 5 | data = mwSharedValue(), 6 | title = mwSharedValue(), 7 | range = mwSlider(min = 2010, 8 | max = 2001 + (nrow(data)-1), c(2001, 2001 + (nrow(data)-1))), 9 | series = mwSelect(choices = colnames(data)[-1], 10 | value = {colnames(data)[3]}, .display = TRUE), 11 | .compare = c("series"), 12 | .runApp = FALSE 13 | ) 14 | 15 | library(dygraphs) 16 | ui <- fillPage( 17 | fillRow( 18 | flex = c(NA, 1), 19 | div( 20 | textInput("title", label = "Title", value = "glop"), 21 | sliderInput("obs", "Number of observations:", 22 | min = 10, max = 1000, value = 500) 23 | ), 24 | mwModuleUI("mw", height = "100%") 25 | ) 26 | ) 27 | 28 | server <- function(input, output, session) { 29 | data <- reactive({ 30 | if(runif(1) > 0.5){ 31 | data.frame( 32 | year = 2000+1:input$obs, 33 | series1 = rnorm(input$obs), 34 | series2 = rnorm(input$obs), 35 | series3 = rnorm(input$obs) 36 | ) 37 | } else { 38 | data.frame( 39 | year = 2000+1:input$obs, 40 | series1 = rnorm(input$obs), 41 | series2 = rnorm(input$obs) 42 | ) 43 | } 44 | }) 45 | 46 | ctrl <- mwModule("mw", controller, data = data, title = reactive(input$title)) 47 | 48 | observeEvent(input$obs, { 49 | ctrl$setValueAll("range", c(2001, 2001 + (nrow(data())-1))) 50 | }, ignoreInit = TRUE) 51 | } 52 | shinyApp(ui, server) 53 | -------------------------------------------------------------------------------- /man/mwDate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwDate} 4 | \alias{mwDate} 5 | \title{Add a date picker to a manipulateWidget gadget} 6 | \usage{ 7 | mwDate(value = NULL, label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{value}{Default value of the input.} 11 | 12 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 13 | variable is used.} 14 | 15 | \item{...}{Other arguments passed to function\code{\link[shiny]{dateInput}}} 16 | 17 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 18 | the input control should be shown/hidden.} 19 | } 20 | \value{ 21 | A function that will generate the input control. 22 | } 23 | \description{ 24 | Add a date picker to a manipulateWidget gadget 25 | } 26 | \examples{ 27 | if (require(dygraphs) && require(xts)) { 28 | mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364) 29 | 30 | manipulateWidget( 31 | dygraph(mydata) \%>\% dyEvent(date, "Your birthday"), 32 | date = mwDate("2017-03-27", label = "Your birthday date", 33 | min = "2017-01-01", max = "2017-12-31") 34 | ) 35 | } 36 | 37 | } 38 | \seealso{ 39 | Other controls: 40 | \code{\link{mwCheckboxGroup}()}, 41 | \code{\link{mwCheckbox}()}, 42 | \code{\link{mwDateRange}()}, 43 | \code{\link{mwGroup}()}, 44 | \code{\link{mwNumeric}()}, 45 | \code{\link{mwPassword}()}, 46 | \code{\link{mwRadio}()}, 47 | \code{\link{mwSelectize}()}, 48 | \code{\link{mwSelect}()}, 49 | \code{\link{mwSharedValue}()}, 50 | \code{\link{mwSlider}()}, 51 | \code{\link{mwText}()} 52 | } 53 | \concept{controls} 54 | -------------------------------------------------------------------------------- /inst/manipulate_widget/manipulate_widget.js: -------------------------------------------------------------------------------- 1 | function select(el, id) { 2 | el = $(el); 3 | var active = el.hasClass("active"); 4 | $(".mw-btn-settings,.mw-btn-area").removeClass("active"); 5 | if (!active) { 6 | el.addClass("active"); 7 | } 8 | } 9 | 10 | function resizeAllWidgets() { 11 | if (!window.HTMLWidgets) {return} 12 | var widgets = HTMLWidgets.findAll(document, ".mw-chart>.html-widget"); 13 | var ids = $.map($(".mw-chart>.html-widget"), function(x, i) {return x.id}); 14 | var container; 15 | if (widgets) { 16 | for (var i = 0; i < widgets.length; i++) { 17 | container = document.getElementById(ids[i]); 18 | if (widgets[i]) { 19 | HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]); 20 | } 21 | } 22 | } 23 | } 24 | 25 | function saveAsPNG(id){ 26 | var chart_area = document.getElementsByClassName(id); 27 | if(chart_area[0]){ 28 | html2canvas(chart_area[0], { 29 | background :'#FFFFFF', 30 | useCORS : true} 31 | ).then( 32 | function(canvas) { 33 | canvas.toBlobHD(function(blob) { 34 | saveAs(blob, "mw-export"); 35 | }, "image/png"); 36 | } 37 | ); 38 | } 39 | } 40 | 41 | var observer = new MutationObserver(function(mutations) { 42 | mutations.forEach(function(mutationRecord) { 43 | resizeAllWidgets(); 44 | }); 45 | }); 46 | 47 | document.onreadystatechange = function() { 48 | var target = document.getElementsByClassName('mw-input-container'); 49 | for (var i = 0; i < target.length; i++) { 50 | observer.observe(target[i], { attributes : true, attributeFilter : ['style'] }); 51 | } 52 | }; 53 | -------------------------------------------------------------------------------- /man/mwTranslations.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/translations.R 3 | \name{mwTranslations} 4 | \alias{mwTranslations} 5 | \title{Translate UI titles and labels} 6 | \usage{ 7 | mwTranslations( 8 | settings = "Settings", 9 | chart = "Chart", 10 | compare = "Compare", 11 | compareVars = "Variables to compare", 12 | ncol = "Nb Columns", 13 | ncharts = "Nb Charts" 14 | ) 15 | } 16 | \arguments{ 17 | \item{settings}{Title of the settings panel.} 18 | 19 | \item{chart}{Title of the chart panel.} 20 | 21 | \item{compare}{Label of the checkbox that activate the comparison mode.} 22 | 23 | \item{compareVars}{Label of the input containing the list of variables to compare.} 24 | 25 | \item{ncol}{Label of the input that sets the number of columns.} 26 | 27 | \item{ncharts}{Label of the input that sets the number of charts.} 28 | } 29 | \value{ 30 | Named list of translation strings. 31 | } 32 | \description{ 33 | Creates a list of translation strings that can be passed to function 34 | \code{\link{manipulateWidget}} to translate some UI elements. 35 | } 36 | \examples{ 37 | translations <- mwTranslations( 38 | settings = "Parametres", chart = "Graphique", compare = "Comparaison", 39 | compareVars = "Variable de comparaison", ncharts = "Nb graph.", ncol = "Nb col." 40 | ) 41 | 42 | if (require(dygraphs)) { 43 | mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) 44 | manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), 45 | range = mwSlider(2001, 2100, c(2001, 2100)), 46 | title = mwText("Fictive time series"), 47 | .translations = translations) 48 | } 49 | 50 | } 51 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: manipulateWidget 2 | Type: Package 3 | Title: Add Even More Interactivity to Interactive Charts 4 | Version: 0.11.1 5 | Authors@R: c( 6 | person("Veronique", "Bachelier", email = "veronique.bachelier@rte-france.com", role = c("aut", "cre")), 7 | person("Jalal-Edine", "ZAWAM", role = "aut"), 8 | person("Francois", "Guillem", role = "aut"), 9 | person("RTE", role = "cph"), 10 | person("JJ", "Allaire", role = "ctb"), 11 | person("Marion", "Praz", email="mnpraz@gmail.com", role = "ctb", comment = "New user interface"), 12 | person("Benoit", "Thieurmel", role = "ctb", email = "benoit.thieurmel@datastorm.fr"), 13 | person(given = "Titouan", family = "Robert", email = "titouan.robert@datastorm.fr", role = "ctb"), 14 | person("Duncan", "Murdoch", email = "murdoch.duncan@gmail.com", role = "ctb") 15 | ) 16 | Description: Like package 'manipulate' does for static graphics, this package 17 | helps to easily add controls like sliders, pickers, checkboxes, etc. that 18 | can be used to modify the input data or the parameters of an interactive 19 | chart created with package 'htmlwidgets'. 20 | URL: https://github.com/rte-antares-rpackage/manipulateWidget 21 | License: GPL (>= 2) | file LICENSE 22 | Depends: 23 | R (>= 2.10) 24 | Imports: 25 | shiny (>= 1.0.3), 26 | miniUI, 27 | htmltools, 28 | htmlwidgets, 29 | knitr, 30 | methods, 31 | tools, 32 | base64enc, 33 | grDevices, 34 | codetools, 35 | webshot, 36 | shinyjs 37 | Suggests: 38 | dygraphs, 39 | leaflet, 40 | plotly, 41 | xts, 42 | rmarkdown, 43 | testthat, 44 | covr 45 | LazyData: TRUE 46 | RoxygenNote: 7.1.1 47 | VignetteBuilder: knitr 48 | Encoding: UTF-8 49 | -------------------------------------------------------------------------------- /R/shiny_module.R: -------------------------------------------------------------------------------- 1 | mwModuleServer <- function(input, output, session, ctrl, ...) { 2 | ns <- session$ns 3 | 4 | ctrl <- ctrl$clone() 5 | 6 | reactiveValueList <- list(...) 7 | 8 | # If no reactive value, start immediately module. 9 | # Else delay start until outer inputs are initialized. 10 | if (length(reactiveValueList) == 0) startModule(ctrl) 11 | else { 12 | moduleStarted <- FALSE 13 | 14 | observe({ 15 | for (n in names(reactiveValueList)) { 16 | ctrl$setValue(n, reactiveValueList[[n]](), reactive = TRUE) 17 | } 18 | if (!moduleStarted) { 19 | startModule(ctrl) 20 | moduleStarted <<- TRUE 21 | } 22 | }) 23 | } 24 | 25 | return(ctrl) 26 | } 27 | 28 | startModule <- function(ctrl) { 29 | ctrl$init() 30 | 31 | dim <- callModule(inputAreaModuleServer, "inputarea", chartId, ctrl) 32 | 33 | ncharts <- reactive(dim$n) 34 | nrow <- reactive(dim$nrow) 35 | ncol <- reactive(dim$ncol) 36 | displayIndBtns <- reactive(dim$displayIndBtns) 37 | 38 | shinyGridEnv <- callModule(gridModuleServer, "grid", dim = dim, ctrl = ctrl) 39 | 40 | ctrl$setShinySession(shinyGridEnv$output, shinyGridEnv$session) 41 | 42 | menuState <- callModule(menuModuleServer, "menu", ncharts, nrow, ncol, displayIndBtns, ctrl) 43 | 44 | chartId <- reactive(menuState()$chartId) 45 | 46 | observe({ 47 | req(dim$n) 48 | ctrl$setChartNumber(dim$n, dim$nrow, dim$ncol) 49 | }) 50 | 51 | observeEvent( 52 | menuState()$done, 53 | onDone(ctrl) 54 | ) 55 | 56 | observeEvent( 57 | menuState()$update, 58 | { 59 | if(!is.null(menuState()$update) && menuState()$update > 0){ 60 | ctrl$updateCharts() 61 | } 62 | } 63 | ) 64 | } 65 | -------------------------------------------------------------------------------- /R/translations.R: -------------------------------------------------------------------------------- 1 | #' Translate UI titles and labels 2 | #' 3 | #' Creates a list of translation strings that can be passed to function 4 | #' \code{\link{manipulateWidget}} to translate some UI elements. 5 | #' 6 | #' @param settings Title of the settings panel. 7 | #' @param chart Title of the chart panel. 8 | #' @param compare Label of the checkbox that activate the comparison mode. 9 | #' @param compareVars Label of the input containing the list of variables to compare. 10 | #' @param ncol Label of the input that sets the number of columns. 11 | #' @param ncharts Label of the input that sets the number of charts. 12 | #' 13 | #' @return 14 | #' Named list of translation strings. 15 | #' 16 | #' @examples 17 | #' translations <- mwTranslations( 18 | #' settings = "Parametres", chart = "Graphique", compare = "Comparaison", 19 | #' compareVars = "Variable de comparaison", ncharts = "Nb graph.", ncol = "Nb col." 20 | #' ) 21 | #' 22 | #' if (require(dygraphs)) { 23 | #' mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) 24 | #' manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), 25 | #' range = mwSlider(2001, 2100, c(2001, 2100)), 26 | #' title = mwText("Fictive time series"), 27 | #' .translations = translations) 28 | #' } 29 | #' 30 | #' @export 31 | #' 32 | mwTranslations <- function(settings = "Settings", chart = "Chart", 33 | compare = "Compare", 34 | compareVars = "Variables to compare", 35 | ncol = "Nb Columns", ncharts = "Nb Charts") { 36 | list( 37 | settings = settings, 38 | chart = chart, 39 | compare = compare, 40 | compareVars = compareVars, 41 | ncol = ncol, 42 | ncharts = ncharts 43 | ) 44 | } 45 | -------------------------------------------------------------------------------- /man/worldEnergyUse.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/zzz.R 3 | \docType{data} 4 | \name{worldEnergyUse} 5 | \alias{worldEnergyUse} 6 | \title{Evolution of energy use per country} 7 | \format{ 8 | An object of class \code{data.frame} with 9375 rows and 15 columns. 9 | } 10 | \usage{ 11 | worldEnergyUse 12 | } 13 | \description{ 14 | Data.frame containing energy consumption per country from 1960 to 2014. The 15 | data comes from the World Bank website. It contains one line per 16 | couple(country, year) and has the following columns: 17 | } 18 | \details{ 19 | \itemize{ 20 | \item country Country name 21 | \item iso2c Country code in two characters 22 | \item year Year 23 | \item population Population of the country 24 | \item energy_used_per_capita Energy used per capita in kg of oil equivalent (EG.USE.PCAP.KG.OE) 25 | \item energy_imported_prop Proportion of energy used that has been imported (EG.IMP.CONS.ZS) 26 | \item energy_fossil_prop Fossil fuel energy consumption in proportion of total consumption (EG.USE.COMM.FO.ZS) 27 | \item energy_used Energy consumption in kg of oil equivalent 28 | \item energy_fossil Fossil fuel energy consumption in kg of oil equivalent 29 | \item prop_world_energy_used Share of the country in the world energy consumption 30 | \item prop_world_energy_fossil Share of the country in the world fossil energy consumption 31 | \item prop_world_population Share of the country in the world population 32 | \item long Longitude of the country 33 | \item lat Lattitude of the country 34 | \item region Region of the country 35 | } 36 | } 37 | \references{ 38 | \url{https://data.worldbank.org/indicator} 39 | } 40 | \author{ 41 | François Guillem \email{guillem.francois@gmail.com} 42 | } 43 | \keyword{datasets} 44 | -------------------------------------------------------------------------------- /man/mwPassword.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwPassword} 4 | \alias{mwPassword} 5 | \title{Add a password to a manipulateWidget gadget} 6 | \usage{ 7 | mwPassword(value = "", label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{value}{Default value of the input.} 11 | 12 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 13 | variable is used.} 14 | 15 | \item{...}{Other arguments passed to function\code{\link[shiny]{passwordInput}}} 16 | 17 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 18 | the input control should be shown/hidden.} 19 | } 20 | \value{ 21 | A function that will generate the input control. 22 | } 23 | \description{ 24 | Add a password to a manipulateWidget gadget 25 | } 26 | \examples{ 27 | if (require(plotly)) { 28 | manipulateWidget( 29 | { 30 | if (passwd != 'abc123') { 31 | plot_ly(type = "scatter", mode="markers") \%>\% 32 | layout(title = "Wrong password. True password is 'abc123'") 33 | } else { 34 | plot_ly(data.frame(x = 1:10, y = rnorm(10)), x=~x, y=~y, type = "scatter", mode = "markers") 35 | } 36 | }, 37 | user = mwText(label = "Username"), 38 | passwd = mwPassword(label = "Password") 39 | ) 40 | } 41 | 42 | } 43 | \seealso{ 44 | Other controls: 45 | \code{\link{mwCheckboxGroup}()}, 46 | \code{\link{mwCheckbox}()}, 47 | \code{\link{mwDateRange}()}, 48 | \code{\link{mwDate}()}, 49 | \code{\link{mwGroup}()}, 50 | \code{\link{mwNumeric}()}, 51 | \code{\link{mwRadio}()}, 52 | \code{\link{mwSelectize}()}, 53 | \code{\link{mwSelect}()}, 54 | \code{\link{mwSharedValue}()}, 55 | \code{\link{mwSlider}()}, 56 | \code{\link{mwText}()} 57 | } 58 | \concept{controls} 59 | -------------------------------------------------------------------------------- /man/mwDateRange.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwDateRange} 4 | \alias{mwDateRange} 5 | \title{Add a date range picker to a manipulateWidget gadget} 6 | \usage{ 7 | mwDateRange( 8 | value = c(Sys.Date(), Sys.Date() + 1), 9 | label = NULL, 10 | ..., 11 | .display = TRUE 12 | ) 13 | } 14 | \arguments{ 15 | \item{value}{Vector containing two dates (either Date objects pr a string in yyy-mm-dd 16 | format) representing the initial date range selected.} 17 | 18 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 19 | variable is used.} 20 | 21 | \item{...}{Other arguments passed to function\code{\link[shiny]{dateRangeInput}}} 22 | 23 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 24 | the input control should be shown/hidden.} 25 | } 26 | \value{ 27 | An Input object 28 | } 29 | \description{ 30 | Add a date range picker to a manipulateWidget gadget 31 | } 32 | \examples{ 33 | if (require(dygraphs) && require(xts)) { 34 | mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364) 35 | 36 | manipulateWidget( 37 | dygraph(mydata) \%>\% dyShading(from=period[1], to = period[2], color = "#CCEBD6"), 38 | period = mwDateRange(c("2017-03-01", "2017-04-01"), 39 | min = "2017-01-01", max = "2017-12-31") 40 | ) 41 | } 42 | 43 | } 44 | \seealso{ 45 | Other controls: 46 | \code{\link{mwCheckboxGroup}()}, 47 | \code{\link{mwCheckbox}()}, 48 | \code{\link{mwDate}()}, 49 | \code{\link{mwGroup}()}, 50 | \code{\link{mwNumeric}()}, 51 | \code{\link{mwPassword}()}, 52 | \code{\link{mwRadio}()}, 53 | \code{\link{mwSelectize}()}, 54 | \code{\link{mwSelect}()}, 55 | \code{\link{mwSharedValue}()}, 56 | \code{\link{mwSlider}()}, 57 | \code{\link{mwText}()} 58 | } 59 | \concept{controls} 60 | -------------------------------------------------------------------------------- /man/staticPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/static_image.R 3 | \name{staticPlot} 4 | \alias{staticPlot} 5 | \alias{staticImage} 6 | \title{Include a static image in a combinedWidgets} 7 | \usage{ 8 | staticPlot(expr, width = 600, height = 400) 9 | 10 | staticImage(file, style = "max-width:100\%\%;max-height:100\%\%") 11 | } 12 | \arguments{ 13 | \item{expr}{Expression that creates a static plot.} 14 | 15 | \item{width}{Width of the image to create.} 16 | 17 | \item{height}{Height of the image to create.} 18 | 19 | \item{file}{path of the image to include.} 20 | 21 | \item{style}{CSS style to apply to the image.} 22 | } 23 | \value{ 24 | a \code{shiny.tag} object containing the HTML code required to include 25 | the image or the plot in a \code{combinedWidgets} object. 26 | } 27 | \description{ 28 | \code{staticPlot} is a function that generates a static plot and then return 29 | the HTML code needed to include the plot in a combinedWidgets. 30 | \code{staticImage} is a more general function that generates the HTML code 31 | necessary to include any image file. 32 | } 33 | \examples{ 34 | staticPlot(hist(rnorm(100))) 35 | 36 | if (require(plotly)) { 37 | data(iris) 38 | 39 | combineWidgets( 40 | plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 41 | staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300) 42 | ) 43 | 44 | # You can also embed static images in the header, footer, left or right 45 | # columns of a combinedWidgets. The advantage is that the space allocated 46 | # to the static plot will be constant when the window is resized. 47 | 48 | combineWidgets( 49 | plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 50 | footer = staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300) 51 | ) 52 | } 53 | 54 | } 55 | -------------------------------------------------------------------------------- /man/mwRadio.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwRadio} 4 | \alias{mwRadio} 5 | \title{Add radio buttons to a manipulateWidget gadget} 6 | \usage{ 7 | mwRadio(choices, value = NULL, label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{choices}{Vector or list of choices. If it is named, then the names rather than the 11 | values are displayed to the user.} 12 | 13 | \item{value}{Initial value of the input. If not specified, the first choice is used.} 14 | 15 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 16 | variable is used.} 17 | 18 | \item{...}{Other arguments passed to function\code{\link[shiny]{radioButtons}}} 19 | 20 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 21 | the input control should be shown/hidden.} 22 | } 23 | \value{ 24 | A function that will generate the input control. 25 | } 26 | \description{ 27 | Add radio buttons to a manipulateWidget gadget 28 | } 29 | \examples{ 30 | if (require(plotly)) { 31 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 32 | 33 | manipulateWidget( 34 | { 35 | mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines") 36 | plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode) 37 | }, 38 | type = mwRadio(c("points", "lines", "both")) 39 | ) 40 | } 41 | 42 | } 43 | \seealso{ 44 | Other controls: 45 | \code{\link{mwCheckboxGroup}()}, 46 | \code{\link{mwCheckbox}()}, 47 | \code{\link{mwDateRange}()}, 48 | \code{\link{mwDate}()}, 49 | \code{\link{mwGroup}()}, 50 | \code{\link{mwNumeric}()}, 51 | \code{\link{mwPassword}()}, 52 | \code{\link{mwSelectize}()}, 53 | \code{\link{mwSelect}()}, 54 | \code{\link{mwSharedValue}()}, 55 | \code{\link{mwSlider}()}, 56 | \code{\link{mwText}()} 57 | } 58 | \concept{controls} 59 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(summary,MWController) 4 | export(combineWidgets) 5 | export(combineWidgetsOutput) 6 | export(compareOptions) 7 | export(knit_print.MWController) 8 | export(manipulateWidget) 9 | export(mwCheckbox) 10 | export(mwCheckboxGroup) 11 | export(mwDate) 12 | export(mwDateRange) 13 | export(mwGroup) 14 | export(mwModule) 15 | export(mwModuleUI) 16 | export(mwNumeric) 17 | export(mwPassword) 18 | export(mwRadio) 19 | export(mwSelect) 20 | export(mwSelectize) 21 | export(mwSharedValue) 22 | export(mwSlider) 23 | export(mwText) 24 | export(mwTranslations) 25 | export(renderCombineWidgets) 26 | export(staticImage) 27 | export(staticPlot) 28 | exportClasses(MWController) 29 | importFrom(grDevices,dev.off) 30 | importFrom(grDevices,png) 31 | importFrom(htmltools,tagGetAttribute) 32 | importFrom(htmlwidgets,getDependency) 33 | importFrom(methods,is) 34 | importFrom(methods,new) 35 | importFrom(methods,setRefClass) 36 | importFrom(miniUI,gadgetTitleBar) 37 | importFrom(miniUI,miniContentPanel) 38 | importFrom(miniUI,miniPage) 39 | importFrom(miniUI,miniTabPanel) 40 | importFrom(miniUI,miniTabstripPanel) 41 | importFrom(shiny,NS) 42 | importFrom(shiny,callModule) 43 | importFrom(shiny,checkboxInput) 44 | importFrom(shiny,fillPage) 45 | importFrom(shiny,fillRow) 46 | importFrom(shiny,icon) 47 | importFrom(shiny,isolate) 48 | importFrom(shiny,observe) 49 | importFrom(shiny,observeEvent) 50 | importFrom(shiny,reactive) 51 | importFrom(shiny,reactiveVal) 52 | importFrom(shiny,reactiveValues) 53 | importFrom(shiny,renderUI) 54 | importFrom(shiny,req) 55 | importFrom(shiny,tagAppendChild) 56 | importFrom(shiny,tagAppendChildren) 57 | importFrom(shiny,tags) 58 | importFrom(shiny,uiOutput) 59 | importFrom(shiny,updateSelectInput) 60 | importFrom(shiny,updateTextInput) 61 | importFrom(stats,runif) 62 | importFrom(utils,getFromNamespace) 63 | -------------------------------------------------------------------------------- /man/mwCheckboxGroup.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwCheckboxGroup} 4 | \alias{mwCheckboxGroup} 5 | \title{Add a group of checkboxes to a manipulateWidget gadget} 6 | \usage{ 7 | mwCheckboxGroup(choices, value = c(), label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{choices}{Vector or list of choices. If it is named, then the names rather than the 11 | values are displayed to the user.} 12 | 13 | \item{value}{Vector containing the values initially selected} 14 | 15 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 16 | variable is used.} 17 | 18 | \item{...}{Other arguments passed to function\code{\link[shiny]{checkboxGroupInput}}} 19 | 20 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 21 | the input control should be shown/hidden.} 22 | } 23 | \value{ 24 | A function that will generate the input control. 25 | } 26 | \description{ 27 | Add a group of checkboxes to a manipulateWidget gadget 28 | } 29 | \examples{ 30 | if (require(plotly)) { 31 | manipulateWidget( 32 | { 33 | if (length(species) == 0) mydata <- iris 34 | else mydata <- iris[iris$Species \%in\% species,] 35 | 36 | plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width, 37 | color = ~droplevels(Species), type = "scatter", mode = "markers") 38 | }, 39 | species = mwCheckboxGroup(levels(iris$Species)) 40 | ) 41 | } 42 | 43 | } 44 | \seealso{ 45 | Other controls: 46 | \code{\link{mwCheckbox}()}, 47 | \code{\link{mwDateRange}()}, 48 | \code{\link{mwDate}()}, 49 | \code{\link{mwGroup}()}, 50 | \code{\link{mwNumeric}()}, 51 | \code{\link{mwPassword}()}, 52 | \code{\link{mwRadio}()}, 53 | \code{\link{mwSelectize}()}, 54 | \code{\link{mwSelect}()}, 55 | \code{\link{mwSharedValue}()}, 56 | \code{\link{mwSlider}()}, 57 | \code{\link{mwText}()} 58 | } 59 | \concept{controls} 60 | -------------------------------------------------------------------------------- /man/compareOptions.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/compare_options.R 3 | \name{compareOptions} 4 | \alias{compareOptions} 5 | \title{Options for comparison mode} 6 | \usage{ 7 | compareOptions(ncharts = NULL, nrow = NULL, ncol = NULL, allowCompare = TRUE) 8 | } 9 | \arguments{ 10 | \item{ncharts}{Number of charts to generate.} 11 | 12 | \item{nrow}{Number of rows. If \code{NULL}, the function tries to pick the 13 | best number of rows given the number of charts and columns.} 14 | 15 | \item{ncol}{Number of columns. If \code{NULL}, the function tries to pick the 16 | best number of columns given the number of charts and rows.} 17 | 18 | \item{allowCompare}{If \code{TRUE} (the default), then the user can use the 19 | UI to add or remove charts and choose which variables to compare} 20 | } 21 | \value{ 22 | List of options 23 | } 24 | \description{ 25 | This function generates a list of options that are used by 26 | \code{\link{manipulateWidget}} to compare multiple charts. 27 | } 28 | \examples{ 29 | if (require(dygraphs)) { 30 | 31 | mydata <- data.frame( 32 | year = 2000+1:100, 33 | series1 = rnorm(100), 34 | series2 = rnorm(100), 35 | series3 = rnorm(100) 36 | ) 37 | manipulateWidget( 38 | dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), 39 | range = mwSlider(2001, 2100, c(2001, 2100)), 40 | series = mwSelect(c("series1", "series2", "series3")), 41 | title = mwText("Fictive time series"), 42 | .compare = list(title = NULL, series = NULL), 43 | .compareOpts = compareOptions(ncharts = 4) 44 | ) 45 | 46 | manipulateWidget( 47 | dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), 48 | range = mwSlider(2001, 2100, c(2001, 2100)), 49 | series = mwSelect(c("series1", "series2", "series3")), 50 | title = mwText("Fictive time series"), 51 | .compare = list(title = NULL, series = NULL), 52 | .compareOpts = compareOptions(ncharts = 3, nrow = 3) 53 | ) 54 | } 55 | 56 | } 57 | -------------------------------------------------------------------------------- /R/compare_options.R: -------------------------------------------------------------------------------- 1 | #' Options for comparison mode 2 | #' 3 | #' This function generates a list of options that are used by 4 | #' \code{\link{manipulateWidget}} to compare multiple charts. 5 | #' 6 | #' @param ncharts Number of charts to generate. 7 | #' @param nrow Number of rows. If \code{NULL}, the function tries to pick the 8 | #' best number of rows given the number of charts and columns. 9 | #' @param ncol Number of columns. If \code{NULL}, the function tries to pick the 10 | #' best number of columns given the number of charts and rows. 11 | #' @param allowCompare If \code{TRUE} (the default), then the user can use the 12 | #' UI to add or remove charts and choose which variables to compare 13 | #' 14 | #' @return List of options 15 | #' 16 | #' @examples 17 | #' if (require(dygraphs)) { 18 | #' 19 | #' mydata <- data.frame( 20 | #' year = 2000+1:100, 21 | #' series1 = rnorm(100), 22 | #' series2 = rnorm(100), 23 | #' series3 = rnorm(100) 24 | #' ) 25 | #' manipulateWidget( 26 | #' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), 27 | #' range = mwSlider(2001, 2100, c(2001, 2100)), 28 | #' series = mwSelect(c("series1", "series2", "series3")), 29 | #' title = mwText("Fictive time series"), 30 | #' .compare = list(title = NULL, series = NULL), 31 | #' .compareOpts = compareOptions(ncharts = 4) 32 | #' ) 33 | #' 34 | #' manipulateWidget( 35 | #' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), 36 | #' range = mwSlider(2001, 2100, c(2001, 2100)), 37 | #' series = mwSelect(c("series1", "series2", "series3")), 38 | #' title = mwText("Fictive time series"), 39 | #' .compare = list(title = NULL, series = NULL), 40 | #' .compareOpts = compareOptions(ncharts = 3, nrow = 3) 41 | #' ) 42 | #' } 43 | #' 44 | #' @export 45 | compareOptions <- function(ncharts = NULL, nrow = NULL, ncol = NULL, allowCompare = TRUE) { 46 | list( 47 | ncharts = ncharts, 48 | nrow = nrow, 49 | ncol = ncol, 50 | allowCompare = allowCompare 51 | ) 52 | } 53 | -------------------------------------------------------------------------------- /data-raw/world_energy_use.R: -------------------------------------------------------------------------------- 1 | ## code to prepare `DATASET` dataset goes here 2 | library(wbstats) 3 | library(dplyr) 4 | 5 | new_cache <- wbcache("en") 6 | wbsearch("energy", cache = new_cache) %>% View() 7 | 8 | indicators <- c( 9 | population = "SP.POP.TOTL", 10 | energy_used_per_capita = "EG.USE.PCAP.KG.OE", 11 | energy_imported_prop = "EG.IMP.CONS.ZS", 12 | energy_fossil_prop = "EG.USE.COMM.FO.ZS" 13 | ) 14 | 15 | data_source <- wb("countries_only", indicators, return_wide = TRUE, ) 16 | 17 | worldEnergyUse <- data_source %>% 18 | select_at(c("country", "iso2c", year = "date", indicators)) %>% 19 | mutate( 20 | country = as.character(country), 21 | year = as.numeric(year), 22 | energy_fossil_prop = energy_fossil_prop / 100, 23 | energy_imported_prop = energy_imported_prop / 100 24 | ) %>% 25 | filter(year <= 2014) %>% 26 | mutate(energy_used = energy_used_per_capita * population) %>% 27 | mutate(energy_fossil = energy_used * energy_fossil_prop) %>% 28 | group_by(year) %>% 29 | mutate( 30 | prop_world_energy_used = energy_used / sum(energy_used, na.rm = TRUE), 31 | prop_world_energy_fossil = energy_fossil / sum(energy_fossil, na.rm = TRUE), 32 | prop_world_population = population / sum(population, na.rm = TRUE) 33 | ) %>% 34 | ungroup() 35 | 36 | # Add country region, longitude and lattitude 37 | countries <- new_cache$countries %>% 38 | select(iso2c, long, lat, region) %>% 39 | mutate( 40 | region = as.character(region), 41 | long = as.numeric(long), 42 | lat = as.numeric(lat) 43 | ) %>% 44 | filter(!is.na(long)) 45 | 46 | worldEnergyUse <- worldEnergyUse %>% 47 | inner_join(countries, by = "iso2c") 48 | 49 | # Remove countries that have only NA values 50 | countries_to_keep <- worldEnergyUse %>% 51 | group_by(iso2c) %>% 52 | summarize(not_na = sum(!is.na(energy_used))) %>% 53 | filter(not_na > 0) %>% 54 | pull(iso2c) 55 | 56 | worldEnergyUse <- worldEnergyUse %>% 57 | filter(iso2c %in% countries_to_keep) 58 | 59 | worldEnergyUse <- as.data.frame(worldEnergyUse) 60 | 61 | usethis::use_data(worldEnergyUse, overwrite = TRUE) 62 | -------------------------------------------------------------------------------- /inst/examples/example-two_mods_one_app.R: -------------------------------------------------------------------------------- 1 | library(dygraphs) 2 | library(plotly) 3 | library(shiny) 4 | 5 | 6 | mydata <- data.frame( 7 | year = 2000+1:100, 8 | series1 = rnorm(100), 9 | series2 = rnorm(100), 10 | series3 = rnorm(100) 11 | ) 12 | 13 | c <- manipulateWidget( 14 | combineWidgets(dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title)), 15 | range = mwSlider(2001, 2100, c(2001, 2100)), 16 | series = mwSelect(c("series1", "series2", "series3")), 17 | title = mwText("Fictive time series"), .updateBtn = FALSE, .updateBtnInit = TRUE, 18 | .compare = c("title", "series"), .runApp = FALSE 19 | ) 20 | 21 | dt <- data.frame ( 22 | x = sort(runif(100)), 23 | y = rnorm(100) 24 | ) 25 | 26 | myPlot <- function(type, lwd) { 27 | if (type == "points") { 28 | plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers") 29 | } else { 30 | plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd)) 31 | } 32 | } 33 | 34 | c2 <- manipulateWidget( 35 | combineWidgets(myPlot(type, lwd)), 36 | type = mwSelect(c("points", "lines"), "points"), .saveBtn = TRUE, 37 | .exportBtn = TRUE, .updateBtn = TRUE, .updateBtnInit = FALSE, 38 | lwd = mwSlider(1, 10, 1, .display = type == "lines"), .runApp = FALSE 39 | ) 40 | 41 | 42 | c2 <- manipulateWidget( 43 | plotEnergyUse(Country, Period), 44 | Period = mwSlider(1960, 2014, c(1960, 2014)), 45 | Country = mwSelect(sort(unique(worldEnergyUse$country))), 46 | .compare = list(Country = c("United States", "China")), 47 | .compareOpts = compareOptions(ncol = 2), .runApp = FALSE 48 | ) 49 | 50 | 51 | ui <- navbarPage( 52 | "Test manipulateWidget", 53 | tabPanel( 54 | "Module 1", 55 | mwModuleUI("mod1", height = "500px", saveBtn = T, updateBtn = F, exportBtn = T), 56 | mwModuleUI("mod3", height = "500px", saveBtn = T, updateBtn = T, exportBtn = T) 57 | ), 58 | tabPanel( 59 | "Module 2", 60 | mwModuleUI("mod2", height = "500px", saveBtn = T, updateBtn = T, exportBtn = T) 61 | ) 62 | ) 63 | 64 | server <- function(input, output, session) { 65 | mwModule("mod1", c) 66 | mwModule("mod2", c2) 67 | } 68 | 69 | shinyApp(ui, server) 70 | -------------------------------------------------------------------------------- /man/mwSlider.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwSlider} 4 | \alias{mwSlider} 5 | \title{Add a Slider to a manipulateWidget gadget} 6 | \usage{ 7 | mwSlider(min, max, value, label = NULL, ..., .display = TRUE) 8 | } 9 | \arguments{ 10 | \item{min}{The minimum value that can be selected.} 11 | 12 | \item{max}{The maximum value that can be selected.} 13 | 14 | \item{value}{Initial value of the slider A numeric vector of length one will create a 15 | regular slider; a numeric vector of length two will create a double-ended 16 | range slider} 17 | 18 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 19 | variable is used.} 20 | 21 | \item{...}{Other arguments passed to function\code{\link[shiny]{sliderInput}}} 22 | 23 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 24 | the input control should be shown/hidden.} 25 | } 26 | \value{ 27 | A function that will generate the input control. 28 | } 29 | \description{ 30 | Add a Slider to a manipulateWidget gadget 31 | } 32 | \examples{ 33 | 34 | if (require(plotly)) { 35 | 36 | myWidget <- manipulateWidget( 37 | plot_ly(data.frame(x = 1:n, y = rnorm(n)), x=~x, y=~y, type = "scatter", mode = "markers"), 38 | n = mwSlider(1, 100, 10, label = "Number of values") 39 | ) 40 | 41 | Sys.sleep(0.5) 42 | 43 | # Create a double ended slider to choose a range instead of a single value 44 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 45 | 46 | manipulateWidget( 47 | plot_ly(mydata[n[1]:n[2], ], x=~x, y=~y, type = "scatter", mode = "markers"), 48 | n = mwSlider(1, 100, c(1, 10), label = "Number of values") 49 | ) 50 | 51 | } 52 | 53 | } 54 | \seealso{ 55 | Other controls: 56 | \code{\link{mwCheckboxGroup}()}, 57 | \code{\link{mwCheckbox}()}, 58 | \code{\link{mwDateRange}()}, 59 | \code{\link{mwDate}()}, 60 | \code{\link{mwGroup}()}, 61 | \code{\link{mwNumeric}()}, 62 | \code{\link{mwPassword}()}, 63 | \code{\link{mwRadio}()}, 64 | \code{\link{mwSelectize}()}, 65 | \code{\link{mwSelect}()}, 66 | \code{\link{mwSharedValue}()}, 67 | \code{\link{mwText}()} 68 | } 69 | \concept{controls} 70 | -------------------------------------------------------------------------------- /R/shiny_module_grid.R: -------------------------------------------------------------------------------- 1 | gridModuleUI <- function(id) { 2 | ns <- NS(id) 3 | uiOutput(ns("cells"), container = function(...) { 4 | tags$div( 5 | class = "mw-chartarea", 6 | ... 7 | ) 8 | }) 9 | } 10 | 11 | gridModuleServer <- function(input, output, session, dim, ctrl, ...) { 12 | ns <- session$ns 13 | 14 | ncells <- reactiveVal(NULL) 15 | 16 | observeEvent(dim$n, { 17 | if (is.null(ncells())) { 18 | outputEls <- lapply(seq_len(dim$n), function(i) { 19 | content <- ctrl$outputFunc(ns(paste0("output_", i)), width = "100%", height = "100%") 20 | style <- sprintf("float:left;width:%s%%;height:%s%%;", 21 | floor(100 / dim$ncol), floor(100 / dim$nrow)) 22 | tags$div(class="mw-chart", style = style, content) 23 | }) 24 | output$cells <- renderUI(shiny::tagList(outputEls)) 25 | } else if (ncells() < dim$n) { 26 | outputEls <- lapply((ncells()+1):dim$n, function(i) { 27 | content <- ctrl$outputFunc(ns(paste0("output_", i)), width = "100%", height = "100%") 28 | style <- sprintf("float:left;width:%s%%;height:%s%%;", 29 | floor(100 / dim$ncol), floor(100 / dim$nrow)) 30 | tags$div(class="mw-chart", style = style, content) 31 | }) 32 | shiny::insertUI(paste0("#",ns("cells")),ui=shiny::tagList(outputEls), session = session) 33 | resetSize(dim$nrow, dim$ncol, ns) 34 | } else if (ncells() > dim$n) { 35 | for (i in ncells():(dim$n+1)) { 36 | shiny::removeUI(sprintf("div:has(> #%s_%s)", ns("output"), i),session = session) 37 | } 38 | } 39 | ncells(dim$n) 40 | }, ignoreNULL = TRUE) 41 | 42 | observe({ 43 | resetSize(dim$nrow, dim$ncol, ns) 44 | shinyjs::runjs("resizeAllWidgets()") 45 | }) 46 | 47 | return(list(output = output, session = session)) 48 | } 49 | 50 | resetSize <- function(nrow, ncol, ns) { 51 | width <- paste0(floor(100 / ncol), "%") 52 | height <- paste0(floor(100 / nrow), "%") 53 | id <- ns("cells") 54 | js <- sprintf( 55 | "$('#%s .mw-chart').css({'float':'left', 'width':'%s', 'height':'%s'})", 56 | id, width, height 57 | ) 58 | shinyjs::runjs(js) 59 | } 60 | -------------------------------------------------------------------------------- /R/static_image.R: -------------------------------------------------------------------------------- 1 | #' Include a static image in a combinedWidgets 2 | #' 3 | #' \code{staticPlot} is a function that generates a static plot and then return 4 | #' the HTML code needed to include the plot in a combinedWidgets. 5 | #' \code{staticImage} is a more general function that generates the HTML code 6 | #' necessary to include any image file. 7 | #' 8 | #' @param expr Expression that creates a static plot. 9 | #' @param width Width of the image to create. 10 | #' @param height Height of the image to create. 11 | #' @param file path of the image to include. 12 | #' @param style CSS style to apply to the image. 13 | #' 14 | #' @return a \code{shiny.tag} object containing the HTML code required to include 15 | #' the image or the plot in a \code{combinedWidgets} object. 16 | #' 17 | #' @examples 18 | #' staticPlot(hist(rnorm(100))) 19 | #' 20 | #' if (require(plotly)) { 21 | #' data(iris) 22 | #' 23 | #' combineWidgets( 24 | #' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 25 | #' staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300) 26 | #' ) 27 | #' 28 | #' # You can also embed static images in the header, footer, left or right 29 | #' # columns of a combinedWidgets. The advantage is that the space allocated 30 | #' # to the static plot will be constant when the window is resized. 31 | #' 32 | #' combineWidgets( 33 | #' plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 34 | #' footer = staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300) 35 | #' ) 36 | #' } 37 | #' 38 | #' @importFrom grDevices dev.off png 39 | #' @export 40 | staticPlot <- function(expr, width = 600, height = 400) { 41 | expr <- substitute(expr) 42 | file <- tempfile(fileext = ".png") 43 | png(file, width, height) 44 | eval(expr, envir = parent.frame()) 45 | dev.off() 46 | staticImage(file) 47 | } 48 | 49 | #' @rdname staticPlot 50 | #' @export 51 | #' 52 | staticImage <- function(file, style = "max-width:100%%;max-height:100%%") { 53 | data <- base64enc::base64encode(readBin(file, "raw", file.info(file)[1, "size"])) 54 | ext <- tools::file_ext(file) 55 | tags$img( 56 | src = sprintf("data:image/%s;base64,%s", ext, data), 57 | style = style 58 | ) 59 | } 60 | -------------------------------------------------------------------------------- /man/mwSharedValue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwSharedValue} 4 | \alias{mwSharedValue} 5 | \title{Shared Value} 6 | \usage{ 7 | mwSharedValue(expr = NULL) 8 | } 9 | \arguments{ 10 | \item{expr}{Expression used to compute the value of the input.} 11 | } 12 | \value{ 13 | An Input object of type "sharedValue". 14 | } 15 | \description{ 16 | This function creates a virtual input that can be used to store a dynamic 17 | shared variable that is accessible in inputs as well as in output. 18 | } 19 | \examples{ 20 | 21 | if (require(plotly)) { 22 | # Plot the characteristics of a car and compare with the average values for 23 | # cars with same number of cylinders. 24 | # The shared variable 'subsetCars' is used to avoid subsetting multiple times 25 | # the data: this value is updated only when input 'cylinders' changes. 26 | colMax <- apply(mtcars, 2, max) 27 | 28 | plotCar <- function(cardata, carName) { 29 | carValues <- unlist(cardata[carName, ]) 30 | carValuesRel <- carValues / colMax 31 | 32 | avgValues <- round(colMeans(cardata), 2) 33 | avgValuesRel <- avgValues / colMax 34 | 35 | plot_ly() \%>\% 36 | add_bars(x = names(cardata), y = carValuesRel, text = carValues, 37 | hoverinfo = c("x+text"), name = carName) \%>\% 38 | add_bars(x = names(cardata), y = avgValuesRel, text = avgValues, 39 | hoverinfo = c("x+text"), name = "average") \%>\% 40 | layout(barmode = 'group') 41 | } 42 | 43 | c <- manipulateWidget( 44 | plotCar(subsetCars, car), 45 | cylinders = mwSelect(c("4", "6", "8")), 46 | subsetCars = mwSharedValue(subset(mtcars, cylinders == cyl)), 47 | car = mwSelect(choices = row.names(subsetCars)) 48 | ) 49 | } 50 | 51 | } 52 | \seealso{ 53 | Other controls: 54 | \code{\link{mwCheckboxGroup}()}, 55 | \code{\link{mwCheckbox}()}, 56 | \code{\link{mwDateRange}()}, 57 | \code{\link{mwDate}()}, 58 | \code{\link{mwGroup}()}, 59 | \code{\link{mwNumeric}()}, 60 | \code{\link{mwPassword}()}, 61 | \code{\link{mwRadio}()}, 62 | \code{\link{mwSelectize}()}, 63 | \code{\link{mwSelect}()}, 64 | \code{\link{mwSlider}()}, 65 | \code{\link{mwText}()} 66 | } 67 | \concept{controls} 68 | -------------------------------------------------------------------------------- /tests/testthat/test-mwGroup.R: -------------------------------------------------------------------------------- 1 | context("Group of inputs") 2 | describe("mwGroup", { 3 | it("throws an error if an argument is not named", { 4 | expect_error(mwGroup(mwText()), "All arguments need to be named.") 5 | }) 6 | 7 | it("throws an error if an argument is not an input", { 8 | expect_error(mwGroup(a = 1), "All arguments need to be Input objects.") 9 | }) 10 | 11 | it("can be cloned", { 12 | env1 <- initEnv(parent.frame(), 1) 13 | env2 <- initEnv(parent.frame(), 2) 14 | 15 | a <- mwText() 16 | b <- mwText() 17 | inner_grp = mwGroup(a = a) 18 | grp <- mwGroup(inner_grp = inner_grp, b = b) 19 | a$init("a", env1) 20 | b$init("b", env1) 21 | inner_grp$init("inner_grp", env1) 22 | grp$init("grp", env1) 23 | 24 | grp2 <- grp$clone(env2) 25 | 26 | expect_equal(c("a", "b"), ls(envir = env2)) 27 | grp2$value$b$setValue("test") 28 | expect_equal(grp2$value$b$value, "test") 29 | expect_equal(get("b", envir = env2), "test") 30 | expect_equal(get("b", envir = env1), "") 31 | 32 | grp2$value$inner_grp$value$a$setValue("test") 33 | expect_equal(grp2$value$inner_grp$value$a$value, "test") 34 | expect_equal(get("a", envir = env2), "test") 35 | expect_equal(get("a", envir = env1), "") 36 | }) 37 | 38 | it("removes inner inputs from environment", { 39 | env1 <- initEnv(parent.frame(), 1) 40 | 41 | a <- mwText() 42 | b <- mwText() 43 | inner_grp = mwGroup(a = a) 44 | grp <- mwGroup(inner_grp = inner_grp, b = b) 45 | a$init("a", env1) 46 | b$init("b", env1) 47 | inner_grp$init("inner_grp", env1) 48 | grp$init("grp", env1) 49 | 50 | grp$destroy() 51 | expect_true(!"a" %in% ls(envir = env1)) 52 | expect_true(!"b" %in% ls(envir = env1)) 53 | }) 54 | 55 | it("can return list of inner inputs", { 56 | env1 <- initEnv(parent.frame(), 1) 57 | 58 | a <- mwText() 59 | b <- mwText() 60 | inner_grp = mwGroup(a = a) 61 | grp <- mwGroup(inner_grp = inner_grp, b = b) 62 | a$init("a", env1) 63 | b$init("b", env1) 64 | inner_grp$init("inner_grp", env1) 65 | grp$init("grp", env1) 66 | 67 | inputs <- grp$getInputs() 68 | expect_equal(sort(names(inputs)), c("a", "b", "grp", "inner_grp")) 69 | expect_identical(inputs$a, a) 70 | expect_identical(inputs$b, b) 71 | }) 72 | }) 73 | -------------------------------------------------------------------------------- /R/module_ui.R: -------------------------------------------------------------------------------- 1 | #' Add a manipulateWidget to a shiny application 2 | #' 3 | #' These two functions can be used to include a manipulateWidget object in a shiny application. 4 | #' \code{mwModuleUI} must be used in the UI to generate the required HTML elements and add 5 | #' javascript and css dependencies. \code{mwModule} must be called once in the server function 6 | #' of the application. 7 | #' 8 | #' @param id A unique string that identifies the module 9 | #' @param controller Object of class \code{\link{MWController}} returned by 10 | #' \code{\link{manipulateWidget}} when parameter \code{.runApp} is 11 | #' \code{FALSE}. 12 | #' @param fillPage : \code{logical}. Render in a fillPage or not ? Defaut to FALSE 13 | #' @param ... named arguments containing reactive values. They can be used to send data from 14 | #' the main shiny application to the module. 15 | #' 16 | #' @return \code{mwModuleUI} returns the required HTML elements for the module. mwModule is only 17 | #' used for its side effects. 18 | #' 19 | #' @examples 20 | #' if (interactive() & require("dygraphs")) { 21 | #' require("shiny") 22 | #' ui <- fillPage( 23 | #' fillRow( 24 | #' flex = c(NA, 1), 25 | #' div( 26 | #' textInput("title", label = "Title", value = "glop"), 27 | #' selectInput("series", "series", choices = c("series1", "series2", "series3")) 28 | #' ), 29 | #' mwModuleUI("ui", height = "100%") 30 | #' )) 31 | #' 32 | #' server <- function(input, output, session) { 33 | #' mydata <- data.frame( 34 | #' year = 2000+1:100, 35 | #' series1 = rnorm(100), 36 | #' series2 = rnorm(100), 37 | #' series3 = rnorm(100) 38 | #' ) 39 | #' 40 | #' c <- manipulateWidget( 41 | #' { 42 | #' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title) 43 | #' }, 44 | #' range = mwSlider(2001, 2100, c(2001, 2050)), 45 | #' series = mwSharedValue(), 46 | #' title = mwSharedValue(), .runApp = FALSE, 47 | #' .compare = "range" 48 | #' ) 49 | #' # 50 | #' mwModule("ui", c, title = reactive(input$title), series = reactive(input$series)) 51 | #' } 52 | #' 53 | #' shinyApp(ui, server) 54 | #' 55 | #' 56 | #' } 57 | #' 58 | #' @export 59 | mwModule <- function(id, controller, fillPage = FALSE, ...) { 60 | shiny::callModule(mwModuleServer, id, ctrl = controller, ...) 61 | } 62 | -------------------------------------------------------------------------------- /man/mwSelectize.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwSelectize} 4 | \alias{mwSelectize} 5 | \title{Add a Select list input to a manipulateWidget gadget} 6 | \usage{ 7 | mwSelectize( 8 | choices = value, 9 | value = NULL, 10 | label = NULL, 11 | ..., 12 | multiple = FALSE, 13 | options = NULL, 14 | .display = TRUE 15 | ) 16 | } 17 | \arguments{ 18 | \item{choices}{Vector or list of choices. If it is named, then the names rather than the 19 | values are displayed to the user.} 20 | 21 | \item{value}{Initial value of the input. If not specified, the first choice is used.} 22 | 23 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 24 | variable is used.} 25 | 26 | \item{...}{Other arguments passed to function\code{\link[shiny]{selectInput}}.} 27 | 28 | \item{multiple}{Is selection of multiple items allowed?} 29 | 30 | \item{options}{A list of options. See the documentation of selectize.js for possible options} 31 | 32 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 33 | the input control should be shown/hidden.} 34 | } 35 | \value{ 36 | A function that will generate the input control. 37 | } 38 | \description{ 39 | Add a Select list input to a manipulateWidget gadget 40 | } 41 | \examples{ 42 | if (require(plotly)) { 43 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 44 | 45 | # Select multiple values 46 | manipulateWidget( 47 | { 48 | if (length(species) == 0) mydata <- iris 49 | else mydata <- iris[iris$Species \%in\% species,] 50 | 51 | plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width, 52 | color = ~droplevels(Species), type = "scatter", mode = "markers") 53 | }, 54 | species = mwSelectize(c("Select one or two species : " = "", levels(iris$Species)), 55 | multiple = TRUE, options = list(maxItems = 2)) 56 | ) 57 | } 58 | 59 | } 60 | \seealso{ 61 | Other controls: 62 | \code{\link{mwCheckboxGroup}()}, 63 | \code{\link{mwCheckbox}()}, 64 | \code{\link{mwDateRange}()}, 65 | \code{\link{mwDate}()}, 66 | \code{\link{mwGroup}()}, 67 | \code{\link{mwNumeric}()}, 68 | \code{\link{mwPassword}()}, 69 | \code{\link{mwRadio}()}, 70 | \code{\link{mwSelect}()}, 71 | \code{\link{mwSharedValue}()}, 72 | \code{\link{mwSlider}()}, 73 | \code{\link{mwText}()} 74 | } 75 | \concept{controls} 76 | -------------------------------------------------------------------------------- /inst/htmlwidgets/combineWidgets.js: -------------------------------------------------------------------------------- 1 | //Copyright © 2016 RTE Réseau de transport d’électricité 2 | 3 | HTMLWidgets.widget({ 4 | 5 | name: 'combineWidgets', 6 | 7 | type: 'output', 8 | 9 | factory: function(el, width, height) { 10 | 11 | var widgets = {}; 12 | 13 | function toArray(x) { 14 | if (x.constructor !== Array) x = [x]; 15 | return x; 16 | } 17 | 18 | function getWidgetFactory(name) { 19 | return HTMLWidgets.widgets.filter(function(x) {return x.name == name})[0]; 20 | } 21 | 22 | function resizeAll() { 23 | for (var k in widgets) { 24 | var widgetEl = document.getElementById(k); 25 | if (!widgetEl) { 26 | delete widgets[k]; 27 | } else { 28 | var x = widgets[k]; 29 | x.factory.resize(widgetEl, widgetEl.clientWidth, widgetEl.clientHeight, x.instance); 30 | } 31 | } 32 | } 33 | 34 | return { 35 | 36 | renderValue: function(x) { 37 | x.elementId = toArray(x.elementId); 38 | x.widgetType = toArray(x.widgetType); 39 | 40 | var nWidgets = x.widgetType.length; 41 | el.innerHTML = x.html; 42 | 43 | for (var i = 0; i < nWidgets; i++) { 44 | var child = document.getElementById(x.elementId[i]); 45 | 46 | if (x.widgetType[i] == "html") { 47 | child.innerHTML = x.data[i]; 48 | } else { 49 | var widgetFactory = getWidgetFactory(x.widgetType[i]); 50 | var w = widgetFactory.initialize(child, child.clientWidth, child.clientHeight); 51 | widgetFactory.renderValue(child, x.data[i], w); 52 | widgets[x.elementId[i]] = {factory:widgetFactory, instance:w}; 53 | } 54 | } 55 | 56 | // Crosstalk inputs need special handling: see 57 | // https://github.com/ramnathv/htmlwidgets/issues/300 58 | 59 | if (x.hasCrosstalkInputs && crosstalk && crosstalk.bind) { 60 | crosstalk.bind(); 61 | } 62 | 63 | // Sometimes widgets are rendered before the size of all html element has 64 | // been computed. Adding a small delay fixes this problem. 65 | setTimeout(resizeAll, 5); 66 | 67 | }, 68 | 69 | resize: function(width, height) { 70 | resizeAll(); 71 | } 72 | 73 | }; 74 | } 75 | }); 76 | -------------------------------------------------------------------------------- /man/mwSelect.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inputs.R 3 | \name{mwSelect} 4 | \alias{mwSelect} 5 | \title{Add a Select list input to a manipulateWidget gadget} 6 | \usage{ 7 | mwSelect( 8 | choices = value, 9 | value = NULL, 10 | label = NULL, 11 | ..., 12 | multiple = FALSE, 13 | .display = TRUE 14 | ) 15 | } 16 | \arguments{ 17 | \item{choices}{Vector or list of choices. If it is named, then the names rather than the 18 | values are displayed to the user.} 19 | 20 | \item{value}{Initial value of the input. If not specified, the first choice is used.} 21 | 22 | \item{label}{Display label for the control. If \code{NULL}, the name of the corresponding 23 | variable is used.} 24 | 25 | \item{...}{Other arguments passed to function\code{\link[shiny]{selectInput}}.} 26 | 27 | \item{multiple}{Is selection of multiple items allowed?} 28 | 29 | \item{.display}{expression that evaluates to TRUE or FALSE, indicating when 30 | the input control should be shown/hidden.} 31 | } 32 | \value{ 33 | A function that will generate the input control. 34 | } 35 | \description{ 36 | Add a Select list input to a manipulateWidget gadget 37 | } 38 | \examples{ 39 | if (require(plotly)) { 40 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 41 | 42 | manipulateWidget( 43 | { 44 | mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines") 45 | plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode) 46 | }, 47 | type = mwSelect(c("points", "lines", "both")) 48 | ) 49 | 50 | Sys.sleep(0.5) 51 | 52 | # Select multiple values 53 | manipulateWidget( 54 | { 55 | if (length(species) == 0) mydata <- iris 56 | else mydata <- iris[iris$Species \%in\% species,] 57 | 58 | plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width, 59 | color = ~droplevels(Species), type = "scatter", mode = "markers") 60 | }, 61 | species = mwSelect(levels(iris$Species), multiple = TRUE) 62 | ) 63 | } 64 | 65 | } 66 | \seealso{ 67 | Other controls: 68 | \code{\link{mwCheckboxGroup}()}, 69 | \code{\link{mwCheckbox}()}, 70 | \code{\link{mwDateRange}()}, 71 | \code{\link{mwDate}()}, 72 | \code{\link{mwGroup}()}, 73 | \code{\link{mwNumeric}()}, 74 | \code{\link{mwPassword}()}, 75 | \code{\link{mwRadio}()}, 76 | \code{\link{mwSelectize}()}, 77 | \code{\link{mwSharedValue}()}, 78 | \code{\link{mwSlider}()}, 79 | \code{\link{mwText}()} 80 | } 81 | \concept{controls} 82 | -------------------------------------------------------------------------------- /inst/examples/energy_consumption.R: -------------------------------------------------------------------------------- 1 | library(manipulateWidget) 2 | library(dplyr) 3 | library(ggplot2) 4 | library(plotly) 5 | 6 | data("worldEnergyUse") 7 | 8 | plotEvoUse <- function(Country, Period = c(1960,2014)) { 9 | dataset <- worldEnergyUse %>% 10 | filter(country == Country, year >= Period[1] & year <= Period[2]) 11 | 12 | ggplot(dataset, aes(year)) + 13 | geom_line(aes(y = energy_used, color = "Total energy")) + 14 | geom_line(aes(y = energy_fossil, color = "Fossil energy")) + 15 | scale_color_manual(values = c("black", "red")) + 16 | expand_limits(y = 0) + 17 | ggtitle(paste("Evolution of energy\nconsumption in", Country)) + 18 | xlab("") + ylab("Energy (kg of oil equivalent)") + labs(color = "") + 19 | theme_bw() + 20 | theme(plot.title = element_text(size=10)) + 21 | theme(axis.title.y = element_text(size=9)) 22 | } 23 | 24 | plotEvoUse("United States") %>% ggplotly() 25 | 26 | tooltipText <- function(title, value) { 27 | sprintf("%s: %s%%", title, round(value * 100, 1)) 28 | } 29 | 30 | plotShareUse <- function(Country, Period = c(1960, 2014)) { 31 | dataset <- worldEnergyUse %>% 32 | filter(country == Country, year %in% Period) 33 | 34 | ggplot(dataset) + 35 | facet_grid(year ~ .) + 36 | geom_bar(aes("Population", weight = prop_world_population, 37 | text = tooltipText("Population", prop_world_population))) + 38 | geom_bar(aes("Energy Use", weight = prop_world_energy_used, 39 | text = tooltipText("Energy Use", prop_world_energy_used))) + 40 | geom_bar(aes("Energy Fossil", weight = prop_world_energy_fossil, 41 | text = tooltipText("Energy Fossil", prop_world_energy_fossil))) + 42 | ggtitle("Share of world...") + 43 | xlab("") + ylab("") + 44 | scale_y_continuous(labels = scales::percent) + 45 | theme_bw() + 46 | theme(plot.title = element_text(size=10)) + 47 | theme(axis.text.x = element_text(angle = 45, hjust = 1)) 48 | } 49 | 50 | suppressWarnings(plotShareUse("Germany")) %>% 51 | ggplotly(tooltip = "text") 52 | 53 | manipulateWidget( 54 | combineWidgets( 55 | plotEvoUse(Country, Period) %>% ggplotly() %>% 56 | layout( 57 | legend = list(orientation = "h", x = 0, y = 0, yanchor = "bottom"), 58 | margin = list(t = 40, b = 0) 59 | ), 60 | suppressWarnings(plotShareUse(Country, Period)) %>% 61 | ggplotly(tooltip = "text") %>% 62 | layout(margin = list(t = 40, b=0)), 63 | ncol = 2, colsize = c(2, 1) 64 | ), 65 | Period = mwSlider(1960, 2014, c(1960, 2014)), 66 | Country = mwSelect(sort(unique(worldEnergyUse$country)), "United States") 67 | ) 68 | -------------------------------------------------------------------------------- /inst/examples/example-runtime_shiny.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "manipulateWidget Demo" 3 | output: html_document 4 | runtime: shiny 5 | --- 6 | 7 | Hodor. Hodor hodor... Hodor hodor hodor hodor. Hodor, hodor. Hodor. Hodor, hodor, hodor. Hodor hodor?! Hodor, hodor. Hodor. Hodor, hodor - hodor hodor! Hodor, hodor, hodor. Hodor hodor hodor. Hodor. Hodor hodor - hodor... Hodor hodor hodor hodor; hodor hodor? Hodor. Hodor HODOR hodor, hodor hodor... Hodor hodor hodor; hodor hodor?! Hodor hodor - hodor hodor; hodor hodor; hodor hodor? Hodor hodor - hodor hodor... Hodor hodor hodor hodor. Hodor. Hodor hodor HODOR! Hodor HODOR hodor, hodor hodor - hodor hodor! Hodor hodor HODOR! Hodor hodor, hodor. Hodor hodor; hodor hodor; hodor hodor - hodor, hodor, hodor hodor. 8 | 9 | ```{r, echo = FALSE, message = FALSE} 10 | library(plotly) 11 | library(manipulateWidget) 12 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 13 | 14 | myPlot <- function(type, lwd) { 15 | if (type == "points") { 16 | plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "markers") 17 | } else { 18 | plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "lines", 19 | line = list(width = lwd)) 20 | } 21 | } 22 | 23 | manipulateWidget( 24 | myPlot(type, lwd), 25 | type = mwSelect(c("points", "lines"), "points"), 26 | lwd = mwSlider(1, 10, 1, .display = type == "lines"), 27 | .height = 600 28 | ) 29 | ``` 30 | 31 | Hodor. Hodor hodor... Hodor hodor hodor hodor. Hodor, hodor. Hodor. Hodor, hodor, hodor. Hodor hodor?! Hodor, hodor. Hodor. Hodor, hodor - hodor hodor! Hodor, hodor, hodor. Hodor hodor hodor. Hodor. Hodor hodor - hodor... Hodor hodor hodor hodor; hodor hodor? Hodor. Hodor HODOR hodor, hodor hodor... Hodor hodor hodor; hodor hodor?! Hodor hodor - hodor hodor; hodor hodor; hodor hodor? Hodor hodor - hodor hodor... Hodor hodor hodor hodor. Hodor. Hodor hodor HODOR! Hodor HODOR hodor, hodor hodor - hodor hodor! Hodor hodor HODOR! Hodor hodor, hodor. Hodor hodor; hodor hodor; hodor hodor - hodor, hodor, hodor hodor. 32 | 33 | ```{r, echo = FALSE, message = FALSE} 34 | library(plotly) 35 | library(manipulateWidget) 36 | mydata <- data.frame(x = 1:100, y = rnorm(100)) 37 | 38 | myPlot <- function(type, lwd) { 39 | if (type == "points") { 40 | plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "markers") 41 | } else { 42 | plot_ly(mydata, x= ~x, y = ~y, type = "scatter", mode = "lines", 43 | line = list(width = lwd)) 44 | } 45 | } 46 | 47 | manipulateWidget( 48 | myPlot(type, lwd), 49 | type = mwSelect(c("points", "lines"), "points"), 50 | lwd = mwSlider(1, 10, 1, .display = type == "lines"), 51 | .height = 600 52 | ) 53 | ``` 54 | -------------------------------------------------------------------------------- /tests/testthat/test-inputs.R: -------------------------------------------------------------------------------- 1 | context("Shiny inputs") 2 | 3 | # Slider 4 | test_input(mwSlider(0, 10, 0), c(5, -20, 20), c(5, 0, 10)) 5 | # Slider with two values 6 | test_input( 7 | mwSlider(0, 10, 0), 8 | list(c(5, 7), c(-20, 20), c(-20, 5), c(5, 20)), 9 | list(c(5, 7), c(0, 10), c(0, 5), c(5, 10)) 10 | ) 11 | 12 | # Text 13 | test_input(mwText(), list("1", 1, NULL), list("1", "1", "")) 14 | 15 | # Numeric 16 | test_input(mwNumeric(0), list(5, -20, 20, NULL, "a"), list(5, -20, 20, NULL, NULL)) 17 | test_input(mwNumeric(0, min = 0, max = 10), c(5, -20, 20), c(5, 0, 10)) 18 | 19 | # Password 20 | test_input(mwPassword(), list("1", 1, NULL), list("1", "1", "")) 21 | 22 | # Select 23 | test_input(mwSelect(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1)) 24 | test_input( 25 | mwSelect(1:4, multiple = TRUE), 26 | list(1, 5, 3:5), 27 | list(1, integer(0), 3:4) 28 | ) 29 | # Select where choices have distinct label and values 30 | test_input( 31 | mwSelect(list(a = 1, b = 2)), 32 | list(1, 2, 5, NULL), 33 | list(1, 2, 1, 1) 34 | ) 35 | test_input( 36 | mwSelect(list(a = 1, b = 2), multiple = TRUE), 37 | list(1, 2, 5, 1:3), 38 | list(1, 2, integer(0), 1:2) 39 | ) 40 | 41 | # Checkbox 42 | test_input( 43 | mwCheckbox(), 44 | list(TRUE, FALSE, NULL, NA, "test"), 45 | list(TRUE, FALSE, FALSE, FALSE, FALSE) 46 | ) 47 | 48 | # Radio buttons 49 | test_input(mwRadio(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1)) 50 | test_input( 51 | mwRadio(list(a = 1, b = 2)), 52 | list(1, 2, 5, NULL), 53 | list(1, 2, 1, 1) 54 | ) 55 | 56 | # Date picker 57 | test_input( 58 | mwDate(), 59 | list(Sys.Date(), "2017-01-01", NULL), 60 | list(Sys.Date(), as.Date("2017-01-01"), Sys.Date()) 61 | ) 62 | # Date with min and max dates 63 | test_input( 64 | mwDate(min = "2017-01-01", max = "2017-12-31"), 65 | list("2017-06-01", "2016-06-01", "2018-06-01"), 66 | list(as.Date("2017-06-01"), as.Date("2017-01-01"), as.Date("2017-12-31")) 67 | ) 68 | 69 | 70 | # Date range 71 | defaultRange <- c(Sys.Date(), Sys.Date()) 72 | test_input( 73 | mwDateRange(), 74 | list(defaultRange, as.character(defaultRange), NULL), 75 | list(defaultRange, defaultRange, defaultRange) 76 | ) 77 | # Date range with min and max dates 78 | test_input( 79 | mwDateRange(min = "2017-01-01", max = "2017-12-31"), 80 | list(c("2016-01-01", "2018-01-01")), 81 | list(as.Date(c("2017-01-01", "2017-12-31"))) 82 | ) 83 | 84 | # Checkbox group 85 | test_input( 86 | mwCheckboxGroup(1:4), 87 | list(1, 5, 3:5), 88 | list(1, integer(0), 3:4) 89 | ) 90 | test_input( 91 | mwCheckboxGroup(list(a = 1, b = 2)), 92 | list(1, 2, 5, 1:3), 93 | list(1, 2, integer(0), 1:2) 94 | ) 95 | 96 | # Groups of input 97 | test_input(mwGroup(a = mwText(), b = mwText())) 98 | -------------------------------------------------------------------------------- /man/MWController-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/controller.R 3 | \docType{class} 4 | \name{MWController-class} 5 | \alias{MWController-class} 6 | \alias{MWController} 7 | \title{Controller object of a manipulateWidget application} 8 | \description{ 9 | \code{MWController} is a reference class that is used to manage interaction 10 | with data and update of the view created by manipulateWidget. Only users who 11 | desire to create automatic tests for applications created with 12 | \code{\link{manipulateWidget}} should care about this object. 13 | } 14 | \section{Fields}{ 15 | 16 | \describe{ 17 | \item{\code{ncharts}}{Number of charts in the application} 18 | 19 | \item{\code{nrow}}{Number of rows.} 20 | 21 | \item{\code{ncol}}{Number of columns.} 22 | 23 | \item{\code{autoUpdate}}{Boolean indicating if charts should be automatically 24 | updated when a value changes. list with \code{value} and \code{initBtn} (not autoUpdate, if want first charts on init)} 25 | }} 26 | 27 | \section{Methods}{ 28 | 29 | \describe{ 30 | \item{\code{getParams(name, chartId = 1)}}{Get parameters of an input for a given chart} 31 | 32 | \item{\code{getValue(name, chartId = 1)}}{Get the value of a variable for a given chart.} 33 | 34 | \item{\code{getValues(chartId = 1)}}{Get all values for a given chart.} 35 | 36 | \item{\code{isVisible(name, chartId = 1)}}{Indicates if a given input is visible} 37 | 38 | \item{\code{returnCharts()}}{Return all charts.} 39 | 40 | \item{\code{setValue(name, value, chartId = 1, updateHTML = FALSE, reactive = FALSE)}}{Update the value of a variable for a given chart.} 41 | 42 | \item{\code{setValueAll(name, value, updateHTML = TRUE)}}{Update the value of an input for all charts} 43 | 44 | \item{\code{updateCharts()}}{Update all charts.} 45 | }} 46 | 47 | \section{Testing a manipulateWidget application}{ 48 | 49 | When \code{\link{manipulateWidget}} is used in a test script, it returns a 50 | \code{MWController} object instead of starting a shiny gadget. This object has 51 | methods to modify inputs values and check the state of the application. This 52 | can be useful to automatically checks if your application behaves like desired. 53 | Here is some sample code that uses package \code{testthat}: 54 | 55 | \preformatted{ 56 | library("testthat") 57 | 58 | controller <- manipulateWidget( 59 | x + y, 60 | x = mwSlider(0, 10, 5), 61 | y = mwSlider(0, x, 0), 62 | .compare = "y" 63 | ) 64 | 65 | test_that("Two charts are created", { 66 | expect_equal(controller$ncharts, 2) 67 | }) 68 | 69 | test_that("Parameter 'max' of 'y' is updated when 'x' changes", { 70 | expect_equal(controller$getParams("y", 1)$max, 5) 71 | expect_equal(controller$getParams("y", 2)$max, 5) 72 | controller$setValue("x", 3) 73 | expect_equal(controller$getParams("y", 1)$max, 3) 74 | expect_equal(controller$getParams("y", 2)$max, 3) 75 | }) 76 | 77 | } 78 | } 79 | 80 | -------------------------------------------------------------------------------- /man/manipulateWidget-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/zzz.R 3 | \docType{package} 4 | \name{manipulateWidget-package} 5 | \alias{manipulateWidget-package} 6 | \title{Add even more interactivity to interactive charts} 7 | \description{ 8 | This package is largely inspired by the \code{manipulate} package from 9 | Rstudio. It can be used to easily create graphical interface that let the 10 | user modify the data or the parameters of an interactive chart. It also 11 | provides the \code{\link{combineWidgets}} function to easily combine multiple 12 | interactive charts in a single view. 13 | } 14 | \details{ 15 | \code{\link{manipulateWidget}} is the main function of the package. It 16 | accepts an expression that generates an interactive chart (and more precisely 17 | an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you 18 | have never heard about it) and a set of controls created with functions 19 | \code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change 20 | values within the expression. Each time the user modifies the value of a 21 | control, the expression is evaluated again and the chart is updated. Consider 22 | the following code: 23 | 24 | \code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))} 25 | 26 | It will generate a graphical interface with a select input on its left with 27 | options "BE", "DE", "ES", "FR". By default, at the beginning the value of the 28 | variable \code{country} will be equal to the first choice of the 29 | corresponding input. So the function will first execute 30 | \code{myPlotFun("BE")} and the result will be displayed in the main panel of 31 | the interface. If the user changes the value to "FR", then the expression 32 | \code{myPlotFun("FR")} is evaluated and the new result is displayed. 33 | 34 | The interface also contains a button "Done". When the user clicks on it, the 35 | last chart is returned. It can be stored in a variable, be modified by the 36 | user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package 37 | \code{htmlwidgets} or converted to a static image file with package 38 | \code{webshot}. 39 | 40 | Finally one can easily create complex layouts thanks to function 41 | \code{\link{combineWidgets}}. For instance, assume we want to see a map that 42 | displays values of some variable for a given year, but on its right side we also 43 | want to see the distributions of three variables. Then we could write: 44 | 45 | \preformatted{ 46 | myPlotFun <- function(year, variable) { 47 | combineWidgets( 48 | ncol = 2, colSize = c(3, 1), 49 | myMap(year, variable), 50 | combineWidgets( 51 | ncol = 1, 52 | myHist(year, "V1"), 53 | myHist(year, "V2"), 54 | myHist(year, "V3"), 55 | ) 56 | ) 57 | } 58 | 59 | manipulateWidget( 60 | myPlotFun(year, variable), 61 | year = mwSlider(2000, 2016, value = 2000), 62 | variable = mwSelect(c("V1", "V2", "V3")) 63 | ) 64 | } 65 | 66 | Of course, \code{\link{combineWidgets}} can be used outside of 67 | \code{\link{manipulateWidget}}. For instance, it can be used in an 68 | Rmarkdown document to easily put together interactive charts. 69 | 70 | For more concrete examples of usage, you should look at the documentation and 71 | especially the examples of \code{\link{manipulateWidget}} and 72 | \code{\link{combineWidgets}}. 73 | } 74 | \seealso{ 75 | \code{\link{manipulateWidget}}, \code{\link{combineWidgets}} 76 | } 77 | -------------------------------------------------------------------------------- /R/shiny_module_compare_inputs.R: -------------------------------------------------------------------------------- 1 | compareInputsModuleUI <- function(id, allowCompare = TRUE) { 2 | ns <- NS(id) 3 | if (allowCompare) { 4 | shiny::uiOutput(ns("content")) 5 | } else { 6 | tags$div( 7 | style = "visibility:hidden;", 8 | shiny::uiOutput(ns("content")) 9 | ) 10 | } 11 | } 12 | 13 | compareInputsModuleServer <- function(input, output, session, ctrl) { 14 | ns <- session$ns 15 | 16 | output$content <- shiny::renderUI({ 17 | shiny::tagList( 18 | tags$div(class="separator"), 19 | checkboxInput(ns("compare"), ctrl$translations$compare, value = ctrl$ncharts > 1), 20 | shiny::conditionalPanel( 21 | sprintf("input['%s']", ns("compare")), 22 | shiny::selectInput( 23 | ns(".compareVars"), ctrl$translations$compareVars, 24 | choices = ctrl$uiSpec$getShareable(), 25 | selected = intersect(ctrl$uiSpec$getShareable(), ctrl$uiSpec$inputList$unshared()), 26 | multiple = TRUE 27 | ), 28 | tags$div( 29 | class = "compare-inputs", 30 | tags$div( 31 | shiny::numericInput(ns("nbCharts"), ctrl$translations$ncharts, 32 | value = max(2, ctrl$ncharts), min = 2, max = 12) 33 | ), 34 | tags$div( 35 | shiny::selectInput(ns("ncols"), ctrl$translations$ncol, c("auto", 1:4), selected = ctrl$ncol) 36 | ) 37 | ) 38 | ) 39 | ) 40 | }) 41 | 42 | nbCharts <- reactive({if (is.null(input$compare)) ctrl$ncharts else if (input$compare) input$nbCharts else 1}) 43 | 44 | observeEvent(input$compare, { 45 | if (!is.null(input$compare) && !input$compare) { 46 | for (n in intersect(ctrl$uiSpec$getShareable(), input$.compareVars)) { 47 | ctrl$uiSpec$shareInput(n) 48 | } 49 | updateSelectInput(session, ".compareVars", selected = list()) 50 | } 51 | }, ignoreInit = TRUE, ignoreNULL = FALSE) 52 | 53 | res <- reactiveValues() 54 | 55 | observe({ 56 | req(nbCharts()) 57 | i_ncols <- input$ncols 58 | if(is.null(i_ncols)) i_ncols <- ctrl$ncol 59 | if(is.null(i_ncols)) i_ncols <- "auto" 60 | if (nbCharts() == 1) { 61 | ncol <- 1 62 | } else if (i_ncols== "auto") { 63 | ncol <- NULL 64 | } else { 65 | ncol <- as.numeric(i_ncols) 66 | } 67 | dim <- .getRowAndCols(nbCharts(), ncol = ncol) 68 | res$n <- dim$n 69 | res$ncol <- dim$ncol 70 | res$nrow <- dim$nrow 71 | }) 72 | 73 | observeEvent(ignoreNULL = FALSE, ignoreInit = TRUE, input$.compareVars, { 74 | toUnshare <- setdiff(input$.compareVars, ctrl$uiSpec$inputList$unshared()) 75 | toShare <- setdiff( 76 | setdiff(ctrl$uiSpec$getShareable(), input$.compareVars), 77 | ctrl$uiSpec$inputList$shared() 78 | ) 79 | 80 | for (n in toUnshare) { 81 | ctrl$uiSpec$unshareInput(n) 82 | } 83 | 84 | for (n in toShare) { 85 | newSharedInputs <- ctrl$uiSpec$shareInput(n) 86 | if (length(newSharedInputs) > 0 & nbCharts() > 1) { 87 | for (i in 2:nbCharts()) ctrl$updateChart(i) 88 | } 89 | } 90 | 91 | unshared <- intersect(ctrl$uiSpec$getShareable(), ctrl$uiSpec$inputList$unshared()) 92 | if (!identical(sort(input$.compareVars), sort(unshared))) { 93 | shiny::updateSelectInput(session, ".compareVars", selected = unshared) 94 | } 95 | }) 96 | 97 | res$.compareVars <- reactive(input$.compareVars) 98 | 99 | res 100 | } 101 | -------------------------------------------------------------------------------- /man/mwModule.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module_ui.R, R/mw_ui.R 3 | \name{mwModule} 4 | \alias{mwModule} 5 | \alias{mwModuleUI} 6 | \title{Add a manipulateWidget to a shiny application} 7 | \usage{ 8 | mwModule(id, controller, fillPage = FALSE, ...) 9 | 10 | mwModuleUI( 11 | id, 12 | border = TRUE, 13 | okBtn = FALSE, 14 | saveBtn = TRUE, 15 | exportBtn = TRUE, 16 | updateBtn = FALSE, 17 | allowCompare = TRUE, 18 | margin = 0, 19 | width = "100\%", 20 | height = 400, 21 | header = NULL, 22 | footer = NULL 23 | ) 24 | } 25 | \arguments{ 26 | \item{id}{A unique string that identifies the module} 27 | 28 | \item{controller}{Object of class \code{\link{MWController}} returned by 29 | \code{\link{manipulateWidget}} when parameter \code{.runApp} is 30 | \code{FALSE}.} 31 | 32 | \item{fillPage}{: \code{logical}. Render in a fillPage or not ? Defaut to FALSE} 33 | 34 | \item{...}{named arguments containing reactive values. They can be used to send data from 35 | the main shiny application to the module.} 36 | 37 | \item{border}{Should a border be added to the module ?} 38 | 39 | \item{okBtn}{Should the UI contain the OK button ?} 40 | 41 | \item{saveBtn}{Should the UI contain the save button ? For saving output as html} 42 | 43 | \item{exportBtn}{Should an export button be added to the controls ? For saving output as png} 44 | 45 | \item{updateBtn}{Should the updateBtn be added to the UI ?} 46 | 47 | \item{allowCompare}{If \code{TRUE} (the default), then the user can use the 48 | UI to add or remove charts and choose which variables to compare} 49 | 50 | \item{margin}{Margin to apply around the module UI. Should be one two or four valid css 51 | units.} 52 | 53 | \item{width}{Width of the module UI.} 54 | 55 | \item{height}{Height of the module UI.} 56 | 57 | \item{header}{Tag or list of tags to display as a common header above all tabPanels.} 58 | 59 | \item{footer}{Tag or list of tags to display as a common footer below all tabPanels} 60 | } 61 | \value{ 62 | \code{mwModuleUI} returns the required HTML elements for the module. mwModule is only 63 | used for its side effects. 64 | } 65 | \description{ 66 | These two functions can be used to include a manipulateWidget object in a shiny application. 67 | \code{mwModuleUI} must be used in the UI to generate the required HTML elements and add 68 | javascript and css dependencies. \code{mwModule} must be called once in the server function 69 | of the application. 70 | } 71 | \examples{ 72 | if (interactive() & require("dygraphs")) { 73 | require("shiny") 74 | ui <- fillPage( 75 | fillRow( 76 | flex = c(NA, 1), 77 | div( 78 | textInput("title", label = "Title", value = "glop"), 79 | selectInput("series", "series", choices = c("series1", "series2", "series3")) 80 | ), 81 | mwModuleUI("ui", height = "100\%") 82 | )) 83 | 84 | server <- function(input, output, session) { 85 | mydata <- data.frame( 86 | year = 2000+1:100, 87 | series1 = rnorm(100), 88 | series2 = rnorm(100), 89 | series3 = rnorm(100) 90 | ) 91 | 92 | c <- manipulateWidget( 93 | { 94 | dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title) 95 | }, 96 | range = mwSlider(2001, 2100, c(2001, 2050)), 97 | series = mwSharedValue(), 98 | title = mwSharedValue(), .runApp = FALSE, 99 | .compare = "range" 100 | ) 101 | # 102 | mwModule("ui", c, title = reactive(input$title), series = reactive(input$series)) 103 | } 104 | 105 | shinyApp(ui, server) 106 | 107 | 108 | } 109 | 110 | } 111 | -------------------------------------------------------------------------------- /R/shiny_module_inputarea.R: -------------------------------------------------------------------------------- 1 | inputAreaModuleUI <- function(id, allowCompare = TRUE) { 2 | ns <- NS(id) 3 | shiny::conditionalPanel( 4 | sprintf("input['%s'] != -1", ns("chartid")), 5 | class = "mw-input-container", 6 | tags$div(style = "display:none;", 7 | shiny::textInput(ns("chartid"), label = "chartid") 8 | ), 9 | tags$div( 10 | class ="mw-inputs", 11 | style = "display:block;", 12 | tags$div( 13 | shiny::textOutput(ns("input_title")), 14 | class="input-title" 15 | ), 16 | tags$div( 17 | class = "mw-inputarea", 18 | shiny::uiOutput(ns("inputarea")) 19 | ), 20 | shiny::conditionalPanel( 21 | sprintf("input['%s'] == '0'", ns("chartid")), 22 | class = "mw-inputarea", 23 | compareInputsModuleUI(ns("compare"), allowCompare = allowCompare) 24 | ) 25 | ) 26 | ) 27 | } 28 | 29 | inputAreaModuleServer <- function(input, output, session, chartId, ctrl) { 30 | ns <- session$ns 31 | 32 | compareMod <- shiny::callModule(compareInputsModuleServer, "compare", ctrl) 33 | 34 | listeners <- c() 35 | visible <- reactive(input$visible()) 36 | 37 | # Controller initialization 38 | ctrl$setShinyInputSession(session) 39 | 40 | addListener <- function(i) { 41 | id <- i$getID() 42 | e <- new.env() 43 | e$firstCall <- TRUE 44 | if (!is.character(id)) return() 45 | if (id %in% listeners) return() 46 | if (ctrl$inputList[id]$type != "sharedValue") { 47 | observeEvent(input[[id]], { 48 | if (e$firstCall) { 49 | e$firstCall <- FALSE 50 | } else { 51 | ctrl$setValueById(id, value = input[[id]]) 52 | } 53 | }, ignoreNULL = FALSE) 54 | listeners <<- append(listeners, id) 55 | } 56 | } 57 | 58 | updateInputs <- function(chartId) { 59 | updateTextInput(session, "chartid", value = chartId) 60 | if (chartId == -1) { 61 | content <- "" 62 | } else { 63 | if (chartId == 0) { 64 | inputs <- ctrl$uiSpec$getInputsForChart(0) 65 | if (compareMod$n == 1 && length(ctrl$uiSpec$inputList$unshared()) > 0) { 66 | inputs <- c(inputs, ctrl$uiSpec$getInputsForChart(1)) 67 | } 68 | } else inputs <- ctrl$uiSpec$getInputsForChart(chartId) 69 | 70 | content <- shiny::tagList(lapply(inputs, function(x) {x$getHTML(ns)})) 71 | 72 | lapply(ctrl$uiSpec$inputList$inputTable$input, addListener) 73 | } 74 | 75 | output$inputarea <- shiny::renderUI(content) 76 | 77 | # Update visibility of inputs 78 | lapply(ctrl$inputList$inputTable$input, function(input) { 79 | # Update input visibility 80 | if (chartId != get(".id", envir = input$env)) return() 81 | # Hack to fix https://github.com/rstudio/shiny/issues/1490 82 | if (input$type == "select" && identical(input$lastParams$multiple, TRUE)) { 83 | input$valueHasChanged <- TRUE 84 | input$updateHTML(session) 85 | } 86 | }) 87 | } 88 | 89 | observeEvent(chartId(), { 90 | updateInputs(chartId()) 91 | 92 | if (chartId() == -1) title <- "" 93 | else if (chartId() == 0) title <- ctrl$translations$settings 94 | else title <- paste(ctrl$translations$chart, chartId()) 95 | output$input_title <- shiny::renderText(title) 96 | }) 97 | 98 | observeEvent(compareMod$.compareVars(), ignoreNULL = FALSE, ignoreInit = TRUE, { 99 | updateInputs(chartId()) 100 | }) 101 | 102 | res <- reactiveValues() 103 | observe(res$n <- compareMod$n) 104 | observe(res$ncol <- compareMod$ncol) 105 | observe(res$nrow <- compareMod$nrow) 106 | observe(res$displayIndBtns <- length(compareMod$.compareVars()) > 0) 107 | 108 | res 109 | } 110 | -------------------------------------------------------------------------------- /tests/testthat/test-controller.R: -------------------------------------------------------------------------------- 1 | context("MWController class") 2 | 3 | describe("MWController", { 4 | it("can be created with the result of initInputEnv()", { 5 | inputs <- initInputEnv(list(a = mwText("a"), b = mwText("b"))) 6 | expr <- expression(paste(a, b)) 7 | controller <- MWController(expr, inputs)$init() 8 | controller$updateCharts() 9 | expect_is(controller$charts, "list") 10 | expect_length(controller$charts, 1) 11 | expect_equal(controller$charts[[1]]$widgets[[1]], "a b") 12 | }) 13 | 14 | it("creates multiple charts in comparison mode", { 15 | inputs <- initInputEnv(list(a = mwText("a"), b = mwText("b")), compare = "b", 16 | ncharts = 3) 17 | expr <- expression(paste(a, b)) 18 | controller <- MWController(expr, inputs)$init() 19 | controller$updateCharts() 20 | expect_is(controller$charts, "list") 21 | expect_length(controller$charts, 3) 22 | for (o in controller$charts) expect_equal(o$widgets[[1]], "a b") 23 | }) 24 | 25 | it ("does not update charts if values do not change", { 26 | inputs <- initInputEnv(list(a = mwText("a"), b = mwText("b"))) 27 | expr <- expression(print("chart updated")) 28 | expect_output(controller <- MWController(expr, inputs)$init(), "chart updated") 29 | expect_output(controller$updateCharts(), "chart updated") 30 | # Update a with different value 31 | expect_output(controller$setValue("a", "b"), "chart updated") 32 | # Update a with same value 33 | expect_silent(controller$setValue("a", "b")) 34 | }) 35 | 36 | it("creates a copy that is completely autonomous", { 37 | inputs <- initInputEnv(list(grp = mwGroup(a = mwText("a"), b = mwText("b")))) 38 | expr <- expression(paste(a, b)) 39 | controller1 <- MWController(expr, inputs)$init() 40 | controller2 <- controller1$clone() 41 | 42 | controller1$setValue("a", "test") 43 | expect_equal(controller1$getValue("a"), "test") 44 | expect_equal(controller2$getValue("a"), "a") 45 | expect_true(controller2$initialized) 46 | expect_true(controller2$inputList$initialized) 47 | }) 48 | 49 | it("accesses parameters of a given input", { 50 | inputs <- initInputEnv(list(a = mwSelect(c("a", "b", "c")), b = mwText("b"))) 51 | expr <- expression(paste(a, b)) 52 | controller <- MWController(expr, inputs)$init() 53 | expect_equal(controller$getParams("a")$choices, c("a", "b", "c")) 54 | }) 55 | 56 | it("does not update values or create charts until it is initialized", { 57 | inputs <- initInputEnv(list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))) 58 | expr <- expression(paste(x, y)) 59 | controller <- MWController(expr, inputs) 60 | expect_length(controller$charts, 0) 61 | expect_equal(controller$getValue("y"), 0) 62 | controller$setValue("x", 3) 63 | expect_length(controller$charts, 0) 64 | expect_equal(controller$getValue("y"), 0) 65 | controller$init() 66 | expect_length(controller$charts, 1) 67 | expect_equal(controller$charts[[1]]$widgets[[1]], "3 3") 68 | expect_equal(controller$getValue("y"), 3) 69 | }) 70 | }) 71 | 72 | describe("summary.MWController", { 73 | it("prints information about controller", { 74 | controller <- manipulateWidget( 75 | d$value, 76 | a = mwSelect(c("a", "b", "c")), 77 | b = mwSelect(c("a", "b", "c"), "b"), 78 | c = mwSelect(c("a", "b", "c"), c("a", "b"), multiple = TRUE), 79 | d = mwSharedValue(data.frame(value = 1)), 80 | .runApp = FALSE 81 | ) 82 | expect_output(summary(controller), "List of inputs") 83 | # Indicates NULL values 84 | expect_output(summary(controller), "NULL") 85 | # paste values if multiple values 86 | expect_output(summary(controller), "a, b") 87 | # for complicated objects, indicates the class of object 88 | controller$init() 89 | expect_output(summary(controller), "data.frame") 90 | }) 91 | }) 92 | -------------------------------------------------------------------------------- /inst/lib/export/canvas-toBlob/canvas-toBlob.js: -------------------------------------------------------------------------------- 1 | /* canvas-toBlob.js 2 | * A canvas.toBlob() implementation. 3 | * 2016-05-26 4 | * 5 | * By Eli Grey, http://eligrey.com and Devin Samarin, https://github.com/eboyjr 6 | * License: MIT 7 | * See https://github.com/eligrey/canvas-toBlob.js/blob/master/LICENSE.md 8 | */ 9 | 10 | /*global self */ 11 | /*jslint bitwise: true, regexp: true, confusion: true, es5: true, vars: true, white: true, 12 | plusplus: true */ 13 | 14 | /*! @source http://purl.eligrey.com/github/canvas-toBlob.js/blob/master/canvas-toBlob.js */ 15 | 16 | (function(view) { 17 | "use strict"; 18 | var 19 | Uint8Array = view.Uint8Array 20 | , HTMLCanvasElement = view.HTMLCanvasElement 21 | , canvas_proto = HTMLCanvasElement && HTMLCanvasElement.prototype 22 | , is_base64_regex = /\s*;\s*base64\s*(?:;|$)/i 23 | , to_data_url = "toDataURL" 24 | , base64_ranks 25 | , decode_base64 = function(base64) { 26 | var 27 | len = base64.length 28 | , buffer = new Uint8Array(len / 4 * 3 | 0) 29 | , i = 0 30 | , outptr = 0 31 | , last = [0, 0] 32 | , state = 0 33 | , save = 0 34 | , rank 35 | , code 36 | , undef 37 | ; 38 | while (len--) { 39 | code = base64.charCodeAt(i++); 40 | rank = base64_ranks[code-43]; 41 | if (rank !== 255 && rank !== undef) { 42 | last[1] = last[0]; 43 | last[0] = code; 44 | save = (save << 6) | rank; 45 | state++; 46 | if (state === 4) { 47 | buffer[outptr++] = save >>> 16; 48 | if (last[1] !== 61 /* padding character */) { 49 | buffer[outptr++] = save >>> 8; 50 | } 51 | if (last[0] !== 61 /* padding character */) { 52 | buffer[outptr++] = save; 53 | } 54 | state = 0; 55 | } 56 | } 57 | } 58 | // 2/3 chance there's going to be some null bytes at the end, but that 59 | // doesn't really matter with most image formats. 60 | // If it somehow matters for you, truncate the buffer up outptr. 61 | return buffer; 62 | } 63 | ; 64 | if (Uint8Array) { 65 | base64_ranks = new Uint8Array([ 66 | 62, -1, -1, -1, 63, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1 67 | , -1, -1, 0, -1, -1, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 68 | , 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 69 | , -1, -1, -1, -1, -1, -1, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35 70 | , 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51 71 | ]); 72 | } 73 | if (HTMLCanvasElement && (!canvas_proto.toBlob || !canvas_proto.toBlobHD)) { 74 | if (!canvas_proto.toBlob) 75 | canvas_proto.toBlob = function(callback, type /*, ...args*/) { 76 | if (!type) { 77 | type = "image/png"; 78 | } if (this.mozGetAsFile) { 79 | callback(this.mozGetAsFile("canvas", type)); 80 | return; 81 | } if (this.msToBlob && /^\s*image\/png\s*(?:$|;)/i.test(type)) { 82 | callback(this.msToBlob()); 83 | return; 84 | } 85 | 86 | var 87 | args = Array.prototype.slice.call(arguments, 1) 88 | , dataURI = this[to_data_url].apply(this, args) 89 | , header_end = dataURI.indexOf(",") 90 | , data = dataURI.substring(header_end + 1) 91 | , is_base64 = is_base64_regex.test(dataURI.substring(0, header_end)) 92 | , blob 93 | ; 94 | if (Blob.fake) { 95 | // no reason to decode a data: URI that's just going to become a data URI again 96 | blob = new Blob 97 | if (is_base64) { 98 | blob.encoding = "base64"; 99 | } else { 100 | blob.encoding = "URI"; 101 | } 102 | blob.data = data; 103 | blob.size = data.length; 104 | } else if (Uint8Array) { 105 | if (is_base64) { 106 | blob = new Blob([decode_base64(data)], {type: type}); 107 | } else { 108 | blob = new Blob([decodeURIComponent(data)], {type: type}); 109 | } 110 | } 111 | callback(blob); 112 | }; 113 | 114 | if (!canvas_proto.toBlobHD && canvas_proto.toDataURLHD) { 115 | canvas_proto.toBlobHD = function() { 116 | to_data_url = "toDataURLHD"; 117 | var blob = this.toBlob(); 118 | to_data_url = "toDataURL"; 119 | return blob; 120 | } 121 | } else { 122 | canvas_proto.toBlobHD = canvas_proto.toBlob; 123 | } 124 | } 125 | }(typeof self !== "undefined" && self || typeof window !== "undefined" && window || this.content || this)); 126 | -------------------------------------------------------------------------------- /tests/testthat/test-manipulate_widget.R: -------------------------------------------------------------------------------- 1 | context("manipulateWidget") 2 | 3 | describe("manipulateWidget", { 4 | it("returns an uninitialized MWController in a non interactive situation", { 5 | c <- manipulateWidget( 6 | paste(a, b), 7 | a = mwSelect(c("a", "b", "c")), 8 | b = mwText("test"), 9 | .compare = "a", .runApp = FALSE 10 | ) 11 | expect_true(!c$initialized) 12 | }) 13 | 14 | it("creates two charts when .compare is a character vector", { 15 | c <- manipulateWidget( 16 | paste(a, b), 17 | a = mwSelect(c("a", "b", "c")), 18 | b = mwText("test"), 19 | .compare = "a", .runApp = FALSE 20 | ) 21 | c$init() 22 | expect_equal(c$ncharts, 2) 23 | expect_equal(c$getValue("a", 1), "a") 24 | expect_equal(c$getValue("a", 2), "a") 25 | }) 26 | 27 | it("creates two charts when .compare is a named list with null values", { 28 | c <- manipulateWidget( 29 | paste(a, b), 30 | a = mwSelect(c("a", "b", "c")), 31 | b = mwText("test"), 32 | .compare = list(a = NULL), .runApp = FALSE 33 | ) 34 | c$init() 35 | expect_equal(c$ncharts, 2) 36 | expect_equal(c$getValue("a", 1), "a") 37 | expect_equal(c$getValue("a", 2), "a") 38 | }) 39 | 40 | it("sets different values when .compare is a named list with non null values", { 41 | c <- manipulateWidget( 42 | paste(a, b), 43 | a = mwSelect(c("a", "b", "c")), 44 | b = mwText("test"), 45 | .compare = list(a = list("a", "b")), .runApp = FALSE 46 | ) 47 | c$init() 48 | expect_equal(c$ncharts, 2) 49 | expect_equal(c$getValue("a", 1), "a") 50 | expect_equal(c$getValue("a", 2), "b") 51 | expect_equal(c$charts[[1]]$widgets[[1]], "a test") 52 | expect_equal(c$charts[[2]]$widgets[[1]], "b test") 53 | }) 54 | 55 | it ("creates more than two charts", { 56 | c <- manipulateWidget( 57 | paste(a, b), 58 | a = mwSelect(c("a", "b", "c")), 59 | b = mwText("test"), 60 | .compare = list(a = list("a", "b", "c")), 61 | .compareOpts = compareOptions(ncharts = 3), .runApp = FALSE 62 | ) 63 | c$init() 64 | expect_equal(c$ncharts, 3) 65 | expect_equal(c$getValue("a", 1), "a") 66 | expect_equal(c$getValue("a", 2), "b") 67 | expect_equal(c$getValue("a", 2), "b") 68 | expect_equal(c$charts[[1]]$widgets[[1]], "a test") 69 | expect_equal(c$charts[[2]]$widgets[[1]], "b test") 70 | expect_equal(c$charts[[3]]$widgets[[1]], "c test") 71 | }) 72 | 73 | it ("updates dynamic inputs", { 74 | c <- manipulateWidget( 75 | x + y, 76 | x = mwSlider(0, 10, 5), 77 | y = mwSlider(0, x, 4), .runApp = FALSE 78 | ) 79 | c$init() 80 | expect_equal(c$getParams("y")$max, 5) 81 | c$setValue("x", 3) 82 | expect_equal(c$getParams("y")$max, 3) 83 | expect_equal(c$getValue("y"), 3) 84 | }) 85 | 86 | it ("conditionally shows/hides inputs", { 87 | c <- manipulateWidget( 88 | x + y, 89 | x = mwSlider(0, 10, 0), 90 | y = mwSlider(0, 10, 0, .display = x < 5), .runApp = FALSE 91 | ) 92 | c$init() 93 | expect_true(c$isVisible("y")) 94 | c$setValue("x", 6) 95 | expect_true(!c$isVisible("y")) 96 | }) 97 | 98 | it ("shares values between inputs and outputs", { 99 | c <- manipulateWidget( 100 | x2 + y, 101 | x = mwSlider(0, 10, 5), 102 | x2 = mwSharedValue(x * 2), 103 | y = mwSlider(0, x2, 0), .runApp = FALSE 104 | ) 105 | c$init() 106 | expect_equal(c$getParams("y")$max, 10) 107 | expect_equal(c$charts[[1]]$widgets[[1]], 10) 108 | c$setValue("x", 8) 109 | expect_equal(c$getValue("x2"), 16) 110 | expect_equal(c$getParams("y")$max, 16) 111 | expect_equal(c$charts[[1]]$widgets[[1]], 16) 112 | 113 | }) 114 | 115 | it ("modifies a sharedInput when it is not dynamic", { 116 | c <- manipulateWidget( 117 | x2 + y, 118 | x = mwSlider(0, 10, 5), 119 | x2 = mwSharedValue(1), 120 | x3 = mwSharedValue(x + x2), 121 | y = mwSlider(0, x2, 0), .runApp = FALSE 122 | ) 123 | c$init() 124 | expect_equal(c$getParams("y")$max, 1) 125 | expect_equal(c$charts[[1]]$widgets[[1]], 1) 126 | c$setValue("x2", 8) 127 | expect_equal(c$getValue("x2"), 8) 128 | expect_equal(c$getValue("x3"), 13) 129 | expect_equal(c$getParams("y")$max, 8) 130 | expect_equal(c$charts[[1]]$widgets[[1]], 8) 131 | c$setValue("x3", 10) # Dynamic shared input. Should not have any effect 132 | expect_equal(c$getValue("x3"), 13) 133 | }) 134 | }) 135 | -------------------------------------------------------------------------------- /inst/lib/export/FileSaver/README.md: -------------------------------------------------------------------------------- 1 | FileSaver.js 2 | ============ 3 | 4 | FileSaver.js implements the HTML5 W3C `saveAs()` FileSaver interface in browsers that do 5 | not natively support it. There is a [FileSaver.js demo][1] that demonstrates saving 6 | various media types. 7 | 8 | FileSaver.js is the solution to saving files on the client-side, and is perfect for 9 | webapps that need to generate files, or for saving sensitive information that shouldn't be 10 | sent to an external server. 11 | 12 | Looking for `canvas.toBlob()` for saving canvases? Check out 13 | [canvas-toBlob.js][2] for a cross-browser implementation. 14 | 15 | Supported browsers 16 | ------------------ 17 | 18 | | Browser | Constructs as | Filenames | Max Blob Size | Dependencies | 19 | | -------------- | ------------- | ------------ | ------------- | ------------ | 20 | | Firefox 20+ | Blob | Yes | 800 MiB | None | 21 | | Firefox < 20 | data: URI | No | n/a | [Blob.js](https://github.com/eligrey/Blob.js) | 22 | | Chrome | Blob | Yes | [500 MiB][3] | None | 23 | | Chrome for Android | Blob | Yes | [500 MiB][3] | None | 24 | | IE 10+ | Blob | Yes | 600 MiB | None | 25 | | Opera 15+ | Blob | Yes | 500 MiB | None | 26 | | Opera < 15 | data: URI | No | n/a | [Blob.js](https://github.com/eligrey/Blob.js) | 27 | | Safari 6.1+* | Blob | No | ? | None | 28 | | Safari < 6 | data: URI | No | n/a | [Blob.js](https://github.com/eligrey/Blob.js) | 29 | 30 | Feature detection is possible: 31 | 32 | ```js 33 | try { 34 | var isFileSaverSupported = !!new Blob; 35 | } catch (e) {} 36 | ``` 37 | 38 | ### IE < 10 39 | 40 | It is possible to save text files in IE < 10 without Flash-based polyfills. 41 | See [ChenWenBrian and koffsyrup's `saveTextAs()`](https://github.com/koffsyrup/FileSaver.js#examples) for more details. 42 | 43 | ### Safari 6.1+ 44 | 45 | Blobs may be opened instead of saved sometimes—you may have to direct your Safari users to manually 46 | press ⌘+S to save the file after it is opened. Using the `application/octet-stream` MIME type to force downloads [can cause issues in Safari](https://github.com/eligrey/FileSaver.js/issues/12#issuecomment-47247096). 47 | 48 | ### iOS 49 | 50 | saveAs must be run within a user interaction event such as onTouchDown or onClick; setTimeout will prevent saveAs from triggering. Due to restrictions in iOS saveAs opens in a new window instead of downloading, if you want this fixed please [tell Apple](https://bugs.webkit.org/show_bug.cgi?id=102914) how this bug is affecting you. 51 | 52 | Syntax 53 | ------ 54 | 55 | ```js 56 | FileSaver saveAs(Blob data, DOMString filename, optional Boolean disableAutoBOM) 57 | ``` 58 | 59 | Pass `true` for `disableAutoBOM` if you don't want FileSaver.js to automatically provide Unicode text encoding hints (see: [byte order mark](https://en.wikipedia.org/wiki/Byte_order_mark)). 60 | 61 | Examples 62 | -------- 63 | 64 | ### Saving text 65 | 66 | ```js 67 | var blob = new Blob(["Hello, world!"], {type: "text/plain;charset=utf-8"}); 68 | saveAs(blob, "hello world.txt"); 69 | ``` 70 | 71 | The standard W3C File API [`Blob`][4] interface is not available in all browsers. 72 | [Blob.js][5] is a cross-browser `Blob` implementation that solves this. 73 | 74 | ### Saving a canvas 75 | 76 | ```js 77 | var canvas = document.getElementById("my-canvas"), ctx = canvas.getContext("2d"); 78 | // draw to canvas... 79 | canvas.toBlob(function(blob) { 80 | saveAs(blob, "pretty image.png"); 81 | }); 82 | ``` 83 | 84 | Note: The standard HTML5 `canvas.toBlob()` method is not available in all browsers. 85 | [canvas-toBlob.js][6] is a cross-browser `canvas.toBlob()` that polyfills this. 86 | 87 | 88 | ![Tracking image](https://in.getclicky.com/212712ns.gif) 89 | 90 | [1]: http://eligrey.com/demos/FileSaver.js/ 91 | [2]: https://github.com/eligrey/canvas-toBlob.js 92 | [3]: https://code.google.com/p/chromium/issues/detail?id=375297 93 | [4]: https://developer.mozilla.org/en-US/docs/DOM/Blob 94 | [5]: https://github.com/eligrey/Blob.js 95 | [6]: https://github.com/eligrey/canvas-toBlob.js 96 | 97 | Contributing 98 | ------------ 99 | 100 | The `FileSaver.js` distribution file is compiled with Uglify.js like so: 101 | 102 | ```bash 103 | uglifyjs FileSaver.js --mangle --comments /@source/ > FileSaver.min.js 104 | ``` 105 | 106 | Please make sure you build a production version before submitting a pull request. 107 | 108 | Bower Installation 109 | ------------------ 110 | 111 | Please see the [this repo](http://github.com/Teleborder/FileSaver.js) for a bower-compatible fork of FileSaver.js, available under the package name `file-saver.js`. 112 | -------------------------------------------------------------------------------- /inst/lib/export/FileSaver/FileSaver.min.js: -------------------------------------------------------------------------------- 1 | /*! @source http://purl.eligrey.com/github/FileSaver.js/blob/master/FileSaver.js */ 2 | var saveAs=saveAs||function(view){"use strict";if(typeof navigator!=="undefined"&&/MSIE [1-9]\./.test(navigator.userAgent)){return}var doc=view.document,get_URL=function(){return view.URL||view.webkitURL||view},save_link=doc.createElementNS("http://www.w3.org/1999/xhtml","a"),can_use_save_link="download"in save_link,click=function(node){var event=new MouseEvent("click");node.dispatchEvent(event)},is_safari=/Version\/[\d\.]+.*Safari/.test(navigator.userAgent),webkit_req_fs=view.webkitRequestFileSystem,req_fs=view.requestFileSystem||webkit_req_fs||view.mozRequestFileSystem,throw_outside=function(ex){(view.setImmediate||view.setTimeout)(function(){throw ex},0)},force_saveable_type="application/octet-stream",fs_min_size=0,arbitrary_revoke_timeout=500,revoke=function(file){var revoker=function(){if(typeof file==="string"){get_URL().revokeObjectURL(file)}else{file.remove()}};if(view.chrome){revoker()}else{setTimeout(revoker,arbitrary_revoke_timeout)}},dispatch=function(filesaver,event_types,event){event_types=[].concat(event_types);var i=event_types.length;while(i--){var listener=filesaver["on"+event_types[i]];if(typeof listener==="function"){try{listener.call(filesaver,event||filesaver)}catch(ex){throw_outside(ex)}}}},auto_bom=function(blob){if(/^\s*(?:text\/\S*|application\/xml|\S*\/\S*\+xml)\s*;.*charset\s*=\s*utf-8/i.test(blob.type)){return new Blob(["\ufeff",blob],{type:blob.type})}return blob},FileSaver=function(blob,name,no_auto_bom){if(!no_auto_bom){blob=auto_bom(blob)}var filesaver=this,type=blob.type,blob_changed=false,object_url,target_view,dispatch_all=function(){dispatch(filesaver,"writestart progress write writeend".split(" "))},fs_error=function(){if(target_view&&is_safari&&typeof FileReader!=="undefined"){var reader=new FileReader;reader.onloadend=function(){var base64Data=reader.result;target_view.location.href="data:attachment/file"+base64Data.slice(base64Data.search(/[,;]/));filesaver.readyState=filesaver.DONE;dispatch_all()};reader.readAsDataURL(blob);filesaver.readyState=filesaver.INIT;return}if(blob_changed||!object_url){object_url=get_URL().createObjectURL(blob)}if(target_view){target_view.location.href=object_url}else{var new_tab=view.open(object_url,"_blank");if(new_tab==undefined&&is_safari){view.location.href=object_url}}filesaver.readyState=filesaver.DONE;dispatch_all();revoke(object_url)},abortable=function(func){return function(){if(filesaver.readyState!==filesaver.DONE){return func.apply(this,arguments)}}},create_if_not_found={create:true,exclusive:false},slice;filesaver.readyState=filesaver.INIT;if(!name){name="download"}if(can_use_save_link){object_url=get_URL().createObjectURL(blob);setTimeout(function(){save_link.href=object_url;save_link.download=name;click(save_link);dispatch_all();revoke(object_url);filesaver.readyState=filesaver.DONE});return}if(view.chrome&&type&&type!==force_saveable_type){slice=blob.slice||blob.webkitSlice;blob=slice.call(blob,0,blob.size,force_saveable_type);blob_changed=true}if(webkit_req_fs&&name!=="download"){name+=".download"}if(type===force_saveable_type||webkit_req_fs){target_view=view}if(!req_fs){fs_error();return}fs_min_size+=blob.size;req_fs(view.TEMPORARY,fs_min_size,abortable(function(fs){fs.root.getDirectory("saved",create_if_not_found,abortable(function(dir){var save=function(){dir.getFile(name,create_if_not_found,abortable(function(file){file.createWriter(abortable(function(writer){writer.onwriteend=function(event){target_view.location.href=file.toURL();filesaver.readyState=filesaver.DONE;dispatch(filesaver,"writeend",event);revoke(file)};writer.onerror=function(){var error=writer.error;if(error.code!==error.ABORT_ERR){fs_error()}};"writestart progress write abort".split(" ").forEach(function(event){writer["on"+event]=filesaver["on"+event]});writer.write(blob);filesaver.abort=function(){writer.abort();filesaver.readyState=filesaver.DONE};filesaver.readyState=filesaver.WRITING}),fs_error)}),fs_error)};dir.getFile(name,{create:false},abortable(function(file){file.remove();save()}),abortable(function(ex){if(ex.code===ex.NOT_FOUND_ERR){save()}else{fs_error()}}))}),fs_error)}),fs_error)},FS_proto=FileSaver.prototype,saveAs=function(blob,name,no_auto_bom){return new FileSaver(blob,name,no_auto_bom)};if(typeof navigator!=="undefined"&&navigator.msSaveOrOpenBlob){return function(blob,name,no_auto_bom){if(!no_auto_bom){blob=auto_bom(blob)}return navigator.msSaveOrOpenBlob(blob,name||"download")}}FS_proto.abort=function(){var filesaver=this;filesaver.readyState=filesaver.DONE;dispatch(filesaver,"abort")};FS_proto.readyState=FS_proto.INIT=0;FS_proto.WRITING=1;FS_proto.DONE=2;FS_proto.error=FS_proto.onwritestart=FS_proto.onprogress=FS_proto.onwrite=FS_proto.onabort=FS_proto.onerror=FS_proto.onwriteend=null;return saveAs}(typeof self!=="undefined"&&self||typeof window!=="undefined"&&window||this.content);if(typeof module!=="undefined"&&module.exports){module.exports.saveAs=saveAs}else if(typeof define!=="undefined"&&define!==null&&define.amd!=null){define([],function(){return saveAs})} 3 | -------------------------------------------------------------------------------- /newUI/manipulate_widget.css: -------------------------------------------------------------------------------- 1 | /* MENU */ 2 | 3 | .mw-menu { 4 | width:50px; 5 | height:100%; 6 | background-color: #f0f0f0; 7 | border-right:solid 1px #f0f0f0; 8 | padding-top: 30px; 9 | } 10 | 11 | 12 | /* general style for buttons */ 13 | .mw-btn { 14 | position: relative; 15 | width:50px; 16 | height:50px; 17 | cursor:pointer; 18 | } 19 | 20 | .mw-btn.active { 21 | background-color: #4e9cff; 22 | } 23 | 24 | /* Arrow that is displayed when a button is active*/ 25 | .right-arrow { 26 | width: 0; 27 | height: 0; 28 | border-style: solid; 29 | border-width: 25px 0 25px 10px; 30 | border-color: transparent transparent transparent #4e9cff; 31 | position: absolute; 32 | top:0; 33 | left: 50px; 34 | display:none; 35 | } 36 | 37 | .mw-btn:hover .right-arrow { 38 | border-color: transparent transparent transparent #2b7be2; 39 | } 40 | 41 | .active .right-arrow { 42 | display: block; 43 | } 44 | 45 | /* Settings button */ 46 | .mw-btn-settings { 47 | margin-bottom: 30px; 48 | padding: 2px; 49 | } 50 | 51 | .bt1 { 52 | color: #4e9cff; 53 | text-align: center; 54 | vertical-align: bottom; 55 | line-height: 44px; 56 | font-size: 30px; 57 | background-color: white; 58 | border: solid 1px #4e9cff; 59 | } 60 | .bt1:hover { 61 | color:#fff; 62 | border:solid 1px #2b7be2; 63 | background-color: #2b7be2; 64 | } 65 | 66 | .mw-btn-settings.active { 67 | border: none; 68 | color: white; 69 | } 70 | 71 | .mw-btn-settings.active .bt1 { 72 | color: white; 73 | background-color: #4e9cff; 74 | } 75 | 76 | .mw-btn-settings.active:hover .bt1 { 77 | color: white; 78 | background-color: #2b7be2; 79 | } 80 | 81 | .mw-btn-settings:hover { 82 | color:#fff; 83 | border:solid 1px #2b7be2; 84 | background-color: #2b7be2; 85 | } 86 | 87 | .mw-btn-settings.active:hover { 88 | color:white; 89 | background-color: #2b7be2; 90 | border: none; 91 | } 92 | 93 | /* Buttons used to display inputs for a specific area */ 94 | .mw-btn-area { 95 | padding: 10px 3.3px; 96 | } 97 | 98 | .mw-btn-area:hover { 99 | background-color: #2b7be2; 100 | } 101 | 102 | .mw-icon-areachart { 103 | position:relative; 104 | background-color: white; 105 | border: solid 1px #4e9cff; 106 | width: 44px; 107 | height: 30px; 108 | } 109 | 110 | .mw-icon-chart { 111 | position: absolute; 112 | background-color: #4e9cff; 113 | } 114 | 115 | .mw-btn:hover .mw-icon-chart { 116 | background-color: #2b7be2; 117 | } 118 | 119 | 120 | /* OK button */ 121 | .mw-btn-ok { 122 | margin: 0 3px; 123 | width: 44px; 124 | height: 44px; 125 | position: absolute; 126 | bottom: 30px; 127 | background-color: #26b48b; 128 | color: white; 129 | text-align: center; 130 | vertical-align: bottom; 131 | line-height: 44px; 132 | border-radius: 5px; 133 | font-size: 20px; 134 | font-weight: bold; 135 | padding:0; 136 | } 137 | 138 | .mw-btn-ok:hover, .mw-btn-ok:active, .mw-btn-ok:focus { 139 | color: white; 140 | background-color: #0b946c; 141 | } 142 | 143 | /* /!\ DO NOT MODIFY THE REST OF THE FILE /!\ */ 144 | 145 | html, body { 146 | height:100%; 147 | } 148 | 149 | .mw-container { 150 | display: flex; 151 | display: -webkit-flex; 152 | display: -moz-flex; 153 | display: -ms-flex; 154 | flex-direction: row; 155 | -webkit-flex-direction: row; 156 | -moz-flex-direction: row; 157 | -ms-flex-direction: row; 158 | height:100%; 159 | width:100%; 160 | } 161 | 162 | .mw-input-container { 163 | height:100%; 164 | } 165 | 166 | .mw-inputs { 167 | width: 200px; 168 | height:100%; 169 | display:none; 170 | border-right:solid 1px #4e9cff; 171 | padding:10px; 172 | } 173 | 174 | .mw-chartarea { 175 | flex: 1; 176 | -webkit-flex: 1; 177 | -moz-flex: 1; 178 | -ms-flex: 1; 179 | } 180 | 181 | .mw-chart { 182 | width:100%; 183 | height:100%; 184 | border: solid 3px red; 185 | } 186 | 187 | .mw-btn-update { 188 | padding: 2px; 189 | } 190 | 191 | .mw-btn-update .bt1 { 192 | height: 46px; 193 | width: 46px; 194 | padding: 2px; 195 | } 196 | 197 | .mw-btn-update .bt1:focus { 198 | color: #4e9cff; 199 | background-color: white; 200 | border-color: #4e9cff; 201 | } 202 | 203 | .mw-btn-update>.bt1:hover { 204 | color: white; 205 | background-color: #2b7be2; 206 | border-color: #2b7be2; 207 | } 208 | 209 | .mw-btn-update .bt1:active { 210 | color: white; 211 | background-color: #4e9cff; 212 | border-color: #4e9cff; 213 | } 214 | 215 | 216 | .mw-chart-selection { 217 | margin-bottom: 30px; 218 | } 219 | 220 | /* Group of inputs */ 221 | .panel-default>.panel-heading { 222 | background-color: #f0f0f0; 223 | } 224 | 225 | .panel-heading .arrow { 226 | width: 22px; 227 | text-align: center; 228 | } 229 | 230 | .panel-heading .arrow::before { 231 | font-family: FontAwesome; 232 | font-size: 20px; 233 | content: "\f0d7"; 234 | display: inline-block; 235 | padding-right: 10px; 236 | vertical-align: middle; 237 | } 238 | 239 | .panel-heading.collapsed .arrow::before { 240 | content: "\f0da"; 241 | } 242 | -------------------------------------------------------------------------------- /R/mw_ui.R: -------------------------------------------------------------------------------- 1 | #' Private function that generates the general layout of the application 2 | #' 3 | #' @param ns namespace function created with shiny::NS(). Useful to create 4 | #' modules. 5 | #' @param inputs Object returned by preprocessInputs 6 | #' @param ncol Number of columns in the chart area. 7 | #' @param nrow Number of rows in the chart area. 8 | #' @param outputFun Function that generates the html elements that will contain 9 | #' a given widget 10 | #' @param okBtn Should the OK Button be added to the UI ? 11 | #' @param saveBtn Should an save button be added to the controls ? For saving output as html. Does not work in RStudio Viewer 12 | #' @param exportBtn Should an export button be added to the controls ? For saving output as png. Does not work in RStudio Viewer 13 | #' @param exportType \code{.exportBtn}, using \code{html2canvas} (default) and keeping current zoom, ... or using \code{webshot} 14 | #' @param updateBtn Should the updateBtn be added to the UI ? 15 | #' @param width, height Must be a valid CSS unit (like "100%", "400px", "auto") or a number, 16 | #' which will be coerced to a string and have "px" appended. Default to "100%" & "400px" 17 | #' 18 | #' @return shiny tags 19 | #' 20 | #' @noRd 21 | mwUI <- function(id, nrow = 1, ncol = 1, okBtn = TRUE, 22 | saveBtn = TRUE, exportBtn = TRUE, exportType = "html2canvas", 23 | updateBtn = FALSE, areaBtns = TRUE, border = FALSE, 24 | width = "100%", height = "400px", 25 | fillPage = TRUE, allowCompare = TRUE) { 26 | 27 | ns <- NS(id) 28 | htmldep <- htmltools::htmlDependency( 29 | "manipulateWidget", 30 | "0.7.0", 31 | system.file("manipulate_widget", package = "manipulateWidget"), 32 | script = "manipulate_widget.js", 33 | style = "manipulate_widget.css" 34 | ) 35 | 36 | if(exportBtn & (exportType %in% "html2canvas")) { 37 | 38 | fileSaver_dep <- htmltools::htmlDependency( 39 | name = "FileSaver", 40 | version = "1.1.20151003", 41 | src = c(file=system.file("lib/export/FileSaver", package="manipulateWidget")), 42 | script = "FileSaver.min.js" 43 | ) 44 | 45 | Blob_dep <- htmltools::htmlDependency( 46 | name = "Blob", 47 | version = "1.0", 48 | src = c(file=system.file("lib/export/Blob", package="manipulateWidget")), 49 | script = "Blob.js" 50 | ) 51 | 52 | canvastoBlob_dep <- htmltools::htmlDependency( 53 | name = "canvas-toBlob", 54 | version = "1.0", 55 | src = c(file=system.file("lib/export/canvas-toBlob", package="manipulateWidget")), 56 | script = "canvas-toBlob.js" 57 | ) 58 | 59 | html2canvas_dep <- htmltools::htmlDependency( 60 | name = "html2canvas", 61 | version = "1.0", 62 | src = c(file=system.file("lib/export/html2canvas", package="manipulateWidget")), 63 | script = "html2canvas.js" 64 | ) 65 | 66 | htmldep <- list(htmldep, fileSaver_dep, Blob_dep, canvastoBlob_dep, html2canvas_dep) 67 | } 68 | 69 | if (border) class <- "mw-container with-border" 70 | else class <- "mw-container" 71 | 72 | content <- fillRow( 73 | flex = c(NA, NA, 1), 74 | width = width, height = height, 75 | menuModuleUI(ns("menu"), updateBtn = updateBtn, saveBtn = saveBtn, 76 | okBtn = okBtn, exportBtn = exportBtn, exportType = exportType), 77 | inputAreaModuleUI(ns("inputarea"), allowCompare = allowCompare), 78 | gridModuleUI(ns("grid")) 79 | ) 80 | 81 | if(fillPage){ 82 | container <- fillPage( 83 | shinyjs::useShinyjs(), 84 | tags$div( 85 | id = ns("ui"), 86 | class = class, 87 | style = paste("width:", width, ";height:", height, ";", sep = ""), 88 | content 89 | ) 90 | ) 91 | } else { 92 | container <- tags$div( 93 | id = ns("ui"), 94 | class = class, 95 | style = paste("width:", width, ";height:", height, ";", sep = ""), 96 | shinyjs::useShinyjs(), 97 | content 98 | ) 99 | } 100 | 101 | htmltools::attachDependencies(container, htmldep, TRUE) 102 | } 103 | 104 | 105 | #' @param border Should a border be added to the module ? 106 | #' @param okBtn Should the UI contain the OK button ? 107 | #' @param saveBtn Should the UI contain the save button ? For saving output as html 108 | #' @param exportBtn Should an export button be added to the controls ? For saving output as png 109 | #' @param updateBtn Should the updateBtn be added to the UI ? 110 | #' @param margin Margin to apply around the module UI. Should be one two or four valid css 111 | #' units. 112 | #' @param width Width of the module UI. 113 | #' @param height Height of the module UI. 114 | #' @param header Tag or list of tags to display as a common header above all tabPanels. 115 | #' @param footer Tag or list of tags to display as a common footer below all tabPanels 116 | #' @inheritParams compareOptions 117 | #' 118 | #' @rdname mwModule 119 | #' @export 120 | mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, 121 | exportBtn = TRUE, updateBtn = FALSE, allowCompare = TRUE, 122 | margin = 0, width = "100%", height = 400, header = NULL, footer = NULL) { 123 | res <- mwUI(id, border = border, okBtn = okBtn, saveBtn = saveBtn, exportBtn = exportBtn, 124 | allowCompare = allowCompare, updateBtn = updateBtn, 125 | width = width, height = height, fillPage = FALSE) 126 | shiny::tagList( 127 | header, 128 | res, 129 | footer 130 | ) 131 | } 132 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | # Copyright © 2016 RTE Réseau de transport d’électricité 2 | 3 | #' @name manipulateWidget-package 4 | #' 5 | #' @title Add even more interactivity to interactive charts 6 | #' 7 | #' @description 8 | #' This package is largely inspired by the \code{manipulate} package from 9 | #' Rstudio. It can be used to easily create graphical interface that let the 10 | #' user modify the data or the parameters of an interactive chart. It also 11 | #' provides the \code{\link{combineWidgets}} function to easily combine multiple 12 | #' interactive charts in a single view. 13 | #' 14 | #' @details 15 | #' \code{\link{manipulateWidget}} is the main function of the package. It 16 | #' accepts an expression that generates an interactive chart (and more precisely 17 | #' an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you 18 | #' have never heard about it) and a set of controls created with functions 19 | #' \code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change 20 | #' values within the expression. Each time the user modifies the value of a 21 | #' control, the expression is evaluated again and the chart is updated. Consider 22 | #' the following code: 23 | #' 24 | #' \code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))} 25 | #' 26 | #' It will generate a graphical interface with a select input on its left with 27 | #' options "BE", "DE", "ES", "FR". By default, at the beginning the value of the 28 | #' variable \code{country} will be equal to the first choice of the 29 | #' corresponding input. So the function will first execute 30 | #' \code{myPlotFun("BE")} and the result will be displayed in the main panel of 31 | #' the interface. If the user changes the value to "FR", then the expression 32 | #' \code{myPlotFun("FR")} is evaluated and the new result is displayed. 33 | #' 34 | #' The interface also contains a button "Done". When the user clicks on it, the 35 | #' last chart is returned. It can be stored in a variable, be modified by the 36 | #' user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package 37 | #' \code{htmlwidgets} or converted to a static image file with package 38 | #' \code{webshot}. 39 | #' 40 | #' Finally one can easily create complex layouts thanks to function 41 | #' \code{\link{combineWidgets}}. For instance, assume we want to see a map that 42 | #' displays values of some variable for a given year, but on its right side we also 43 | #' want to see the distributions of three variables. Then we could write: 44 | #' 45 | #' \preformatted{ 46 | #' myPlotFun <- function(year, variable) { 47 | #' combineWidgets( 48 | #' ncol = 2, colSize = c(3, 1), 49 | #' myMap(year, variable), 50 | #' combineWidgets( 51 | #' ncol = 1, 52 | #' myHist(year, "V1"), 53 | #' myHist(year, "V2"), 54 | #' myHist(year, "V3"), 55 | #' ) 56 | #' ) 57 | #' } 58 | #' 59 | #' manipulateWidget( 60 | #' myPlotFun(year, variable), 61 | #' year = mwSlider(2000, 2016, value = 2000), 62 | #' variable = mwSelect(c("V1", "V2", "V3")) 63 | #' ) 64 | #' } 65 | #' 66 | #' Of course, \code{\link{combineWidgets}} can be used outside of 67 | #' \code{\link{manipulateWidget}}. For instance, it can be used in an 68 | #' Rmarkdown document to easily put together interactive charts. 69 | #' 70 | #' For more concrete examples of usage, you should look at the documentation and 71 | #' especially the examples of \code{\link{manipulateWidget}} and 72 | #' \code{\link{combineWidgets}}. 73 | #' 74 | #' @seealso \code{\link{manipulateWidget}}, \code{\link{combineWidgets}} 75 | #' 76 | #' @rdname manipulateWidget-package 77 | #' @docType package 78 | #' @importFrom shiny tags observe observeEvent reactive isolate icon tagAppendChild 79 | #' @importFrom shiny tagAppendChildren fillPage fillRow NS uiOutput checkboxInput 80 | #' callModule reactiveVal reactiveValues renderUI req updateSelectInput updateTextInput 81 | #' @importFrom miniUI miniContentPanel miniPage miniTabPanel miniTabstripPanel gadgetTitleBar 82 | #' @importFrom htmlwidgets getDependency 83 | #' @importFrom methods is new setRefClass 84 | #' @importFrom utils getFromNamespace 85 | #' @importFrom stats runif 86 | NULL 87 | 88 | #' Evolution of energy use per country 89 | #' 90 | #' Data.frame containing energy consumption per country from 1960 to 2014. The 91 | #' data comes from the World Bank website. It contains one line per 92 | #' couple(country, year) and has the following columns: 93 | #' 94 | #' \itemize{ 95 | #' \item country Country name 96 | #' \item iso2c Country code in two characters 97 | #' \item year Year 98 | #' \item population Population of the country 99 | #' \item energy_used_per_capita Energy used per capita in kg of oil equivalent (EG.USE.PCAP.KG.OE) 100 | #' \item energy_imported_prop Proportion of energy used that has been imported (EG.IMP.CONS.ZS) 101 | #' \item energy_fossil_prop Fossil fuel energy consumption in proportion of total consumption (EG.USE.COMM.FO.ZS) 102 | #' \item energy_used Energy consumption in kg of oil equivalent 103 | #' \item energy_fossil Fossil fuel energy consumption in kg of oil equivalent 104 | #' \item prop_world_energy_used Share of the country in the world energy consumption 105 | #' \item prop_world_energy_fossil Share of the country in the world fossil energy consumption 106 | #' \item prop_world_population Share of the country in the world population 107 | #' \item long Longitude of the country 108 | #' \item lat Lattitude of the country 109 | #' \item region Region of the country 110 | #' } 111 | #' 112 | #' @author François Guillem \email{guillem.francois@gmail.com} 113 | #' @references \url{https://data.worldbank.org/indicator} 114 | "worldEnergyUse" 115 | 116 | 117 | 118 | 119 | 120 | globalVariables(c("mod", "multiple", "name", "type")) 121 | -------------------------------------------------------------------------------- /inst/examples/manipulate_widget.R: -------------------------------------------------------------------------------- 1 | # Basic example with fake data 2 | if (require(dygraphs)) { 3 | mydata <- data.frame(period = 1:100, value = rnorm(100)) 4 | manipulateWidget(dygraph(mydata[range[1]:range[2], ], main = title), 5 | range = mwSlider(1, 100, c(1, 100)), 6 | title = mwText("Fictive time series")) 7 | } 8 | 9 | # Let use manipulateWidget to explore the evolution of energy consumption in 10 | # the world 11 | data("worldEnergyUse") 12 | 13 | if (require(plotly)) { 14 | # Function that generates a chart representing the evolution of energy 15 | # consumption per country. Creating a function is not necessary. We do it 16 | # for clarity and reuse in the different examples. 17 | plotEnergyUse <- function(Country, Period, lwd = 2, col = "gray") { 18 | dataset <- subset( 19 | worldEnergyUse, 20 | country == Country & year >= Period[1] & year <= Period[2] 21 | ) 22 | plot_ly(dataset) %>% 23 | add_lines(~year, ~energy_used, line = list(width = lwd, color = col)) %>% 24 | layout(title = paste("Energy used in", Country)) 25 | } 26 | 27 | # Launch the interactive visualisation 28 | manipulateWidget( 29 | plotEnergyUse(Country, Period), 30 | Period = mwSlider(1960, 2014, c(1960, 2014)), 31 | Country = mwSelect(sort(unique(worldEnergyUse$country)), "United States") 32 | ) 33 | 34 | # Directly start comparison mode 35 | manipulateWidget( 36 | plotEnergyUse(Country, Period), 37 | Period = mwSlider(1960, 2014, c(1960, 2014)), 38 | Country = mwSelect(sort(unique(worldEnergyUse$country))), 39 | .compare = list(Country = c("United States", "China")), 40 | .compareOpts = compareOptions(ncol = 2) 41 | ) 42 | 43 | # Dynamic input parameters 44 | #------------------------- 45 | # The arguments of an input can depend on the values of other inputs. 46 | # In this example, when the user changes the region, the choices of input 47 | # "Country" are updated with the countries of that region. 48 | 49 | # First we create a list that contains for each region the countries in that 50 | # retion 51 | refRegions <- by(worldEnergyUse$country, worldEnergyUse$region, 52 | function(x) as.character(sort(unique(x)))) 53 | 54 | manipulateWidget( 55 | plotEnergyUse(Country, Period), 56 | Period = mwSlider(1960, 2014, c(1960, 2014)), 57 | Region = mwSelect(sort(unique(worldEnergyUse$region))), 58 | Country = mwSelect(choices = refRegions[[Region]]) 59 | ) 60 | 61 | # Grouping inputs 62 | #---------------- 63 | # Inputs can be visually grouped with function mwGroup() 64 | manipulateWidget( 65 | plotEnergyUse(Country, Period, lwd, col), 66 | Period = mwSlider(1960, 2014, c(1960, 2014)), 67 | Country = mwSelect(sort(unique(worldEnergyUse$country)), "United States"), 68 | `Graphical Parameters` = mwGroup( 69 | lwd = mwSlider(1,10, 2, label = "Line Width"), 70 | col = mwSelect(choices = c("gray", "black", "red")) 71 | ) 72 | ) 73 | 74 | # Conditional inputs 75 | #------------------- 76 | # Inputs can be displayed or hidden depending on the state of other inputs. 77 | # In this example, user can choose to display the level of aggregation 78 | # (region or country). Depending on the choixe, the application displays 79 | # input Region or input Country. 80 | plotEnergyUseRegion <- function(Region, Period, lwd = 2, col = "gray") { 81 | dataset <- subset( 82 | worldEnergyUse, 83 | region == Region & year >= Period[1] & year <= Period[2] 84 | ) 85 | dataset <- aggregate(energy_used ~ year, sum, data = dataset) 86 | 87 | plot_ly(dataset) %>% 88 | add_lines(~year, ~energy_used, line = list(width = lwd, color = col)) %>% 89 | layout(title = paste("Energy used in", Region)) 90 | } 91 | 92 | manipulateWidget( 93 | { 94 | if (Level == "Region") { 95 | plotEnergyUseRegion(Region, Period) 96 | } else { 97 | plotEnergyUse(Country, Period) 98 | } 99 | }, 100 | Period = mwSlider(1960, 2014, c(1960, 2014)), 101 | Level = mwSelect(c("Region", "Country")), 102 | Region = mwSelect(sort(unique(worldEnergyUse$region)), 103 | .display = Level == "Region"), 104 | Country = mwSelect(sort(unique(worldEnergyUse$country)), 105 | .display = Level == "Country") 106 | ) 107 | 108 | } 109 | 110 | # Advanced Usage 111 | # -------------- 112 | # When .expr is evaluated with tehnical variables: 113 | # .initial: is it the first evaluation? 114 | # .outputId: integer representing the id of the chart 115 | # .output: shiny output id 116 | # .session: shiny session 117 | # They can be used to update an already rendered widget instead of replacing 118 | # it each time an input value is modified. 119 | # 120 | # In this example, we represent on a map, the energy use of countries. 121 | # When the user changes an input, the map is not redrawn. Only the circle 122 | # markers are updated. 123 | if (require(leaflet)) { 124 | plotMap <- function(Year, MaxRadius = 30, .initial, .session, .output) { 125 | dataset <- subset(worldEnergyUse, year == Year) 126 | radius <- sqrt(dataset$energy_used) / 127 | max(sqrt(worldEnergyUse$energy_used), na.rm = TRUE) * MaxRadius 128 | 129 | if (.initial) { # map has not been rendered yet 130 | map <- leaflet() %>% addTiles() 131 | } else { # map already rendered 132 | map <- leafletProxy(.output, .session) %>% clearMarkers() 133 | } 134 | 135 | map %>% addCircleMarkers(dataset$long, dataset$lat, radius = radius, 136 | color = "gray", weight = 0, fillOpacity = 0.7) 137 | } 138 | 139 | manipulateWidget( 140 | plotMap(Year, MaxRadius, .initial, .session, .output), 141 | Year = mwSlider(1960, 2014, 2014), 142 | MaxRadius = mwSlider(10, 50, 20) 143 | ) 144 | } 145 | -------------------------------------------------------------------------------- /R/shiny_module_menu.R: -------------------------------------------------------------------------------- 1 | menuModuleUI <- function(id, okBtn = TRUE, saveBtn = TRUE, updateBtn = FALSE, 2 | exportBtn = TRUE, exportType = "html2canvas") { 3 | ns <- NS(id) 4 | 5 | container <- tags$div( 6 | class="mw-menu", 7 | # Main Settings button 8 | tags$div( 9 | style = "padding:0;", 10 | class = "mw-btn mw-btn-settings", 11 | onclick = sprintf("select(this, '%s')", ns("mw-shared-inputs")), 12 | shiny::actionButton(ns(".settings"), "", icon = shiny::icon("gears"), class = "bt1 settings"), 13 | tags$div(class="right-arrow") 14 | ), 15 | uiOutput(ns("chart_btns")) 16 | ) 17 | 18 | if (updateBtn) { 19 | updateBtn <- tags$div( 20 | class = "mw-btn mw-btn-update", 21 | shiny::actionButton(ns(".update"), "", icon = shiny::icon("refresh"), class = "bt1") 22 | ) 23 | container <- tagAppendChild(container, updateBtn) 24 | } 25 | 26 | actionButtons <- tags$div(class = "action-buttons-container") 27 | 28 | if (saveBtn) { 29 | saveBtnInput <- shiny::downloadButton(ns("save"), label = "", class = "mw-btn mw-btn-save") 30 | actionButtons <- tagAppendChild(actionButtons, saveBtnInput) 31 | } 32 | 33 | if (exportBtn) { 34 | if(exportType %in% "html2canvas"){ 35 | exportBtnInput <- shiny::actionButton(ns("export_html2canvas"), icon = icon("camera"), label = "", 36 | class = "mw-btn mw-btn-export", 37 | onclick = sprintf("saveAsPNG('%s')", "mw-chartarea")) 38 | } else { 39 | # exportBtnInput <- shiny::downloadButton(ns("export"), icon = icon("camera"), label = "", 40 | # class = "mw-btn mw-btn-export") 41 | exportBtnInput <- tags$a(id = ns("export"), 42 | class = paste("btn btn-default shiny-download-link", 43 | "mw-btn mw-btn-export"), href = "", target = "_blank", download = NA, 44 | icon("camera"), "") 45 | } 46 | 47 | actionButtons <- tagAppendChild(actionButtons, exportBtnInput) 48 | } 49 | 50 | if (okBtn) { 51 | okBtnInput <- shiny::actionButton(ns("done"), "OK", class = "mw-btn mw-btn-ok") 52 | actionButtons <- tagAppendChild(actionButtons, okBtnInput) 53 | } 54 | 55 | tagAppendChild(container, actionButtons) 56 | } 57 | 58 | menuModuleServer <- function(input, output, session, ncharts, nrow, ncol, 59 | displayIndBtns, ctrl) { 60 | ns <- session$ns 61 | 62 | chartId <- shiny::reactiveVal(-1) 63 | 64 | state <- reactive({ 65 | list( 66 | chartId = chartId(), 67 | done = input$done, 68 | update = input$.update, 69 | save = input$save 70 | ) 71 | }) 72 | 73 | listeners <- character() 74 | 75 | # Eventually add listeners 76 | observe({ 77 | req(ncharts()) 78 | ids <- ns(paste0("mw-ind-inputs-", seq_len(ncharts()))) 79 | 80 | lapply(seq_along(ids), function(i) { 81 | if (! ids[[i]] %in% listeners) { 82 | observeEvent(input[[ids[i]]], { 83 | if (chartId() == i) chartId(-1) 84 | else chartId(i) 85 | }) 86 | } 87 | }) 88 | 89 | listeners <<- union(listeners, ids) 90 | }) 91 | 92 | # If user removes current chart, update chartId 93 | observeEvent(ncharts(), { 94 | if (chartId() > ncharts() | (chartId() == 1 & ncharts() == 1)) { 95 | chartId(-1) 96 | } 97 | }) 98 | 99 | output$chart_btns <- renderUI({ 100 | req(ncharts()) 101 | if (ncharts() < 2 || !displayIndBtns()) "" 102 | else { 103 | ids <- ns(paste0("mw-ind-inputs-", seq_len(ncharts()))) 104 | 105 | btns <- lapply(seq_len(ncharts()), function(i) { 106 | if (i == chartId()) active_class <- " active" 107 | else active_class <- "" 108 | 109 | tags$div( 110 | class = paste0("mw-btn mw-btn-area", active_class), 111 | style = "padding:0;", 112 | onclick = sprintf("select(this,'%s')", ids[i]), 113 | shiny::actionButton( 114 | ns(ids[i]), class = "bt1 area", 115 | .uiChartIcon(i, nrow(), ncol()) 116 | ), 117 | tags$div(class="right-arrow") 118 | ) 119 | }) 120 | btns$class <- "mw-chart-selection" 121 | 122 | do.call(tags$div, btns) 123 | } 124 | }) 125 | 126 | observeEvent(input$.settings, { 127 | if (chartId() == 0) chartId(-1) 128 | else chartId(0) 129 | }) 130 | 131 | output$save <- shiny::downloadHandler( 132 | filename = function() { 133 | paste('mw-', Sys.Date(), '.html', sep='') 134 | }, 135 | content = function(con) { 136 | htmlwidgets::saveWidget(widget = onDone(ctrl$clone(), stopApp = FALSE), 137 | file = con, selfcontained = TRUE) 138 | } 139 | ) 140 | 141 | output$export <- shiny::downloadHandler( 142 | filename = function() { 143 | paste('mw-', Sys.Date(), '.png', sep='') 144 | }, 145 | content = function(con) { 146 | tmp_html <- tempfile(fileext=".html") 147 | htmlwidgets::saveWidget(widget = onDone(ctrl$clone(), stopApp = FALSE), 148 | file = tmp_html, selfcontained = TRUE) 149 | webshot::webshot(url = tmp_html, file = con) 150 | } 151 | ) 152 | 153 | return(state) 154 | } 155 | 156 | 157 | .uiChartIcon <- function(i, nrow, ncol) { 158 | WIDTH <- 27 159 | HEIGHT <- 22 160 | PAD <- 2 161 | i <- i - 1 162 | 163 | w <- (WIDTH - 2 * PAD) / ncol 164 | h <- (HEIGHT - 2 * PAD) / nrow 165 | 166 | chartIconStyle <- sprintf("width:%spx;height:%spx;left:%spx;top:%spx;", 167 | w, h, w * (i%%ncol) + PAD, h * (i %/% ncol) + PAD) 168 | tags$div( 169 | class = "mw-icon-areachart", 170 | tags$div(class="mw-icon-chart", style=chartIconStyle) 171 | ) 172 | } 173 | -------------------------------------------------------------------------------- /man/combineWidgets.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/combine_widgets.R 3 | \name{combineWidgets} 4 | \alias{combineWidgets} 5 | \title{Combine several interactive plots} 6 | \usage{ 7 | combineWidgets( 8 | ..., 9 | list = NULL, 10 | nrow = NULL, 11 | ncol = NULL, 12 | title = NULL, 13 | rowsize = 1, 14 | colsize = 1, 15 | byrow = TRUE, 16 | titleCSS = "", 17 | header = NULL, 18 | footer = NULL, 19 | leftCol = NULL, 20 | rightCol = NULL, 21 | width = NULL, 22 | height = NULL 23 | ) 24 | } 25 | \arguments{ 26 | \item{...}{htmlwidgets to combine. If this list contains objects that are not 27 | htmlwidgets, the function tries to convert them into a character string which 28 | is interpreted as html content.} 29 | 30 | \item{list}{Instead of directly passing htmlwidgets to the function, one can 31 | pass a list of htmlwidgets and objects coercible to character. In particular, 32 | it can be usefull if multiple htmlwidgets have been generated using a loop 33 | function like \code{\link[base]{lapply}}.} 34 | 35 | \item{nrow}{Number of rows of the layout. If \code{NULL}, the function will 36 | automatically take a value such that are at least as many cells in the 37 | layout as the number of htmlwidgets.} 38 | 39 | \item{ncol}{Number of columns of the layout.If \code{NULL}, the function will 40 | automatically take a value such that are at least as many cells in the 41 | layout as the number of htmlwidgets.} 42 | 43 | \item{title}{Title of the view.} 44 | 45 | \item{rowsize}{This argument controls the relative size of each row. For 46 | instance, if the layout has two rows and \code{rowsize = c(2,1)}, then the 47 | width of the first row will be twice the one of the second one. This 48 | argument is recycled to fit the number of rows.} 49 | 50 | \item{colsize}{Same as rowsize but for the height of the columns of the 51 | layout.} 52 | 53 | \item{byrow}{If \code{TRUE}, then the layout is filled by row. Else it is 54 | filled by column.} 55 | 56 | \item{titleCSS}{A character containing css properties to modify the 57 | appearance of the title of the view.} 58 | 59 | \item{header}{Content to display between the title and the combined widgets. 60 | It can be a single character string or html tags.} 61 | 62 | \item{footer}{Content to display under the combined widgets. It can be a 63 | single character string or html tags.} 64 | 65 | \item{leftCol}{Content to display on the left of the combined widgets. It can 66 | be a single character string or html tags.} 67 | 68 | \item{rightCol}{Content to display on the right the combined widgets. It can 69 | be a single character string or html tags.} 70 | 71 | \item{width}{Total width of the layout (optional, defaults to automatic 72 | sizing).} 73 | 74 | \item{height}{Total height of the layout (optional, defaults to automatic 75 | sizing).} 76 | } 77 | \value{ 78 | A htmlwidget object of class \code{combineWidget}. Individual widgets 79 | are stored in element \code{widgets} and can be extracted or updated. This 80 | is useful when a function returns a \code{combineWidgets} object but user 81 | wants to keep only one widget or to update one of them (see examples). 82 | } 83 | \description{ 84 | This function combines different htmlwidgets in a unique view. 85 | } 86 | \details{ 87 | The function only allows table like layout : each row has the same 88 | number of columns and reciprocally. But it is possible to create more complex 89 | layout by nesting combined htmlwidgets. (see examples) 90 | } 91 | \examples{ 92 | if (require(plotly)) { 93 | data(iris) 94 | 95 | combineWidgets(title = "The Iris dataset", 96 | plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 97 | plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20), 98 | plot_ly(iris, x = ~Petal.Length, type = "histogram", nbinsx = 20), 99 | plot_ly(iris, x = ~Petal.Width, type = "histogram", nbinsx = 20) 100 | ) 101 | 102 | # Create a more complex layout by nesting combinedWidgets 103 | combineWidgets(title = "The iris data set: sepals", ncol = 2, colsize = c(2,1), 104 | plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width, type = "scatter", 105 | mode = "markers", color = ~Species), 106 | combineWidgets( 107 | plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 108 | plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20) 109 | ) 110 | ) 111 | 112 | # combineWidgets can also be used on a single widget to easily add to it a 113 | # title and a footer. 114 | require(shiny) 115 | comments <- tags$div( 116 | "Wow this plot is so ", 117 | tags$span("amazing!!", style = "color:red;font-size:36px") 118 | ) 119 | 120 | combineWidgets( 121 | plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 122 | title = "Distribution of Sepal Length", 123 | footer = comments 124 | ) 125 | 126 | # It is also possible to combine htmlwidgets with text or other html elements 127 | myComment <- tags$div( 128 | style="height:100\%;background-color:#eee;padding:10px;box-sizing:border-box", 129 | tags$h2("Comment"), 130 | tags$hr(), 131 | "Here is a very clever comment about the awesome graphics you just saw." 132 | ) 133 | combineWidgets( 134 | plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 135 | plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20), 136 | plot_ly(iris, x = ~Petal.Length, type = "histogram", nbinsx = 20), 137 | myComment 138 | ) 139 | 140 | # Updating individual widgets. 141 | myWidget <- combineWidgets( 142 | plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20), 143 | plot_ly(iris, x = ~Sepal.Width, type = "histogram", nbinsx = 20), 144 | ncol = 2 145 | ) 146 | myWidget 147 | 148 | 149 | myWidget$widgets[[1]] <- myWidget$widgets[[1]] \%>\% 150 | layout(title = "Histogram of Sepal Length") 151 | 152 | myWidget$widgets[[2]] <- myWidget$widgets[[2]] \%>\% 153 | layout(title = "Histogram of Sepal Width") 154 | 155 | myWidget 156 | 157 | 158 | # Instead of passing directly htmlwidgets to the function, one can pass 159 | # a list containing htmlwidgets. This is especially useful when the widgets 160 | # are generated using a loop function like "lapply" or "replicate". 161 | # 162 | # The following code generates a list of 12 histograms and use combineWidgets 163 | # to display them. 164 | samples <- replicate(12, plot_ly(x = rnorm(100), type = "histogram", nbinsx = 20), 165 | simplify = FALSE) 166 | combineWidgets(list = samples, title = "12 samples of the same distribution") 167 | } 168 | 169 | } 170 | -------------------------------------------------------------------------------- /inst/manipulate_widget/manipulate_widget.css: -------------------------------------------------------------------------------- 1 | /* MENU */ 2 | 3 | .mw-menu { 4 | width:35px; 5 | height:100%; 6 | background-color: #e7e8ea; 7 | border-right:solid 1px #e7e8ea; 8 | } 9 | 10 | .separator { 11 | border-top:solid 1px #4e9cff; 12 | width:100%; 13 | height:1px; 14 | margin-top:-1px; 15 | } 16 | 17 | 18 | /* general style for buttons */ 19 | .mw-btn { 20 | position: relative; 21 | width:35px; 22 | height:35px; 23 | cursor:pointer; 24 | } 25 | 26 | .mw-btn.active { 27 | background-color: #4e9cff; 28 | } 29 | 30 | /* Arrow that is displayed when a button is active*/ 31 | .right-arrow { 32 | width: 0; 33 | height: 0; 34 | border-style: solid; 35 | border-width: 17.5px 0 17.5px 8px; 36 | border-color: transparent transparent transparent #4e9cff; 37 | position: absolute; 38 | top:0; 39 | left: 35px; 40 | display:none; 41 | } 42 | 43 | .mw-btn:hover .right-arrow { 44 | border-color: transparent transparent transparent #2b7be2; 45 | } 46 | 47 | .active>.right-arrow { 48 | display: block; 49 | } 50 | 51 | /* Settings button */ 52 | .mw-btn-settings { 53 | margin-bottom: 20px; 54 | padding: 2px; 55 | } 56 | 57 | .mw-btn-settings:hover { 58 | color:#fff; 59 | background-color: #2b7be2; 60 | } 61 | 62 | .bt1, .btn.bt1, .mw-btn-settings .bt1:focus { 63 | color: #4e9cff; 64 | text-align: center; 65 | vertical-align: bottom; 66 | line-height: 33px; 67 | font-size: 20px; 68 | background-color: white; 69 | border: solid 1px #4e9cff; 70 | } 71 | .mw-btn-settings:hover .bt1, .mw-btn-settings .bt1:active, .mw-btn-settings .bt1:hover { 72 | color:#fff; 73 | border:solid 1px #2b7be2; 74 | background-color: #2b7be2; 75 | } 76 | 77 | .bt1.area:active { 78 | background-color: #2b7be2; 79 | } 80 | 81 | .mw-btn-settings.active .bt1 { 82 | color: white; 83 | background-color: #4e9cff; 84 | } 85 | 86 | .mw-btn-settings.active:hover .bt1 { 87 | color: white; 88 | background-color: #2b7be2; 89 | border: solid 1px #2b7be2; 90 | } 91 | 92 | /* Buttons used to display inputs for a specific area */ 93 | .mw-btn-area { 94 | padding: 10px 3.3px; 95 | } 96 | 97 | .mw-btn-area:hover { 98 | background-color: #2b7be2; 99 | } 100 | 101 | .mw-icon-areachart { 102 | position:relative; 103 | background-color: white; 104 | border: solid 1px #4e9cff; 105 | width: 29px; 106 | height: 24px; 107 | } 108 | 109 | .mw-icon-chart { 110 | position: absolute; 111 | background-color: #4e9cff; 112 | } 113 | 114 | .mw-btn:hover .mw-icon-chart { 115 | background-color: #2b7be2; 116 | } 117 | 118 | 119 | /* OK and save buttons button */ 120 | .action-buttons-container { 121 | position: absolute; 122 | bottom: 3px; 123 | width:35px; 124 | } 125 | 126 | .btn.mw-btn-ok, .btn.mw-btn-save, .btn.mw-btn-export { 127 | margin: 2px; 128 | margin-top: 0px; 129 | width: 29px; 130 | height: 29px; 131 | background-color: #26b48b; 132 | color: white; 133 | text-align: center; 134 | vertical-align: bottom; 135 | line-height: 29px; 136 | border-radius: 5px; 137 | font-size: 15px; 138 | font-weight: bold; 139 | padding:0; 140 | } 141 | 142 | .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, .btn.mw-btn-export:hover, .btn.mw-btn-export:focus, .btn.mw-btn-export:active { 143 | color: white; 144 | background-color: #0b946c; 145 | } 146 | 147 | 148 | .mw-btn-update .bt1 { 149 | padding:0; 150 | width:35px; 151 | height:35px; 152 | outline:0; 153 | border-radius:2; 154 | } 155 | 156 | .mw-btn-update .bt1:focus { 157 | color: #4e9cff; 158 | background-color: white; 159 | border-color: #4e9cff; 160 | } 161 | 162 | .mw-btn-update>.bt1:hover { 163 | color: white; 164 | background-color: #2b7be2; 165 | border-color: #2b7be2; 166 | } 167 | 168 | .mw-btn-update .bt1:active { 169 | color: white; 170 | background-color: #4e9cff; 171 | border-color: #4e9cff; 172 | } 173 | 174 | 175 | .mw-chart-selection { 176 | margin-bottom: 20px; 177 | } 178 | 179 | /* Settings button */ 180 | .bt1.settings { 181 | padding:0; 182 | width:35px; 183 | height:35px; 184 | outline:0; 185 | border-radius:0; 186 | } 187 | 188 | .bt1.area { 189 | padding:0; 190 | width:35px; 191 | height:35px; 192 | outline:0; 193 | border-radius:0; 194 | border: none; 195 | background: none; 196 | padding: 5.5px 3.3px; 197 | } 198 | 199 | /* Input title */ 200 | .input-title { 201 | width:100%; 202 | font-size:20px; 203 | border-bottom:solid 1px #4e9cff; 204 | padding-bottom:5px; 205 | } 206 | 207 | /* Compare inputs */ 208 | .compare-inputs { 209 | width:100%; 210 | } 211 | 212 | .compare-inputs > div { 213 | width:50%; 214 | float:left; 215 | padding-left:5px; 216 | } 217 | 218 | .compare-inputs > div:first-child { 219 | padding-left:0px; 220 | padding-right:5px; 221 | } 222 | 223 | 224 | /* /!\ DO NOT MODIFY THE REST OF THE FILE /!\ */ 225 | 226 | html, body { 227 | height:100%; 228 | } 229 | 230 | .mw-container { 231 | height:100%; 232 | width:100%; 233 | } 234 | 235 | .with-border { 236 | padding: 30px 0; 237 | } 238 | 239 | .without-ok .mw-btn-ok { 240 | display: none; 241 | } 242 | 243 | .without-save .mw-btn-save { 244 | display: none; 245 | } 246 | 247 | .without-export .mw-btn-export { 248 | display: none; 249 | } 250 | 251 | .with-border > div { 252 | border:solid 1px #ccc; 253 | border-radius: 5px; 254 | } 255 | 256 | .mw-input-container { 257 | height:100%; 258 | } 259 | 260 | .mw-inputs { 261 | width: 200px; 262 | height:100%; 263 | border-right:solid 1px #4e9cff; 264 | padding:3px 10px; 265 | overflow: auto; 266 | } 267 | 268 | .mw-chartarea { 269 | height:100%; 270 | width:100%; 271 | position:absolute; 272 | flex: 1; 273 | -webkit-flex: 1; 274 | -moz-flex: 1; 275 | -ms-flex: 1; 276 | } 277 | 278 | .mw-chart { 279 | width:100%; 280 | height:100%; 281 | } 282 | 283 | /* Overhide bootstrap style for some input controls */ 284 | 285 | .form-control:focus, .selectize-input.focus { 286 | border-color: #4e9cff; 287 | } 288 | 289 | /* slider input */ 290 | .irs-from, .irs-to, .irs-bar, .irs-bar-edge { 291 | background-color: #4e9cff; 292 | } 293 | 294 | .irs-bar { 295 | border-top: solid 1px #4e9cff; 296 | border-bottom: solid 1px #4e9cff; 297 | } 298 | 299 | 300 | /* Group of inputs */ 301 | .panel-default>.panel-heading { 302 | background-color: #f0f0f0; 303 | } 304 | 305 | .panel-heading .arrow { 306 | width: 22px; 307 | text-align: center; 308 | } 309 | 310 | .panel-heading .arrow::before { 311 | font-family: FontAwesome; 312 | font-size: 20px; 313 | content: "\f0d7"; 314 | display: inline-block; 315 | padding-right: 10px; 316 | vertical-align: middle; 317 | } 318 | 319 | .panel-heading.collapsed .arrow::before { 320 | content: "\f0da"; 321 | } 322 | -------------------------------------------------------------------------------- /tests/testthat/test-input_list_class.R: -------------------------------------------------------------------------------- 1 | context("InputList class") 2 | 3 | describe("InputList", { 4 | it ("correctly updates values when an input value changes", { 5 | inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)) 6 | inputs <- initAllInputs(inputs, initEnv(parent.frame(), 1)) 7 | inputList <- InputList(inputs)$init() 8 | 9 | expect_equal(inputList$getInputById("output_1_y")$value, 5) 10 | 11 | inputList$setValue(inputId = "output_1_x", value = 7) 12 | expect_equal(inputList$getInputById("output_1_x")$value, 7) 13 | }) 14 | 15 | it("detects dependencies between inputs", { 16 | inputs <- list( 17 | x = mwSlider(0, 10, 5), 18 | y = mwSlider(x, 10, 0, .display = z > 3), 19 | z = mwSlider(0, x, 0) 20 | ) 21 | inputs <- initAllInputs(inputs, initEnv(parent.frame(), 1)) 22 | inputList <- InputList(inputs)$init() 23 | expect_equal(inputList$getDeps(inputList$getInputById("output_1_x")), 24 | list(params = character(), display = character())) 25 | expect_length(inputList$getInputById("output_1_y")$revDeps, 0) 26 | expect_equal(inputList$getDeps(inputList$getInputById("output_1_y")), 27 | list(params = "output_1_x", display = "output_1_z")) 28 | expect_equal(inputList$getInputById("output_1_x")$revDeps, c("output_1_y", "output_1_z")) 29 | expect_equal(inputList$getInputById("output_1_z")$displayRevDeps, c("output_1_y")) 30 | }) 31 | 32 | inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(0, 10, 0)) 33 | inputs2 <- list(x = mwSlider(0, 10, 6), y = mwSlider(0, 10, 1)) 34 | inputs <- c( 35 | initAllInputs(list(shared = mwText("test")), initEnv(parent.frame(), 0)), 36 | initAllInputs(inputs, initEnv(parent.frame(), 1)), 37 | initAllInputs(inputs2, initEnv(parent.frame(), 2)) 38 | ) 39 | inputList <- InputList(inputs)$init() 40 | 41 | it ("gets and updates an input by name and chartId", { 42 | # Get Input 43 | # Individual inputs 44 | expect_equal(inputList$getInput("x", 1)$value, 5) 45 | expect_equal(inputList$getInput("x", 2)$value, 6) 46 | # Shared inputs 47 | expect_equal(inputList$getInput("shared", 1)$value, "test") 48 | expect_equal(inputList$getInput("shared", 2)$value, "test") 49 | 50 | # Get input value 51 | # Individual inputs 52 | expect_equal(inputList$getValue("x", 1), 5) 53 | expect_equal(inputList$getValue("x", 2), 6) 54 | # Shared inputs 55 | expect_equal(inputList$getValue("shared", 1), "test") 56 | expect_equal(inputList$getValue("shared", 2), "test") 57 | 58 | # Update input value 59 | # Individual inputs 60 | expect_equal(inputList$setValue("x", 4, 1), 4) 61 | expect_equal(inputList$setValue("x", 5, 2), 5) 62 | expect_equal(inputList$getValue("x", 1), 4) 63 | expect_equal(inputList$getValue("x", 2), 5) 64 | # Shared inputs 65 | expect_equal(inputList$setValue("shared", "test1", 1), "test1") 66 | expect_equal(inputList$getValue("shared", 1), "test1") 67 | expect_equal(inputList$setValue("shared", "test2", 1), "test2") 68 | expect_equal(inputList$getValue("shared", 2), "test2") 69 | 70 | it ("gets all values for one chart", { 71 | for (i in 1:2) { 72 | values <- inputList$getValues(i) 73 | expect_is(values, "list") 74 | expect_named(values, c("shared", "x", "y"), ignore.order = TRUE) 75 | for (n in c("shared", "x", "y")) { 76 | expect_equal(values[[n]], inputList$getValue(n, i)) 77 | } 78 | } 79 | }) 80 | 81 | it ("indicates if an input is shared or not", { 82 | expect_true(inputList$isShared("shared")) 83 | expect_true(! inputList$isShared("x")) 84 | expect_true(! inputList$isShared("y")) 85 | }) 86 | 87 | it ("does not modify values until it is initialized", { 88 | inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)) 89 | inputs <- initAllInputs(inputs, initEnv(parent.frame(), 1)) 90 | inputList <- InputList(inputs) 91 | 92 | expect_equal(inputList$getInputById("output_1_y")$value, 0) 93 | inputList$setValue(inputId = "output_1_x", value = 7) 94 | expect_equal(inputList$getInputById("output_1_y")$value, 0) 95 | 96 | inputList$init() 97 | expect_equal(inputList$getInputById("output_1_y")$value, 7) 98 | inputList$setValue(inputId = "output_1_x", value = 8) 99 | expect_equal(inputList$getInputById("output_1_y")$value, 8) 100 | }) 101 | 102 | it ("can add an input", { 103 | e <- initEnv(parent.frame(), 1) 104 | inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)) 105 | inputs <- initAllInputs(inputs, e) 106 | inputList <- InputList(inputs[1])$init() 107 | inputList$addInputs(inputs[2]) 108 | expect_equal(inputList$getInputById("output_1_y")$value, 5) 109 | 110 | inputList$setValue(inputId = "output_1_x", value = 7) 111 | expect_equal(inputList$getInputById("output_1_y")$value, 7) 112 | 113 | values <- inputList$getValues(1) 114 | expect_is(values, "list") 115 | expect_named(values, c("x", "y"), ignore.order = TRUE) 116 | for (n in c("x", "y")) { 117 | expect_equal(values[[n]], inputList$getValue(n, 1)) 118 | } 119 | }) 120 | 121 | it ("can add a group of inputs", { 122 | e <- initEnv(parent.frame(), 1) 123 | inputs <- list(x = mwSlider(0, 10, 5), grp = mwGroup(y = mwSlider(x, 10, 0))) 124 | initInputEnv(inputs, e) 125 | inputList <- InputList(inputs[1])$init() 126 | inputList$addInputs(inputs[2]) 127 | 128 | expect_equal(nrow(inputList$inputTable), 3) 129 | expect_equal(sort(inputList$inputTable$name), c("grp", "x", "y")) 130 | }) 131 | 132 | it ("can remove an input", { 133 | e <- initEnv(parent.frame(), 1) 134 | inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)) 135 | inputs <- initAllInputs(inputs, e) 136 | inputList <- InputList(inputs)$init() 137 | inputList$removeInput("y", 1) 138 | expect_null(inputList$getInputById("output_1_y")) 139 | expect_length(inputList$getInputById("output_1_x")$revDeps, 0) 140 | expect_silent(inputList$setValue(inputId = "output_1_x", value = 7)) 141 | 142 | values <- inputList$getValues(1) 143 | expect_equal(values, list(x = 7)) 144 | }) 145 | 146 | it ("can remove a group of inputs", { 147 | e <- initEnv(parent.frame(), 1) 148 | inputs <- list(x = mwSlider(0, 10, 5), grp = mwGroup(y = mwSlider(x, 10, 0))) 149 | inputs <- initAllInputs(inputs, e) 150 | inputList <- InputList(inputs)$init() 151 | inputList$removeInput("grp", 1) 152 | expect_null(inputList$getInputById("output_1_y")) 153 | expect_null(inputList$getInputById("output_1_grp")) 154 | expect_length(inputList$getInputById("output_1_x")$revDeps, 0) 155 | expect_silent(inputList$setValue(inputId = "output_1_x", value = 7)) 156 | 157 | values <- inputList$getValues(1) 158 | expect_equal(values, list(x = 7)) 159 | }) 160 | }) 161 | }) 162 | -------------------------------------------------------------------------------- /inst/lib/export/Blob/Blob.js: -------------------------------------------------------------------------------- 1 | /* Blob.js 2 | * A Blob implementation. 3 | * 2014-07-24 4 | * 5 | * By Eli Grey, http://eligrey.com 6 | * By Devin Samarin, https://github.com/dsamarin 7 | * License: MIT 8 | * See https://github.com/eligrey/Blob.js/blob/master/LICENSE.md 9 | */ 10 | 11 | /*global self, unescape */ 12 | /*jslint bitwise: true, regexp: true, confusion: true, es5: true, vars: true, white: true, 13 | plusplus: true */ 14 | 15 | /*! @source http://purl.eligrey.com/github/Blob.js/blob/master/Blob.js */ 16 | 17 | (function (view) { 18 | "use strict"; 19 | 20 | view.URL = view.URL || view.webkitURL; 21 | 22 | if (view.Blob && view.URL) { 23 | try { 24 | new Blob; 25 | return; 26 | } catch (e) {} 27 | } 28 | 29 | // Internally we use a BlobBuilder implementation to base Blob off of 30 | // in order to support older browsers that only have BlobBuilder 31 | var BlobBuilder = view.BlobBuilder || view.WebKitBlobBuilder || view.MozBlobBuilder || (function(view) { 32 | var 33 | get_class = function(object) { 34 | return Object.prototype.toString.call(object).match(/^\[object\s(.*)\]$/)[1]; 35 | } 36 | , FakeBlobBuilder = function BlobBuilder() { 37 | this.data = []; 38 | } 39 | , FakeBlob = function Blob(data, type, encoding) { 40 | this.data = data; 41 | this.size = data.length; 42 | this.type = type; 43 | this.encoding = encoding; 44 | } 45 | , FBB_proto = FakeBlobBuilder.prototype 46 | , FB_proto = FakeBlob.prototype 47 | , FileReaderSync = view.FileReaderSync 48 | , FileException = function(type) { 49 | this.code = this[this.name = type]; 50 | } 51 | , file_ex_codes = ( 52 | "NOT_FOUND_ERR SECURITY_ERR ABORT_ERR NOT_READABLE_ERR ENCODING_ERR " 53 | + "NO_MODIFICATION_ALLOWED_ERR INVALID_STATE_ERR SYNTAX_ERR" 54 | ).split(" ") 55 | , file_ex_code = file_ex_codes.length 56 | , real_URL = view.URL || view.webkitURL || view 57 | , real_create_object_URL = real_URL.createObjectURL 58 | , real_revoke_object_URL = real_URL.revokeObjectURL 59 | , URL = real_URL 60 | , btoa = view.btoa 61 | , atob = view.atob 62 | 63 | , ArrayBuffer = view.ArrayBuffer 64 | , Uint8Array = view.Uint8Array 65 | 66 | , origin = /^[\w-]+:\/*\[?[\w\.:-]+\]?(?::[0-9]+)?/ 67 | ; 68 | FakeBlob.fake = FB_proto.fake = true; 69 | while (file_ex_code--) { 70 | FileException.prototype[file_ex_codes[file_ex_code]] = file_ex_code + 1; 71 | } 72 | // Polyfill URL 73 | if (!real_URL.createObjectURL) { 74 | URL = view.URL = function(uri) { 75 | var 76 | uri_info = document.createElementNS("http://www.w3.org/1999/xhtml", "a") 77 | , uri_origin 78 | ; 79 | uri_info.href = uri; 80 | if (!("origin" in uri_info)) { 81 | if (uri_info.protocol.toLowerCase() === "data:") { 82 | uri_info.origin = null; 83 | } else { 84 | uri_origin = uri.match(origin); 85 | uri_info.origin = uri_origin && uri_origin[1]; 86 | } 87 | } 88 | return uri_info; 89 | }; 90 | } 91 | URL.createObjectURL = function(blob) { 92 | var 93 | type = blob.type 94 | , data_URI_header 95 | ; 96 | if (type === null) { 97 | type = "application/octet-stream"; 98 | } 99 | if (blob instanceof FakeBlob) { 100 | data_URI_header = "data:" + type; 101 | if (blob.encoding === "base64") { 102 | return data_URI_header + ";base64," + blob.data; 103 | } else if (blob.encoding === "URI") { 104 | return data_URI_header + "," + decodeURIComponent(blob.data); 105 | } if (btoa) { 106 | return data_URI_header + ";base64," + btoa(blob.data); 107 | } else { 108 | return data_URI_header + "," + encodeURIComponent(blob.data); 109 | } 110 | } else if (real_create_object_URL) { 111 | return real_create_object_URL.call(real_URL, blob); 112 | } 113 | }; 114 | URL.revokeObjectURL = function(object_URL) { 115 | if (object_URL.substring(0, 5) !== "data:" && real_revoke_object_URL) { 116 | real_revoke_object_URL.call(real_URL, object_URL); 117 | } 118 | }; 119 | FBB_proto.append = function(data/*, endings*/) { 120 | var bb = this.data; 121 | // decode data to a binary string 122 | if (Uint8Array && (data instanceof ArrayBuffer || data instanceof Uint8Array)) { 123 | var 124 | str = "" 125 | , buf = new Uint8Array(data) 126 | , i = 0 127 | , buf_len = buf.length 128 | ; 129 | for (; i < buf_len; i++) { 130 | str += String.fromCharCode(buf[i]); 131 | } 132 | bb.push(str); 133 | } else if (get_class(data) === "Blob" || get_class(data) === "File") { 134 | if (FileReaderSync) { 135 | var fr = new FileReaderSync; 136 | bb.push(fr.readAsBinaryString(data)); 137 | } else { 138 | // async FileReader won't work as BlobBuilder is sync 139 | throw new FileException("NOT_READABLE_ERR"); 140 | } 141 | } else if (data instanceof FakeBlob) { 142 | if (data.encoding === "base64" && atob) { 143 | bb.push(atob(data.data)); 144 | } else if (data.encoding === "URI") { 145 | bb.push(decodeURIComponent(data.data)); 146 | } else if (data.encoding === "raw") { 147 | bb.push(data.data); 148 | } 149 | } else { 150 | if (typeof data !== "string") { 151 | data += ""; // convert unsupported types to strings 152 | } 153 | // decode UTF-16 to binary string 154 | bb.push(unescape(encodeURIComponent(data))); 155 | } 156 | }; 157 | FBB_proto.getBlob = function(type) { 158 | if (!arguments.length) { 159 | type = null; 160 | } 161 | return new FakeBlob(this.data.join(""), type, "raw"); 162 | }; 163 | FBB_proto.toString = function() { 164 | return "[object BlobBuilder]"; 165 | }; 166 | FB_proto.slice = function(start, end, type) { 167 | var args = arguments.length; 168 | if (args < 3) { 169 | type = null; 170 | } 171 | return new FakeBlob( 172 | this.data.slice(start, args > 1 ? end : this.data.length) 173 | , type 174 | , this.encoding 175 | ); 176 | }; 177 | FB_proto.toString = function() { 178 | return "[object Blob]"; 179 | }; 180 | FB_proto.close = function() { 181 | this.size = 0; 182 | delete this.data; 183 | }; 184 | return FakeBlobBuilder; 185 | }(view)); 186 | 187 | view.Blob = function(blobParts, options) { 188 | var type = options ? (options.type || "") : ""; 189 | var builder = new BlobBuilder(); 190 | if (blobParts) { 191 | for (var i = 0, len = blobParts.length; i < len; i++) { 192 | if (Uint8Array && blobParts[i] instanceof Uint8Array) { 193 | builder.append(blobParts[i].buffer); 194 | } 195 | else { 196 | builder.append(blobParts[i]); 197 | } 198 | } 199 | } 200 | var blob = builder.getBlob(type); 201 | if (!blob.slice && blob.webkitSlice) { 202 | blob.slice = blob.webkitSlice; 203 | } 204 | return blob; 205 | }; 206 | 207 | var getPrototypeOf = Object.getPrototypeOf || function(object) { 208 | return object.__proto__; 209 | }; 210 | view.Blob.prototype = getPrototypeOf(new view.Blob()); 211 | }(typeof self !== "undefined" && self || typeof window !== "undefined" && window || this.content || this)); 212 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # manipulateWidget 0.11.1 (2021-10-05) 4 | 5 | ## Bug Fixes 6 | * fix tests on R-devel 4.2 7 | 8 | # manipulateWidget 0.11.0 (2020-03-21) 9 | 10 | ## New features 11 | * New comparison mode: the UI generated with `manipulateWidget()` has now new controls to enter in comparison mode, choose the number of charts, the layout and the variables to compare. 12 | * `compareOptions()` gains a new argument `allowCompare` to hide/show the new controls presented above. 13 | * New function `mwTranslations()` to translate UI elements. 14 | * UI has been slightly reworked. 15 | 16 | ## Bug Fixes 17 | * The number of unnecesary updates has been decreased resulting in better performance. 18 | * Sometimes, there were some conflict when a parameter in `manipulateWidget()` had the same name as a variable in the global environment. 19 | * `mwSelect(multiple = TRUE)` was not updating charts when selection was empty. 20 | * `staticPlot()` was evaluating expressions in the wrong environment. 21 | 22 | ## Breaking changes 23 | * shiny applications using functions `mwModule()` and `mwModuleUI()` : you have to passed directly ui options like buttons on `mwModuleUI()` rather than in `mwModule()` 24 | 25 | 26 | # manipulateWidget 0.10.0 (2018-05-30) 27 | 28 | ## New features 29 | * UI has now a button to save the current chart in a PNG file. `manipulateWidget`gains a new parameter ".exportBtn" to show or hide this button. 30 | 31 | ## Bugfixes 32 | * Passing `.saveBtn` using module 33 | * Fix reset widget after saving in .html 34 | 35 | # manipulateWidget 0.9.0 (2018-01-29) 36 | 37 | ## New features 38 | * Can add a label to `mwGroup` 39 | * new ``mwSelectize`` input 40 | * add ``.showCompare`` 41 | 42 | ## Bugfixes 43 | * Loss of scrollbar using `shiny` with `fluidPage` and `manipulateWidget` 44 | * Fix Handle shiny tag objects with HTML dependencies 45 | * Preserve the class of widgets that are passed to combineWidgets 46 | 47 | # manipulateWidget 0.8.0 (2017-11-27) 48 | 49 | ## New features 50 | * `manipulateWidget()` has a new parameter `.updateBtnInit`. In case of update button `.updateBtn`, you can decide to render graphics on init or not. 51 | * 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. 52 | * `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()`. 53 | * `manipulateWidget` interfaces can now be included in shiny applications thanks to the two new functions `mwModule()` and `mwModuleUI()`. 54 | * 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 55 | `manipulateWidget()` is used in a shiny application to send data from the main application to the module. 56 | * `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. 57 | * `mwModule()` now return `controller` value, with possibility to use new `clear()` method 58 | * add `header`, `footer` and `fluidRow` arguments to `mwModuleUI()` 59 | 60 | ## Bugfixes 61 | * When a UI contained dynamic inputs, output was sometimes updated before inputs, which could lead to some errors. 62 | * Opening the same application in two browsers (or tabs) resulted in strange results. 63 | 64 | 65 | # manipulateWidget 0.7.0 (2017-06-08) 66 | 67 | ## Breaking changes 68 | * `manipulateWidget()` has lost all arguments that were used to customize the UI. Parameters `.controlPos`, `.tabColumns` and `.compareLayout` do not exist anymore. 69 | 70 | ## New features 71 | * `manipulateWidget()` now creates a more compact and elegant user interface. 72 | * 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. 73 | * Argument `.compare` of `manipulateWidget` can now be a character vector. 74 | 75 | # manipulateWidget 0.6.0 (2017-05-24) 76 | 77 | ## Breaking changes 78 | * `manipulateWidget()` now has a simpler API to show, hide and update inputs dynamically. Parameters `.display` and `.updateInputs` have been removed. 79 | * Functions `mwUI()` and `mwControlsUI()` have been removed. 80 | 81 | ## New Features 82 | * `manipulateWidget()` gains a new parameter `.return` to modify the object returned by the function. 83 | * `manipulateWidget()` has two new arguments `.width` and `.height` to control size of the UI in Rmarkdown documents with option `runtime: shiny` 84 | * New function `mwGroup` can be used to create groups of input. 85 | 86 | 87 | ## Bug fixes 88 | * Select inputs have had a buggy behavior in some settings. 89 | * Labels of inputs were incorrect in comparison mode. 90 | 91 | # manipulateWidget 0.5.1 (2017-01-23) 92 | 93 | ## New Features 94 | 95 | * 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. 96 | 97 | ## Bug fixes 98 | 99 | * Fixed a scope problem occuring when manipulateWidget was used inside a function and parameter `.updateInputs` was used. 100 | * Fixed a crash that could occur when parameters `.compare` and `.updateInputs` were used together. 101 | 102 | 103 | # manipulateWidget 0.5.0 (2017-01-18) 104 | 105 | ## New Features 106 | 107 | * `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) 108 | * `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). 109 | * Now, input controls generated by `manipulateWidget()` can be dynamically updated thanks to the new argument ".updateInputs". 110 | * New functions `staticImage()` and `staticPlot()` to include in a combine widget a static image or a static plot created with base functions, ggplot2, etc. 111 | * In `combinedWidgets`objects, individual widgets are stored in a property called `widgets`, so users can now access them and modify them. 112 | 113 | 114 | # manipulateWidget 0.4 (2016-12-16) 115 | 116 | ## Breaking changes 117 | 118 | * 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. 119 | 120 | ## New features 121 | 122 | * `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. 123 | 124 | ## Bug fixes 125 | * `manipulateWidget()` now preserves the order of the initial value of select inputs. 126 | * `manipulateWidget()` now automatically finds the correct render and output functions. This solves in particular sizing problems. 127 | 128 | # manipulateWidget 0.3 (2016-10-06) 129 | 130 | * add a file LICENSE and copyright to sources files 131 | 132 | # manipulateWidget 0.2 (2016-09-27) 133 | 134 | ## New features 135 | 136 | * 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. 137 | * 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. 138 | 139 | ## Bug fixes 140 | 141 | * Many useless but worrying warning messages have been removed. 142 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Add more interactivity to interactive charts" 3 | output: github_document 4 | --- 5 | 6 | ```{r setup, include=FALSE} 7 | knitr::opts_chunk$set(echo = TRUE) 8 | library(manipulateWidget) 9 | ``` 10 | 11 | 12 | [![CRAN Status Badge](http://www.r-pkg.org/badges/version/manipulateWidget)](http://cran.r-project.org/package=manipulateWidget) 13 | [![CRAN Downloads Badge](https://cranlogs.r-pkg.org/badges/manipulateWidget)](http://cran.r-project.org/package=manipulateWidget) 14 | [![Travis-CI Build Status](https://travis-ci.org/rte-antares-rpackage/manipulateWidget.svg?branch=master)](https://travis-ci.org/rte-antares-rpackage/manipulateWidget) 15 | [![Appveyor Build Status](https://ci.appveyor.com/api/projects/status/6y3tdofl0nk7oc4g/branch/master?svg=true)](https://ci.appveyor.com/project/rte-antares-rpackage/manipulatewidget/branch/master) 16 | 17 | `manipulateWidget` lets you create in just a few lines of R code a nice user interface to modify the data or the graphical parameters of one or multiple interactive charts. It is useful to quickly explore visually some data or for package developers to generate user interfaces easy to maintain. 18 | 19 | ![Combining widgets and some html content](vignettes/fancy-example.gif) 20 | 21 | This R 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 way a graphical interface that let 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. 22 | 23 | ## Features 24 | 25 | * Easily combine multiple interactive charts (`htmlwidgets`) in a single interactive chart with function `combineWidgets`. 26 | * With only a few lines of code, create a complete user interface that lets a user change the settings of a chart: filter the input data, change the model, modify the chart type or anything else. 27 | * Comparison mode: compare at a glance two set of parameters. For instance compare the same chart for two different countries or compare the results of several models or whatever. 28 | * Export to HTML or to PNG with a single click. 29 | 30 | ## Why should you use it? 31 | 32 | All functionalities of this package can be replicated with other packages like [shiny](https://shiny.rstudio.com/), [flexdashboard](http://rmarkdown.rstudio.com/flexdashboard/), [crosstalk](http://rstudio.github.io/crosstalk/) and others. So why another package? 33 | 34 | `manipulateWidget` has three advantages: 35 | 36 | * It is easy and fast to use. Only a few lines of `R` are necessary to create a user interface. 37 | * Code can be included in any R script. No need to create a dedicated .R or .Rmd file. 38 | * It works with all htmlwidgets. In contrast, `crosstalk` only supports a few of them. 39 | 40 | `manipulateWidget` can be especially powerful for users who are exploring some data set and want to quickly build a graphical tool to see what is in their data. `manipulateWidget` has also some advanced features that can be used with almost no additional code and that could seduce some package developers: grouping inputs, conditional inputs and comparison mode. 41 | 42 | 43 | ## Installation 44 | 45 | The package can be installed from CRAN: 46 | 47 | ```{r eval=FALSE} 48 | install.packages("manipulateWidget") 49 | ``` 50 | 51 | You can also install the latest development version from github: 52 | 53 | ```{r eval=FALSE} 54 | devtools::install_github("rte-antares-rpackage/manipulateWidget", ref="develop") 55 | ``` 56 | 57 | 58 | ## Getting started 59 | 60 | The hard part for the user is to write a code that generates an interactive chart. Once this is 61 | done, he only has to describe what parameter of the code should be modified by what input control. For instance, consider the following code that identifies clusters in the iris data set and uses package `plotly` to generate an interactive scatter plot. 62 | 63 | ```{r plotevouse, message=FALSE, warning=FALSE, out.width=600, out.height=400} 64 | library(manipulateWidget) 65 | library(dplyr) 66 | library(ggplot2) 67 | library(plotly) 68 | 69 | data("worldEnergyUse") 70 | 71 | plotEvoUse <- function(Country, Period = c(1960,2014)) { 72 | dataset <- worldEnergyUse %>% 73 | filter(country == Country, year >= Period[1] & year <= Period[2]) 74 | 75 | ggplot(dataset, aes(year)) + 76 | geom_line(aes(y = energy_used, color = "Total energy")) + 77 | geom_line(aes(y = energy_fossil, color = "Fossil energy")) + 78 | scale_color_manual(values = c("black", "red")) + 79 | expand_limits(y = 0) + 80 | ggtitle(paste("Evolution of energy\nconsumption in", Country)) + 81 | xlab("") + ylab("Energy (kg of oil equivalent)") + labs(color = "") + 82 | theme_bw() + 83 | theme(plot.title = element_text(size=10)) + 84 | theme(axis.title.y = element_text(size=9)) 85 | } 86 | 87 | plotEvoUse("United States") %>% ggplotly() 88 | ``` 89 | 90 | We create a second function that represents the share of a given country in the world energy consumption and population. We create also create a custom tooltip. 91 | 92 | ```{r plotshareuse, message=FALSE, out.width=600, out.height=400} 93 | tooltipText <- function(title, value) { 94 | sprintf("%s: %s%%", title, round(value * 100, 1)) 95 | } 96 | 97 | plotShareUse <- function(Country, Period = c(1960, 2014)) { 98 | dataset <- worldEnergyUse %>% 99 | filter(country == Country, year %in% Period) 100 | 101 | ggplot(dataset) + 102 | facet_grid(year ~ .) + 103 | geom_bar(aes("Population", weight = prop_world_population, 104 | text = tooltipText("Population", prop_world_population))) + 105 | geom_bar(aes("Energy Use", weight = prop_world_energy_used, 106 | text = tooltipText("Energy Use", prop_world_energy_used))) + 107 | geom_bar(aes("Energy Fossil", weight = prop_world_energy_fossil, 108 | text = tooltipText("Energy Fossil", prop_world_energy_fossil))) + 109 | ggtitle("Share of world...") + 110 | xlab("") + ylab("") + 111 | scale_y_continuous(labels = scales::percent) + 112 | theme_bw() + 113 | theme(plot.title = element_text(size=10)) + 114 | theme(axis.text.x = element_text(angle = 45, hjust = 1)) 115 | } 116 | 117 | suppressWarnings(plotShareUse("Germany")) %>% 118 | ggplotly(tooltip = "text") 119 | ``` 120 | 121 | We can combine two charts with the helper function `combineWidgets()`. We create a new function for clarity, but this is not a requirement. 122 | 123 | ```{r combinewidgets, message=FALSE, warning=FALSE, out.width=600, out.height=400} 124 | combinedPlots <- function(Country, Period = c(1960, 2014)) { 125 | combineWidgets( 126 | plotEvoUse(Country, Period) %>% ggplotly() %>% 127 | layout( 128 | legend = list(orientation = "h", x = 0, y = 0, yanchor = "bottom") 129 | ), 130 | plotShareUse(Country, Period) %>% ggplotly(tooltip = "text"), 131 | ncol = 2, colsize = c(2, 1) 132 | ) 133 | } 134 | 135 | combinedPlots("Germany") 136 | ``` 137 | 138 | So we now have some R code that generates a nice interactive chart. Now we would like to create a user interface that lets a user choose the country and the period that he wants to visualize. 139 | 140 | Here comes the magic of package `manipulateWidget`! With this package, you only have to write a few more lines of R code to achieve this result: 141 | 142 | ```{r eval = FALSE} 143 | manipulateWidget( 144 | combinedPlots(Period, Country), 145 | Period = mwSlider(1960, 2014, c(1960, 2014)), 146 | Country = mwSelect(sort(unique(worldEnergyUse$country)), "United States") 147 | ) 148 | ``` 149 | 150 | And voila! 151 | 152 | For more information take a look at the [package vignette](https://cran.r-project.org/web/packages/manipulateWidget/vignettes/manipulateWidgets.html). 153 | 154 | ## License Information: 155 | 156 | Copyright 2015-2020 RTE (France) 157 | 158 | * RTE: http://www.rte-france.com 159 | 160 | This Source Code is subject to the terms of the GNU General Public License, version 2 or any higher version. If a copy of the GPL-v2 was not distributed with this file, You can obtain one at https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html. 161 | -------------------------------------------------------------------------------- /R/input_env.R: -------------------------------------------------------------------------------- 1 | #' Private function that initialize an environment for a given chart. 2 | #' 3 | #' @param parentEnv an environment to be used as the enclosure of the environment 4 | #' created. 5 | #' @param id index of the chart 6 | #' 7 | #' @return Environment 8 | #' @noRd 9 | initEnv <- function(parentEnv, id) { 10 | res <- new.env(parent = parentEnv) 11 | res$.initial <- TRUE 12 | res$.session <- NULL 13 | res$.id <- id 14 | if (id == 0) res$.output <- "shared" 15 | else res$.output <- paste0("output_", id) 16 | res 17 | } 18 | 19 | #' Private function that initializes environments and inputs 20 | #' 21 | #' @param inputs list of uninitialized inputs 22 | #' @param env parent environement 23 | #' @param compare character vector with the name of the inputs to compare 24 | #' @param ncharts number of charts that will be created 25 | #' 26 | #' @return An InputEnv object with the following elements: 27 | #' - envs: list with elements 28 | #' - shared: shared environment 29 | #' - ind: list of individual environments. Length is equal to ncharts 30 | #' - hierarchy: Named list representing the disposition of inputs 31 | #' - inputList: same as inputs but flattened to facilitate looping. 32 | #' - ncharts: number of charts 33 | #' @noRd 34 | initInputEnv <- function(inputs, env = parent.frame(), compare = NULL, ncharts = 1) { 35 | res <- InputEnv() 36 | res$init(inputs = inputs, env = env, compare = compare, ncharts = ncharts) 37 | res 38 | } 39 | 40 | InputEnv <- setRefClass( 41 | "InputEnv", 42 | fields = c("envs", "inputList", "ncharts", "hierarchy"), 43 | methods = list( 44 | initialize = function() {}, 45 | 46 | init = function(inputs, env = parent.frame(), compare = NULL, ncharts = 1) { 47 | if (is.null(names(inputs))) stop("All arguments need to be named.") 48 | for (i in inputs) if (!inherits(i, "Input")) stop("All arguments need to be Input objects.") 49 | 50 | ncharts <<- ncharts 51 | 52 | # Initialize environments 53 | sharedEnv <- initEnv(env, 0) 54 | indEnvs <- lapply(seq_len(ncharts), function(i) initEnv(sharedEnv, i)) 55 | envs <<- list( 56 | shared = sharedEnv, 57 | ind = indEnvs 58 | ) 59 | 60 | # Get the hierarchy of inputs (used for html generation) 61 | getHierarchyRecursive <- function(inputs) { 62 | res <- sapply(names(inputs), function(n) { 63 | if (inputs[[n]]$type == "group") { 64 | getHierarchyRecursive(inputs[[n]]$value) 65 | } else { 66 | n 67 | } 68 | }, USE.NAMES = TRUE, simplify = FALSE) 69 | } 70 | 71 | hierarchy <<- getHierarchyRecursive(inputs) 72 | 73 | # Init inputs 74 | lapply(names(inputs), function(n) {inputs[[n]]$init(n, sharedEnv)}) 75 | inputList <<- InputList(inputs) 76 | 77 | # If compare is not null, unshare inputs and set initial values 78 | lapply(names(compare) , function(n) { 79 | newInputIds <- unshareInput(n) 80 | if (!is.null(compare[[n]])) { 81 | for (i in seq_len(ncharts)) { 82 | inputList$setValue(inputId = newInputIds[i], value = compare[[n]][[i]]) 83 | } 84 | } 85 | }) 86 | }, 87 | 88 | shareInput = function(name) { 89 | if (name %in% inputList$shared()) { 90 | return(character()) 91 | } 92 | oldInput <- inputList$getInput(name, 1) 93 | 94 | if(!is.null(oldInput$group)) { 95 | return(shareInput(oldInput$group)) 96 | } 97 | 98 | catIfDebug("Share variable", name) 99 | newInputIds <- character() 100 | 101 | for (dep in unname(do.call(c, inputList$getDeps(oldInput)))) { 102 | newInputIds <- append(newInputIds, shareInput(inputList$getInput(inputId = dep)$name)) 103 | } 104 | 105 | newInput <- oldInput$clone(envs$shared) 106 | 107 | for (i in seq_len(ncharts)) { 108 | inputList$getInput(name, i)$destroy() 109 | inputList$removeInput(name, chartId = i) 110 | } 111 | 112 | append(newInputIds, inputList$addInputs(list(name = newInput))) 113 | }, 114 | 115 | unshareInput = function(name) { 116 | if (is.null(name) || name %in% "") return(character()) 117 | if (name %in% inputList$unshared()) return(character()) 118 | 119 | oldInput <- inputList$getInput(name, 0) 120 | 121 | if(!is.null(oldInput$group)) { 122 | return(unshareInput(oldInput$group)) 123 | } 124 | 125 | catIfDebug("Unshare variable", name) 126 | newInputIds <- character() 127 | 128 | for (id in c(oldInput$revDeps,oldInput$displayRevDeps)) { 129 | newInputIds <- append(newInputIds, unshareInput(inputList$getInput(inputId = id)$name)) 130 | } 131 | inputList$removeInput(name, chartId = 0) 132 | 133 | 134 | for (i in seq_len(ncharts)) { 135 | newInput <- oldInput$clone(envs$ind[[i]]) 136 | 137 | newInputIds <- append( 138 | newInputIds, 139 | inputList$addInputs(list(name = newInput)) 140 | ) 141 | } 142 | 143 | oldInput$destroy() 144 | 145 | newInputIds 146 | }, 147 | 148 | getInputsForChart = function(chartId) { 149 | if (chartId == 0) { 150 | inputNames <- intersect(names(hierarchy), inputList$shared()) 151 | } else { 152 | inputNames <- intersect(names(hierarchy), inputList$unshared()) 153 | } 154 | sapply(inputNames, function(n) { 155 | inputList$getInput(n, chartId) 156 | }, simplify = FALSE, USE.NAMES = TRUE) 157 | }, 158 | 159 | getShareable = function() { 160 | intersect( 161 | names(hierarchy), 162 | inputList$inputTable[inputList$inputTable$type != "sharedValue", "name"] 163 | ) 164 | }, 165 | 166 | addChart = function() { 167 | ncharts <<- ncharts + 1 168 | # Copy environment of last chart 169 | envs$ind <<- append(envs$ind, cloneEnv(envs$ind[[ncharts - 1]], envs$shared)) 170 | assign(".id", ncharts, envir = envs$ind[[ncharts]]) 171 | assign(".output", paste0("output_", ncharts), envir = envs$ind[[ncharts]]) 172 | assign(".initial", TRUE, envir = envs$ind[[ncharts]]) 173 | 174 | # Get the list of inputs to clone 175 | toClone <- inputList$inputTable$chartId == ncharts - 1 & 176 | inputList$inputTable$name %in% names(hierarchy) 177 | inputsToClone <- inputList$inputTable[toClone, "input"] 178 | 179 | # Copy inputs 180 | newInputs <- lapply(inputsToClone, function(input) { 181 | input$clone(envs$ind[[ncharts]]) 182 | }) 183 | 184 | allNewInputs <- lapply(unname(newInputs), function(input) { 185 | input$getInputs() 186 | }) 187 | 188 | allNewInputs <- do.call(c, allNewInputs) 189 | 190 | inputList$addInputs(allNewInputs) 191 | }, 192 | 193 | removeChart = function() { 194 | if (ncharts == 1) stop("Need at least one chart.") 195 | 196 | for (n in inputList$unshared()) { 197 | inputList$removeInput(n, chartId = ncharts) 198 | } 199 | 200 | envs$ind[[ncharts]] <<- NULL 201 | ncharts <<- ncharts - 1 202 | }, 203 | 204 | setChartNumber = function(n) { 205 | if (n < 1) stop("Need at least one chart.") 206 | while (n != ncharts) { 207 | if (n > ncharts) { 208 | addChart() 209 | } else { 210 | removeChart() 211 | } 212 | } 213 | }, 214 | 215 | clone = function() { 216 | newSharedEnv <- cloneEnv(envs$shared) 217 | newEnvs <- lapply(envs$ind, cloneEnv, parentEnv = newSharedEnv) 218 | 219 | newInputList <- InputList(list()) 220 | 221 | newInputs <- list() 222 | for (n in names(hierarchy)) { 223 | if(inputList$isShared(n)) { 224 | newInputs <- append(newInputs, inputList$getInput(n, 0)$clone(newSharedEnv)) 225 | } else { 226 | for (i in seq_len(ncharts)) { 227 | newInputs <- append(newInputs, inputList$getInput(n, i)$clone(newEnvs[[i]])) 228 | } 229 | } 230 | } 231 | newInputList$addInputs(newInputs) 232 | 233 | res <- InputEnv() 234 | res$envs <- list(shared = newSharedEnv, ind = newEnvs) 235 | res$inputList <- newInputList 236 | res$hierarchy <- hierarchy 237 | res$ncharts <- ncharts 238 | 239 | res 240 | } 241 | ) 242 | ) 243 | -------------------------------------------------------------------------------- /R/input_list_class.R: -------------------------------------------------------------------------------- 1 | extractVarsFromExpr <- function(expr) { 2 | f <- function() {} 3 | body(f) <- expr 4 | codetools::findGlobals(f, merge = FALSE)$variables 5 | } 6 | 7 | # Private reference class used to update value and params of a set of inputs 8 | # when the value of an input changes. 9 | InputList <- setRefClass( 10 | "InputList", 11 | fields = c("session", "initialized", "inputTable"), 12 | methods = list( 13 | initialize = function(inputs, session = NULL) { 14 | "args: 15 | - inputs: list of initialized inputs 16 | - session: shiny session" 17 | 18 | inputList <- lapply(inputs, function(input) input$getInputs()) 19 | inputList <- do.call(c, inputList) 20 | 21 | if (length(inputs) > 0) { 22 | inputTable <<- data.frame( 23 | row.names = sapply(inputList, function(x) {x$getID()}), 24 | name = sapply(inputList, function(x) x$name), 25 | chartId = sapply(inputList, function(x) get(".id", envir = x$env)), 26 | type = sapply(inputList, function(x) x$type), 27 | input = I(inputList), 28 | stringsAsFactors = FALSE 29 | ) 30 | } else { 31 | inputTable <<- data.frame() 32 | } 33 | 34 | 35 | session <<- session 36 | initialized <<- FALSE 37 | 38 | # Set dependencies 39 | setDeps() 40 | }, 41 | 42 | setDeps = function() { 43 | # Reset all deps 44 | for (id in row.names(inputTable)) { 45 | getInputById(id)$resetDeps() 46 | } 47 | 48 | for (input in inputTable$input) { 49 | inputId <- input$getID() 50 | deps <- getDeps(input) 51 | for (d in deps$params) { 52 | getInputById(d)$addDeps(newRevDeps = inputId) 53 | } 54 | for (d in deps$display) { 55 | getInputById(d)$addDeps(newDisplayRevDeps = inputId) 56 | } 57 | } 58 | }, 59 | 60 | init = function() { 61 | if (!initialized) { 62 | update(forceDeps = TRUE) 63 | initialized <<- TRUE 64 | } 65 | return(.self) 66 | }, 67 | 68 | isShared = function(name) { 69 | idx <- which(inputTable$name == name) 70 | if (length(idx) == 0) stop("cannot find input ", name) 71 | any(inputTable$chartId[idx] == 0) 72 | }, 73 | 74 | shared = function() { 75 | inputTable$name[inputTable$chartId == 0] 76 | }, 77 | 78 | unshared = function() { 79 | unique(inputTable$name[inputTable$chartId != 0]) 80 | }, 81 | 82 | isVisible = function(name, chartId = 1, inputId = NULL) { 83 | i <- getInput(name, chartId, inputId) 84 | eval(i$display, envir = i$env) 85 | }, 86 | 87 | updateHTMLVisibility = function(name, chartId = 1, inputId = NULL) { 88 | if (!is.null(session)) { 89 | input <- getInput(name, chartId, inputId) 90 | catIfDebug("Update visibility of", input$getID()) 91 | shiny::updateCheckboxInput( 92 | session, 93 | paste0(input$getID(), "_visible"), 94 | value = eval(input$display, envir = input$env) 95 | ) 96 | } 97 | }, 98 | 99 | getDeps = function(input) { 100 | chartId <- get(".id", input$env) 101 | 102 | deps <- lapply(input$params, extractVarsFromExpr) 103 | deps <- do.call(c, deps) 104 | 105 | displayDeps <- extractVarsFromExpr(input$display) 106 | 107 | list( 108 | params = row.names(inputTable)[inputTable$name %in% deps & inputTable$chartId %in% c(0, chartId)], 109 | display = row.names(inputTable)[inputTable$name %in% displayDeps & inputTable$chartId %in% c(0, chartId)] 110 | ) 111 | }, 112 | 113 | getInput = function(name, chartId = 1, inputId = NULL) { 114 | if (!is.null(inputId)) { 115 | return(getInputById(inputId)) 116 | } 117 | idx <- which(inputTable$name == name & inputTable$chartId %in% c(0, chartId)) 118 | if (length(idx) == 0) { 119 | catIfDebug("cannot find input with name ", name) 120 | NULL 121 | } else { 122 | inputTable$input[[idx]] 123 | } 124 | }, 125 | 126 | getInputById = function(inputId) { 127 | if (!inputId %in% row.names(inputTable)) { 128 | catIfDebug("cannot find input with id ", inputId) 129 | NULL 130 | } else { 131 | inputTable[inputId, "input"][[1]] 132 | } 133 | }, 134 | 135 | addInputs = function(x) { 136 | if (length(x) == 0) return() 137 | initialInputs <- row.names(inputTable) 138 | 139 | for (input in x) { 140 | if (input$type == "group") addInputs(input$value) 141 | } 142 | 143 | newInputs <- data.frame( 144 | row.names = sapply(x, function(i) i$getID()), 145 | name = sapply(x, function(i) i$name), 146 | chartId = sapply(x, function(i) get(".id", envir = i$env)), 147 | type = sapply(x, function(i) i$type), 148 | input = I(x), 149 | stringsAsFactors = FALSE 150 | ) 151 | 152 | inputTable <<- rbind(inputTable, newInputs) 153 | 154 | # Reset dependencies 155 | setDeps() 156 | if (initialized) update(forceDeps = TRUE) 157 | 158 | setdiff(row.names(inputTable), initialInputs) 159 | }, 160 | 161 | removeInput = function(name, chartId = 0, inputId = NULL) { 162 | if (!is.null(inputId)) { 163 | if (!inputId %in% row.names(inputTable)){ 164 | catIfDebug("cannot find input with id ", inputId) 165 | return(TRUE) 166 | } else { 167 | idx <- which(row.names(inputTable) == inputId) 168 | } 169 | } else { 170 | idx <- which(inputTable$name == name & inputTable$chartId == chartId) 171 | } 172 | 173 | if (length(idx) == 0){ 174 | catIfDebug("cannot find input with name ", name) 175 | return(TRUE) 176 | } 177 | if (length(idx) > 1){ 178 | catIfDebug("Something wrong with input", name) 179 | return(TRUE) 180 | } 181 | 182 | inputToRemove <- inputTable[idx, "input"][[1]] 183 | 184 | inputTable <<- inputTable[-idx,] 185 | 186 | if(inputToRemove$type == "group") { 187 | for (input in inputToRemove$value) removeInput(inputId = input$getID()) 188 | } 189 | 190 | setDeps() 191 | 192 | TRUE 193 | }, 194 | 195 | getValue = function(name, chartId = 1, inputId = NULL) { 196 | getInput(name, chartId, inputId)$value 197 | }, 198 | 199 | getValues = function(chartId = 1) { 200 | idx <- which(inputTable$chartId %in% c(0, chartId) & inputTable$type != "group") 201 | res <- lapply(inputTable$input[idx], function(i) i$value) 202 | names(res) <- inputTable$name[idx] 203 | res 204 | }, 205 | 206 | setValue = function(name, value, chartId = 1, inputId = NULL, reactive = FALSE) { 207 | input <- getInput(name, chartId, inputId) 208 | oldValue <- input$value 209 | res <- input$setValue(value, reactive = reactive) 210 | if (!identical(oldValue, res)) updateRevDeps(input) 211 | res 212 | }, 213 | 214 | updateRevDeps = function(input, force = FALSE) { 215 | if (!initialized && !force) return() 216 | 217 | if (length(input$revDeps) > 0) { 218 | catIfDebug("Update dependencies of variable", input$name) 219 | for (inputId in input$revDeps) { 220 | revDepInput <- getInput(inputId = inputId) 221 | if(!identical(revDepInput$value, revDepInput$updateValue())) { 222 | updateRevDeps(revDepInput) 223 | } 224 | } 225 | } 226 | 227 | for (inputId in input$displayRevDeps) { 228 | updateHTMLVisibility(inputId = inputId) 229 | } 230 | updateHTML() 231 | }, 232 | 233 | update = function(forceDeps = FALSE) { 234 | "Update all inputs" 235 | for (input in inputTable$input) { 236 | if (!identical(input$value, input$updateValue())) updateRevDeps(input, force = forceDeps) 237 | } 238 | }, 239 | 240 | updateHTML = function() { 241 | if (!is.null(session)) { 242 | for (input in inputTable$input) { 243 | input$updateHTML(session) 244 | } 245 | } 246 | }, 247 | 248 | show = function() { 249 | print(inputTable) 250 | } 251 | ) 252 | ) 253 | 254 | `[.InputList` <- function(x, i, j, ...) { 255 | x$inputTable[i, j, ...] 256 | } 257 | --------------------------------------------------------------------------------