diff --git a/.Rbuildignore b/.Rbuildignore
index 165a9b9..de4340d 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -8,3 +8,4 @@ README_files
^\.travis\.yml$
^codecov\.yml$
newUI
+^inst/examples
diff --git a/DESCRIPTION b/DESCRIPTION
index fcbd032..d637de7 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,13 +1,14 @@
Package: manipulateWidget
Type: Package
Title: Add Even More Interactivity to Interactive Charts
-Version: 0.7.0
-Date: 2017-05-24
+Version: 0.8.1
+Date: 2017-11-27
Authors@R: c(
person("Francois", "Guillem", email = "francois.guillem@rte-france.com", role = c("aut", "cre")),
person("RTE", role = "cph"),
person("JJ", "Allaire", role = "ctb"),
- person("Marion", "Praz", email="mnpraz@gmail.com", role = "ctb", comment = "New user interface")
+ person("Marion", "Praz", email="mnpraz@gmail.com", role = "ctb", comment = "New user interface"),
+ person("Benoit", "Thieurmel", role = "ctb", email = "benoit.thieurmel@datastorm.fr")
)
Description: Like package 'manipulate' does for static graphics, this package
helps to easily add controls like sliders, pickers, checkboxes, etc. that
@@ -17,16 +18,16 @@ URL: https://github.com/rte-antares-rpackage/manipulateWidget
BugReports: https://goo.gl/pV7o5c
License: GPL (>= 2) | file LICENSE
Imports:
- shiny,
+ shiny (>= 1.0.3),
miniUI,
htmltools,
htmlwidgets,
- lazyeval,
knitr,
methods,
tools,
base64enc,
- grDevices
+ grDevices,
+ codetools
Suggests:
dygraphs,
leaflet,
diff --git a/NAMESPACE b/NAMESPACE
index 4211a69..b3c938a 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,27 +1,35 @@
# Generated by roxygen2: do not edit by hand
+S3method(summary,MWController)
export(combineWidgets)
export(combineWidgetsOutput)
export(compareOptions)
+export(knit_print.MWController)
export(manipulateWidget)
export(mwCheckbox)
export(mwCheckboxGroup)
export(mwDate)
export(mwDateRange)
export(mwGroup)
+export(mwModule)
+export(mwModuleUI)
export(mwNumeric)
export(mwPassword)
export(mwRadio)
export(mwSelect)
+export(mwSharedValue)
export(mwSlider)
export(mwText)
export(renderCombineWidgets)
export(staticImage)
export(staticPlot)
+exportClasses(MWController)
importFrom(grDevices,dev.off)
importFrom(grDevices,png)
importFrom(htmlwidgets,getDependency)
importFrom(methods,is)
+importFrom(methods,new)
+importFrom(methods,setRefClass)
importFrom(miniUI,gadgetTitleBar)
importFrom(miniUI,miniContentPanel)
importFrom(miniUI,miniPage)
diff --git a/NEWS.md b/NEWS.md
index a88a5da..f5114c1 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,27 @@
+# manipulateWidget 0.8.1 (2017-11-27)
+
+## New features
+* `mwModule()` now return `controller` value, with possibility to use new `clear()` method
+* add `header`, `footer` and `fluidRow` arguments to `mwModuleUI()`
+
+# manipulateWidget 0.8.0 (2017-10-25)
+
+## New features
+* `manipulateWidget()` has a new parameter `.updateBtnInit`. In case of update button `.updateBtn`, you can decideto render graphics on init or not.
+* UI has now a button to save the current chart in an HTML file (thanks to Benoit Thieurmel).`manipulateWidget`gains a new parameter ".saveBtn" to show or hide this button.
+* `manipulateWidget()` has a new parameter ".runApp". If it is false, then the function returns an object of class `MWController` that can be modified using command line instructions. This is useful to write tests for UIs created with `manipulateWidget()`.
+* `manipulateWidget` interfaces can now be included in shiny applications thanks to the two new functions `mwModule()` and `mwModuleUI()`.
+* A new virtual input called `mwSharedValue` has been introduced. It can be used to avoid repeating the same computations when inputs and output use a common intermediary value. It can also be used when
+`manipulateWidget()` is used in a shiny application to send data from the main application to the module.
+* `manipulateWidget()` now only updates the dependant inputs and outputs when user changes the value of an input. This can lead to important performance improvement in complicated applications.
+
+## Bugfixes
+* When a UI contained dynamic inputs, output was sometimes updated before inputs, which could lead to some errors.
+* Opening the same application in two browsers (or tabs) resulted in strange results.
+
+
# manipulateWidget 0.7.0 (2017-06-08)
## Breaking changes
diff --git a/R/combineWidgets.R b/R/combine_widgets.R
similarity index 96%
rename from R/combineWidgets.R
rename to R/combine_widgets.R
index 6f525dc..f1c64e6 100644
--- a/R/combineWidgets.R
+++ b/R/combine_widgets.R
@@ -256,7 +256,7 @@ preRenderCombinedWidgets <- function(x) {
widgetEL <- mapply(
function(id, size) {
sprintf('',
size, size, id)
},
diff --git a/R/compareOptions.R b/R/compare_options.R
similarity index 100%
rename from R/compareOptions.R
rename to R/compare_options.R
diff --git a/R/controller.R b/R/controller.R
new file mode 100644
index 0000000..b2b8ea2
--- /dev/null
+++ b/R/controller.R
@@ -0,0 +1,412 @@
+#' Controller object of a manipulateWidget application
+#'
+#' @description
+#' \code{MWController} is a reference class that is used to manage interaction
+#' with data and update of the view created by manipulateWidget. Only users who
+#' desire to create automatic tests for applications created with
+#' \code{\link{manipulateWidget}} should care about this object.
+#'
+#' @section Testing a manipulateWidget application:
+#' When \code{\link{manipulateWidget}} is used in a test script, it returns a
+#' \code{MWController} object instead of starting a shiny gadget. This object has
+#' methods to modify inputs values and check the state of the application. This
+#' can be useful to automatically checks if your application behaves like desired.
+#' Here is some sample code that uses package \code{testthat}:
+#'
+#' \preformatted{
+#' library("testthat")
+#'
+#' controller <- manipulateWidget(
+#' x + y,
+#' x = mwSlider(0, 10, 5),
+#' y = mwSlider(0, x, 0),
+#' .compare = "y"
+#' )
+#'
+#' test_that("Two charts are created", {
+#' expect_equal(controller$ncharts, 2)
+#' })
+#'
+#' test_that("Parameter 'max' of 'y' is updated when 'x' changes", {
+#' expect_equal(controller$getParams("y", 1)$max, 5)
+#' expect_equal(controller$getParams("y", 2)$max, 5)
+#' controller$setValue("x", 3)
+#' expect_equal(controller$getParams("y", 1)$max, 3)
+#' expect_equal(controller$getParams("y", 2)$max, 3)
+#' })
+#'
+#' }
+#'
+#' @field ncharts Number of charts in the application
+#' @field nrow Number of rows.
+#' @field ncol Number of columns.
+#' @field autoUpdate Boolean indicating if charts should be automatically
+#' updated when a value changes. list with \code{value} and \code{initBtn} (not autoUpdate, if want first charts on init)
+#'
+#' @export
+MWController <- setRefClass(
+ "MWController",
+ fields = c("inputList", "uiSpec", "envs", "session", "shinyOutput", "expr", "ncharts", "charts",
+ "autoUpdate", "renderFunc", "outputFunc", "useCombineWidgets", "nrow", "ncol",
+ "returnFunc", "initialized"),
+ methods = list(
+
+ initialize = function(expr, inputs, autoUpdate = list(value = TRUE, initBtn = FALSE), nrow = NULL,
+ ncol = NULL, returnFunc = function(widget, envs) {widget}) {
+ expr <<- expr
+ inputList <<- inputs$inputList
+ uiSpec <<- inputs
+ ncharts <<- inputs$ncharts
+ envs <<- inputs$envs
+ autoUpdate <<- autoUpdate
+ outputFunc <<- NULL
+ renderFunc <<- NULL
+ session <<- NULL
+ shinyOutput <<- NULL
+ useCombineWidgets <<- FALSE
+ nrow <<- nrow
+ ncol <<- ncol
+ returnFunc <<- returnFunc
+ charts <<- list()
+ initialized <<- FALSE
+ },
+
+ init = function() {
+ catIfDebug("Controller initialization")
+ if (!initialized) {
+ inputList$init()
+ updateCharts()
+ if (is.null(renderFunc) || is.null(outputFunc) || is.null(useCombineWidgets)) {
+ outputAndRender <- getOutputAndRenderFunc(charts[[1]])
+ renderFunc <<- outputAndRender$renderFunc
+ outputFunc <<- outputAndRender$outputFunc
+ useCombineWidgets <<- outputAndRender$useCombineWidgets
+ if (useCombineWidgets) {
+ charts <<- lapply(charts, combineWidgets)
+ }
+ }
+ initialized <<- TRUE
+ }
+
+ invisible(.self)
+ },
+
+ clear = function(){
+ rm(list = ls(envir = .self, all.names = TRUE), envir = .self, inherits = TRUE)
+ },
+
+ setShinySession = function(output, session) {
+ catIfDebug("Set shiny session")
+ session <<- session
+ shinyOutput <<- output
+ inputList$session <<- session
+ for (env in envs$ind) {
+ assign(".initial", FALSE, envir = env)
+ assign(".session", session, envir = env)
+ }
+ # also on shared env
+ assign(".initial", FALSE, envir = envs$shared)
+ assign(".session", session, envir = envs$shared)
+ },
+
+ getValue = function(name, chartId = 1) {
+ "Get the value of a variable for a given chart."
+ inputList$getValue(name, chartId)
+ },
+
+ getValueById = function(id) {
+ inputList$getValue(inputId = id)
+ },
+
+ setValue = function(name, value, chartId = 1, reactive = FALSE) {
+ "Update the value of a variable for a given chart."
+ oldValue <- getValue(name, chartId)
+ newValue <- inputList$setValue(name, value, chartId, reactive = reactive)
+ if (!initialized) return()
+ if (autoUpdate$value && !identical(oldValue, newValue)) {
+ if (inputList$isShared(name)) updateCharts()
+ else updateChart(chartId)
+ }
+ },
+
+ setValueById = function(id, value) {
+ oldValue <- getValueById(id)
+ newValue <- inputList$setValue(inputId = id, value = value)
+ if (!initialized) return()
+ if (autoUpdate$value && !identical(oldValue, newValue)) {
+ if (grepl("^shared_", id)) updateCharts()
+ else {
+ chartId <- get(".id", envir = inputList$inputs[[id]]$env)
+ updateChart(chartId)
+ }
+ }
+ },
+
+ getValues = function(chartId = 1) {
+ "Get all values for a given chart."
+ inputList$getValues(chartId)
+ },
+
+ getParams = function(name, chartId = 1) {
+ "Get parameters of an input for a given chart"
+ inputList$getInput(name, chartId)$getParams()
+ },
+
+ isVisible = function(name, chartId = 1) {
+ "Indicates if a given input is visible"
+ inputList$isVisible(name, chartId = 1)
+ },
+
+ updateChart = function(chartId = 1) {
+ catIfDebug("Update chart", chartId)
+ if(!is.null(envs)){
+ e <- new.env(parent = envs$ind[[chartId]]) # User can set values in expr without messing environments
+ charts[[chartId]] <<- eval(expr, envir = e)
+ if (useCombineWidgets) {
+ charts[[chartId]] <<- combineWidgets(charts[[chartId]])
+ }
+ renderShinyOutput(chartId)
+ }
+
+ },
+
+ returnCharts = function() {
+ "Return all charts."
+ if (length(charts) == 1) {
+ finalWidget <- charts[[1]]
+ } else {
+ finalWidget <- combineWidgets(list = charts, nrow = nrow, ncol = ncol)
+ }
+ returnFunc(finalWidget, envs$ind)
+ },
+
+ show = function() {
+ if (!initialized) {
+ message("Nothing to display because controller has not been initialized. Use 'ctrl$init()' where 'ctrl' is the variable created with manipulateWidget()")
+ }
+ print(returnCharts())
+ },
+
+ updateCharts = function() {
+ "Update all charts."
+ for (i in seq_len(ncharts)) updateChart(i)
+ },
+
+ renderShinyOutput = function(chartId) {
+ if (!is.null(renderFunc) & !is.null(shinyOutput) &
+ is(charts[[chartId]], "htmlwidget")) {
+ catIfDebug("Render shiny output")
+ outputId <- get(".output", envir = envs$ind[[chartId]])
+ shinyOutput[[outputId]] <<- renderFunc(charts[[chartId]])
+ }
+ },
+
+ renderShinyOutputs = function() {
+ for (i in seq_len(ncharts)) renderShinyOutput(i)
+ },
+
+ clone = function(env = parent.frame()) {
+ res <- MWController(
+ expr,
+ cloneUISpec(uiSpec, session),
+ autoUpdate
+ )
+ res$charts <- charts
+ res$nrow <- nrow
+ res$ncol <- ncol
+ res$outputFunc <- outputFunc
+ res$renderFunc <- renderFunc
+ res$useCombineWidgets <- useCombineWidgets
+ res$initialized <- initialized
+ res$inputList$initialized <- initialized
+
+ res
+ },
+
+ getModuleUI = function(gadget = TRUE, saveBtn = TRUE, addBorder = !gadget) {
+ function(ns, okBtn = gadget, width = "100%", height = "400px") {
+ #ns <- shiny::NS(id)
+ mwUI(ns, uiSpec, nrow, ncol, outputFunc,
+ okBtn = okBtn, updateBtn = !autoUpdate$value, saveBtn = saveBtn,
+ areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder,
+ width = width, height = height)
+ }
+ },
+
+ render = function(output, session) {
+ if (initialized) return()
+ ns <- session$ns
+ tryCatch({
+ init()
+ setShinySession(output, session)
+ output$ui <- renderUI(getModuleUI()(ns, height = "100%"))
+
+ lapply(inputList$inputs, function(input) {
+ # Update input visibility
+ catIfDebug("Update visibility of", input$getID())
+ shiny::updateCheckboxInput(
+ session,
+ paste0(input$getID(), "_visible"),
+ value = eval(input$display, envir = input$env)
+ )
+ # Hack to fix https://github.com/rstudio/shiny/issues/1490
+ if (input$type == "select" && identical(input$lastParams$multiple, TRUE)) {
+ input$valueHasChanged <- TRUE
+ input$updateHTML(session)
+ }
+ })
+ if (autoUpdate$value) renderShinyOutputs()
+ }, error = function(e) {catIfDebug("Initialization error"); print(e)})
+ },
+
+ getModuleServer = function() {
+ function(input, output, session, ...) {
+
+ controller <- .self$clone()
+
+ reactiveValueList <- list(...)
+
+ observe({
+ for (n in names(reactiveValueList)) {
+ controller$setValue(n, reactiveValueList[[n]](), reactive = TRUE)
+ }
+ controller$render(output, session)
+ })
+
+ lapply(names(controller$inputList$inputs), function(id) {
+ if (controller$inputList$inputs[[id]]$type != "sharedValue") {
+ # When shiny starts, this code is executed but input[[id]] is not defined yet.
+ # The code is designed to skip this first useless update.
+ e <- environment()
+ e$shinyInitialisation <- TRUE
+ observe({
+ shinyValue <- input[[id]]
+ if (e$shinyInitialisation) {
+ assign("shinyInitialisation", FALSE, envir = e)
+ } else {
+ controller$setValueById(id, value = shinyValue)
+ controller$render(output, session)
+ }
+ })
+ }
+ })
+
+ observeEvent(input$.update, controller$updateCharts(), ignoreNULL = !autoUpdate$initBtn)
+ observeEvent(input$done, onDone(controller))
+
+ output$save <- shiny::downloadHandler(
+ filename = function() {
+ paste('mpWidget-', Sys.Date(), '.html', sep='')
+ },
+ content = function(con) {
+ htmlwidgets::saveWidget(widget = onDone(controller, stopApp = FALSE),
+ file = con, selfcontained = TRUE)
+ }
+ )
+
+ return(controller)
+ }
+ }
+ )
+)
+
+cloneEnv <- function(env, parentEnv = parent.env(env)) {
+ res <- as.environment(as.list(env, all.names = TRUE))
+ parent.env(res) <- parentEnv
+ res
+}
+
+cloneUISpec <- function(uiSpec, session) {
+ newSharedEnv <- cloneEnv(uiSpec$envs$shared)
+ newEnvs <- lapply(uiSpec$envs$ind, cloneEnv, parentEnv = newSharedEnv)
+
+ newInputs <- lapply(seq_along(uiSpec$inputList$inputs), function(i) {
+ x <- uiSpec$inputList$inputs[[i]]$copy()
+ chartId <- uiSpec$inputList$chartIds[i]
+ if (chartId == 0) x$env <- newSharedEnv
+ else x$env <- newEnvs[[chartId]]
+ x
+ })
+ names(newInputs) <- names(uiSpec$inputList$inputs)
+
+ newSpec <- replaceInputs(uiSpec$inputs, newInputs, c(list(newSharedEnv), newEnvs))
+
+ list(
+ envs = list(shared = newSharedEnv, ind = newEnvs),
+ inputs = newSpec,
+ inputList = InputList(newInputs, session),
+ ncharts = uiSpec$ncharts
+ )
+}
+
+replaceInputs <- function(inputs, newInputs, envs) {
+ lapply(inputs, function(el) {
+ if (is.list(el)) return(replaceInputs(el, newInputs, envs))
+ else if (el$type == "group") {
+ params <- replaceInputs(el$value, newInputs, envs)
+ params$.display <- el$display
+ newGroup <- do.call(mwGroup, params)
+ env <- envs[[1 + get(".id", envir = el$env)]]
+ newGroup$init(el$name, env)
+ return(newGroup)
+ }
+ else return(newInputs[[el$getID()]])
+ })
+}
+
+
+
+#' knit_print method for MWController object
+#'
+#' @param x MWController object
+#' @param ... arguments passed to function knit_print
+#'
+#' @export
+knit_print.MWController <- function(x, ...) {
+ x$init()
+ knitr::knit_print(x$returnCharts(), ...)
+}
+
+#' summary method for MWController object
+#'
+#' @param object MWController object
+#' @param ... Not use
+#'
+#' @export
+summary.MWController <- function(object, ...) {
+ cat("Initialized :", object$initialized, "\n")
+ cat("Number of chart(s) :", object$ncharts, "\n")
+ cat("Number of row(s) :", object$nrow, "\n")
+ cat("Number of column(s) :", object$ncol, "\n")
+ cat("\nList of inputs : \n\n")
+ infos <- lapply(names(object$inputList$inputs), function(n){
+ input <- object$inputList$inputs[[n]]
+ if (is.atomic(input$value)) {
+ if (is.null(input$value)) value <- "NULL"
+ else if (length(input$value) == 0) value <- ""
+ else value <- paste(input$value, collapse = ", ")
+ } else {
+ if(is.call(input$value) | is.name(input$value)){
+ value <- evalValue(input$value, parent.frame())
+ if (is.null(value)) value <- sprintf("<%s>", class(input$value[1]))
+ else if (length(value) == 0) value <- ""
+ else value <- paste(value, collapse = ", ")
+ } else {
+ value <- sprintf("<%s>", class(input$value[1]))
+ }
+ }
+
+ chartId <- as.character(get(".id", envir = input$env))
+ if (chartId == "0") chartId <- "shared"
+
+ visible <- object$inputList$isVisible(inputId = n)
+
+ data.frame(inputId = n, type = input$type, variable = input$name,
+ chart = chartId, value = value, visible = visible,
+ stringsAsFactors = FALSE)
+ })
+ infos$stringsAsFactors <- FALSE
+ infos <- do.call(rbind, infos)
+ print(infos)
+}
+
diff --git a/R/controlsUtils.R b/R/controlsUtils.R
deleted file mode 100644
index 0e41a40..0000000
--- a/R/controlsUtils.R
+++ /dev/null
@@ -1,119 +0,0 @@
-# Set or update the elements of a list given the elements of another list.
-mergeList <- function(x, y) {
- for (n in names(y)) {
- x[[n]] <- y[[n]]
- }
- x
-}
-
-# Internal function that extracts the name, initial value and type of input
-# controls defined by the user.
-# This function is required because of the fact that the user can group controls
-# and even create nested groups so it is a bit hard to know what are the
-# available controls.
-#
-# Returns a data.frame with columns "name", "initValue", "type", "level",
-# "multiple" and "params".
-# "level" is equal to 1 if the input is not contained in a group, 2 if it is
-# contained in a group, 3 if it is contained in a group contained in a group,
-# etc.
-getControlDesc <- function(controls) {
- if (length(controls) == 0) return(data.frame())
- inputNames <- c()
- initValues <- list()
- types <- c()
- groupLevel <- c()
- group <- c()
- multiple <- c()
- params <- list()
- display <- list()
-
- getControlDescRecursive <- function(x, name = "", parent = "", level = 0) {
- groupLevel <<- append(groupLevel, level)
- group <<- append(group, parent)
- display <<- append(display, list(attr(x, "display")))
- inputNames <<- append(inputNames, name)
-
- if (is.function(x)) {
- value <- list(attr(x, "params")$value)
- initValues <<- append(initValues, value)
- types <<- append(types, attr(x, "type"))
- m <- if (is.null(attr(x, "params")$multiple)) NA else eval(attr(x, "params")$multiple)
- multiple <<- append(multiple, m)
-
- # Label of the control
- if (is.null(attr(x, "params"))) {
- attr(x, "params") <- list(label = name)
- } else if (is.null(attr(x, "params")$label)) {
- attr(x, "params")$label <- name
- }
- params <<- append(params, list(attr(x, "params")))
- } else if (length(x) == 0) {
- return()
- } else {
- initValues <<- append(initValues, list(NULL))
- types <<- append(types, "group")
- multiple <<- append(multiple, NA)
- params <<- append(params, list(NULL))
- mapply(getControlDescRecursive, x=x, name = names(x), parent = name, level = level + 1)
- }
- }
- getControlDescRecursive(controls, ".root")
-
- res <- data.frame(
- name = inputNames,
- initValue = I(initValues),
- type = types,
- level = groupLevel,
- group = group,
- multiple = multiple,
- params = I(params),
- display = I(display),
- stringsAsFactors = FALSE
- )
-
- res
-}
-
-# Internal function that filters a list of controls given a vector of names.
-# If drop = TRUE, controls whose name is in "names" are removed, else they
-# are kept and all other controls are removed.
-filterControls <- function(controls, names, drop = FALSE) {
- if (length(controls) == 0) return(controls)
-
- filterControlsRecursive <- function(x) {
- for (n in names(x)) {
- if (is.list(x[[n]])) {
- x[[n]] <- filterControlsRecursive(x[[n]])
- if (length(x[[n]]) == 0) x[[n]] <- NULL
- } else {
- if (!n %in% names & !drop) x[[n]] <- NULL
- if (n %in% names & drop) x[[n]] <- NULL
- }
- }
- return(x)
- }
-
- filterControlsRecursive(controls)
-}
-
-# Add a suffix to the name of each control without impacting the labels of the
-# inputs.
-addSuffixToControls <- function(controls, suffix) {
- if (length(controls) == 0) return(controls)
- addSuffixToControlsRecursive <- function(x) {
- for (n in names(x)) {
- if (is.list(x[[n]])) {
- x[[n]] <- addSuffixToControlsRecursive(x[[n]])
- }
- if (is.null(attr(x[[n]], "params"))) {
- attr(x[[n]], "params") <- list(label = n)
- }else if (is.null(attr(x[[n]], "params")$label)) {
- attr(x[[n]], "params")$label <- n
- }
- }
- names(x) <- paste0(names(x), suffix)
- return(x)
- }
- addSuffixToControlsRecursive(controls)
-}
diff --git a/R/debug.R b/R/debug.R
new file mode 100644
index 0000000..8885027
--- /dev/null
+++ b/R/debug.R
@@ -0,0 +1,17 @@
+mwDebug <- function() {
+ options(mwDebug = TRUE)
+}
+
+mwUndebug <- function() {
+ options(mwDebug = FALSE)
+}
+
+mwDebugMode <- function() {
+ res <- getOption("mwDebug")
+ if (is.null(res)) res <- FALSE
+ res
+}
+
+catIfDebug <- function(...) {
+ if (mwDebugMode()) cat(..., "\n")
+}
diff --git a/R/get_output_and_render_func.R b/R/get_output_and_render_func.R
new file mode 100644
index 0000000..9e76d90
--- /dev/null
+++ b/R/get_output_and_render_func.R
@@ -0,0 +1,33 @@
+#' Private function that gets shiny output and render functions for a given htmlWidget
+#'
+#' @param x Object, generally a htmlwidget.
+#'
+#' @return A list with the following elements
+#' - outputFunc
+#' - renderFunc
+#' - useCombineWidgets TRUE only if x is not an htmlwidget
+#' @noRd
+getOutputAndRenderFunc <- function(x) {
+ # Get shiny output and render functions
+ if (inherits(x, "htmlwidget")) {
+ cl <- class(x)
+ pkg <- attr(x, "package")
+
+ renderFunName <- ls(getNamespace(pkg), pattern = "^render")
+ renderFunction <- getFromNamespace(renderFunName, pkg)
+
+ outputFunName <- ls(getNamespace(pkg), pattern = "Output$")
+ outputFunction <- getFromNamespace(outputFunName, pkg)
+ useCombineWidgets <- FALSE
+ } else {
+ renderFunction <- renderCombineWidgets
+ outputFunction <- combineWidgetsOutput
+ useCombineWidgets <- TRUE
+ }
+
+ list(
+ outputFunc = outputFunction,
+ renderFunc = renderFunction,
+ useCombineWidgets = useCombineWidgets
+ )
+}
diff --git a/R/getRowAndCols.R b/R/get_row_and_cols.R
similarity index 100%
rename from R/getRowAndCols.R
rename to R/get_row_and_cols.R
diff --git a/R/init_inputs.R b/R/init_inputs.R
new file mode 100644
index 0000000..3a2e6eb
--- /dev/null
+++ b/R/init_inputs.R
@@ -0,0 +1,67 @@
+#' Private function that initialize an environment for a given chart.
+#'
+#' @param parentEnv an environment to be used as the enclosure of the environment
+#' created.
+#' @param id index of the chart
+#'
+#' @return Environment
+#' @noRd
+initEnv <- function(parentEnv, id) {
+ res <- new.env(parent = parentEnv)
+ res$.initial <- TRUE
+ res$.session <- NULL
+ res$.id <- id
+ if (id == 0) res$.output <- "shared"
+ else res$.output <- paste0("output_", id)
+ res
+}
+
+#' Private function that initializes environments and inputs
+#'
+#' @param inputs list of uninitialized inputs
+#' @param env parent environement
+#' @param compare character vector with the name of the inputs to compare
+#' @param ncharts number of charts that will be created
+#'
+#' @return A list with the following elements:
+#' - envs: list with elements
+#' - shared: shared environment
+#' - ind: list of individual environments. Length is equal to ncharts
+#' - inputs: list with elements:
+#' - shared: shared inputs (initialized)
+#' -ind: list of individual inputs (initialized) for each chart. Length is
+#' equal to ncharts
+#' - inputList: same as inputs but flattened to facilitate looping.
+#' - ncharts: number of charts
+#' @noRd
+initInputs <- function(inputs, env = parent.frame(), compare = NULL, ncharts = 1) {
+ if (is.null(names(inputs))) stop("All arguments need to be named.")
+ for (i in inputs) if (!inherits(i, "Input")) stop("All arguments need to be Input objects.")
+
+ sharedEnv <- initEnv(env, 0)
+ indEnvs <- lapply(seq_len(ncharts), function(i) initEnv(sharedEnv, i))
+
+ sharedInputs <- filterAndInitInputs(inputs, names(compare), drop = TRUE, sharedEnv)
+ indInputs <- lapply(seq_len(ncharts), function(i) {
+ newValues <- list()
+ for (n in names(compare)) {
+ if(!is.null(compare[[n]])) newValues[[n]] <- compare[[n]][[i]]
+ }
+ filterAndInitInputs(inputs, names(compare), env = indEnvs[[i]], newValues = newValues)
+ })
+
+ inputList <- InputList(list(sharedInputs, indInputs))
+
+ list(
+ envs = list(
+ shared = sharedEnv,
+ ind = indEnvs
+ ),
+ inputs = list(
+ shared = sharedInputs,
+ ind = indInputs
+ ),
+ inputList = inputList,
+ ncharts = ncharts
+ )
+}
diff --git a/R/input_class.R b/R/input_class.R
new file mode 100644
index 0000000..75ea9be
--- /dev/null
+++ b/R/input_class.R
@@ -0,0 +1,235 @@
+controlValueAndParams <- function(value, params, name, env){
+ # have another variable name in env
+ if(exists(name, envir = env)){
+ # get value
+ value_name <- get(name, envir = env)
+ control <- function(value, name, env){
+ # case of value / params of type name
+ if(is.name(value)){
+ # change name to new_name and assign current value
+ new_name <- paste0(".tmp_mw_", name)
+ assign(new_name, value_name, envir = env)
+ # modify expr
+ value <- eval(parse(text = paste0("substitute(", new_name, ")")))
+ # case of value / params of type call
+ } else if(is.call(value)){
+ # change name to new_name and assign current value
+ new_name <- paste0(".tmp_mw_", name)
+ assign(new_name, value_name, envir = env)
+
+ # modify expr
+ char_call <- paste0(deparse(value), collapse = "\n")
+
+ m <- gregexpr(paste0("((_.)[[:punct:]]|[[:space:]]|^){1}(",
+ name,
+ ")((_.)[[:punct:]]|[[:space:]]|$){1}"), char_call)
+
+ if(m[[1]][1] != -1){
+ matches_values <- unlist(regmatches(char_call, m))
+ mlength <- attr(m[[1]], "match.length")
+ mstart <- m[[1]][1:length(mlength)]
+ if(mstart[1] != 1){
+ final_value <- substring(char_call, 1, mstart[1]-1)
+ } else {
+ final_value <- ""
+ }
+ for(i in 1:length(mlength)){
+ tmp <- matches_values[i]
+ if(nchar(tmp) == (nchar(name) + 2)){
+ final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i]), new_name,
+ substring(char_call, mstart[i] + mlength[i] - 1, mstart[i] + mlength[i] - 1))
+ } else if(nchar(tmp) == nchar(name)){
+ final_value <- paste0(final_value, new_name)
+ } else if(nchar(tmp) > (nchar(name) + 2)){
+ final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i] + mlength[i] - 1))
+ } else {
+ if(substring(tmp, 1, nchar(name)) == name){
+ final_value <- paste0(final_value, new_name,
+ substring(char_call, mstart[i] + mlength[i] - 1, mstart[i] + mlength[i] - 1))
+ } else {
+ final_value <- paste0(final_value, substring(char_call, mstart[i], mstart[i]), new_name)
+ }
+ }
+ if(i != length(mlength)){
+ if((mstart[i] + mlength[i]) != mstart[i+1]){
+ final_value <- paste0(final_value, substring(char_call, mstart[i] + mlength[i], mstart[i+1] - 1))
+ }
+ } else if((mstart[i] + mlength[i] - 1) != nchar(char_call)){
+ final_value <- paste0(final_value, substring(char_call, mstart[i] + mlength[i], nchar(char_call)))
+ }
+ }
+ } else {
+ final_value <- char_call
+ }
+ value <- eval(parse(text = paste0("substitute(", final_value, ")")))
+ } else {
+ value
+ }
+ return(value)
+ }
+
+ # control value
+ value <- control(value, name, env)
+
+ # control params
+ params <- lapply(params, function(x){control(x, name, env)})
+ }
+
+ return(list(value = value, params = params))
+}
+
+emptyField <- function(x) inherits(x, "uninitializedField")
+
+evalParams <- function(params, env) {
+ lapply(params, function(x) {
+ tryCatch(eval(x, envir = env), silent = TRUE, error = function(e) {
+ if(mwDebugMode()) message(e$message)
+ NULL
+ })
+ })
+}
+
+evalValue <- function(value, env) {
+ tryCatch(eval(value, envir = env), silent = TRUE, error = function(e) {
+ if(mwDebugMode()) message(e$message);
+ NULL
+ })
+}
+
+
+# Private reference class representing an input.
+Input <- setRefClass(
+ "Input",
+ fields = c("type", "name", "idFunc", "label", "value", "display", "params", "env",
+ "validFunc", "htmlFunc", "htmlUpdateFunc",
+ "lastParams", "changedParams", "valueHasChanged",
+ "revDeps", "displayRevDeps", "value_expr"),
+
+ methods = list(
+ init = function(name, env) {
+ "Set environment and default values"
+ name <<- name
+ env <<- env
+ valueHasChanged <<- FALSE
+ changedParams <<- list()
+ revDeps <<- character()
+ displayRevDeps <<- character()
+ if (emptyField(label) || is.null(label)) label <<- name
+ if (emptyField(idFunc)) {
+ idFunc <<- function(oid, name) paste(oid, name, sep = "_")
+ }
+
+ ctrl_vp <- controlValueAndParams(value, params, name, env)
+ value <<- ctrl_vp$value
+ params <<- ctrl_vp$params
+
+ if(is.call(value) | is.name(value)){
+ assign(name, evalValue(value, parent.frame()), envir = env)
+ value_expr <<- value
+ } else {
+ assign(name, value, envir = env)
+ value_expr <<- NULL
+ }
+
+ lastParams <<- NULL
+ },
+
+ getID = function() {
+ "Get the id of the input for the UI"
+ gsub("[^a-zA-Z0-9]", "_", idFunc(get(".output", envir = env), name))
+ },
+
+ setValue = function(newValue, reactive = FALSE) {
+ "Modify value of the input. If newValue is invalid, it sets a valid value"
+ catIfDebug("Set value of ", getID())
+ if(reactive & type == "sharedValue"){
+ params$dynamic <<- FALSE
+ }
+ if (!emptyField(validFunc)) value <<- validFunc(evalValue(newValue, env), getParams())
+ assign(name, value, envir = env)
+ valueHasChanged <<- FALSE
+ value
+ },
+
+ updateValue = function() {
+ "Update value after a change in environment"
+ catIfDebug("Update value of ", getID())
+ oldValue <- value
+
+ if (!emptyField(validFunc)){
+ if(is.call(value_expr) | is.name(value_expr)){
+ tmp_value <- evalValue(value_expr, env)
+ if(is.null(tmp_value) & !is.call(oldValue) & !is.name(oldValue)) tmp_value <- oldValue
+ value <<- validFunc(tmp_value, getParams())
+ } else {
+ tmp_value <- evalValue(value, env)
+ if(is.null(tmp_value) & !is.call(oldValue) & !is.name(oldValue)) tmp_value <- oldValue
+ value <<- validFunc(tmp_value, getParams())
+ }
+ }
+ if (!identical(value, oldValue)) {
+ valueHasChanged <<- TRUE
+ assign(name, value, envir = env)
+ }
+ value
+ },
+
+ getParams = function() {
+ "Get parameter values"
+ oldParams <- lastParams
+ lastParams <<- evalParams(params, env)
+
+ for (n in names(lastParams)) {
+ if (!is.null(oldParams[[n]]) &&
+ !identical(lastParams[[n]], oldParams[[n]])) {
+ changedParams[[n]] <<- lastParams[[n]]
+ }
+ }
+ lastParams
+ },
+
+ getHTML = function(ns = NULL) {
+ "Get the input HTML"
+ if (emptyField(htmlFunc)) return(NULL)
+ id <- getID()
+ if (!is.null(ns)) id <- ns(id)
+ shiny::conditionalPanel(
+ condition = sprintf("input['%s_visible']", id),
+ tags$div(
+ style="display:none;",
+ shiny::checkboxInput(paste0(id, "_visible"), "", value = evalValue(display, env))
+ ),
+ htmlFunc(id, label, value, lastParams, ns)
+ )
+ },
+
+ updateHTML = function(session) {
+ "Update the input HTML."
+ if (emptyField(htmlUpdateFunc)) return()
+ if (valueHasChanged || length(changedParams) > 0) {
+ catIfDebug("Update HTML of ", getID(), "\n")
+ htmlParams <- changedParams
+ if (valueHasChanged) htmlParams$value <- value
+ else if(length(changedParams) > 0){
+ htmlParams$value <- validFunc(value, getParams())
+ }
+ htmlParams$session <- session
+ htmlParams$inputId <- getID()
+ do.call(htmlUpdateFunc, htmlParams)
+ valueHasChanged <<- FALSE
+ changedParams <<- list()
+ }
+ },
+
+ show = function() {
+ "print method"
+ cat("input of class", type, "\n")
+ if (type == "group") {
+ for (n in names(value)) {
+ cat("$", n, ": ", sep = "")
+ value[[n]]$show()
+ }
+ }
+ }
+ )
+)
diff --git a/R/input_list_class.R b/R/input_list_class.R
new file mode 100644
index 0000000..678fbb5
--- /dev/null
+++ b/R/input_list_class.R
@@ -0,0 +1,140 @@
+extractVarsFromExpr <- function(expr) {
+ f <- function() {}
+ body(f) <- expr
+ codetools::findGlobals(f, merge = FALSE)$variables
+}
+
+# Private reference class used to update value and params of a set of inputs
+# when the value of an input changes.
+InputList <- setRefClass(
+ "InputList",
+ fields = c("inputs", "session", "names", "chartIds", "initialized"),
+ methods = list(
+ initialize = function(inputs, session = NULL) {
+ "args:
+ - inputs: list of initialized inputs
+ - session: shiny session"
+ inputList <- flattenInputs(unname(inputs))
+ inputs <<- inputList
+ names(inputs) <<- sapply(inputList, function(x) {x$getID()})
+ names <<- sapply(inputList, function(x) x$name)
+ chartIds <<- sapply(inputList, function(x) get(".id", envir = x$env))
+ session <<- session
+ initialized <<- FALSE
+
+ # Set dependencies
+ for (input in inputList) {
+ inputId <- input$getID()
+ deps <- getDeps(input)
+ for (d in deps$params) {
+ inputs[[d]]$revDeps <<- union(.self$inputs[[d]]$revDeps, inputId)
+ }
+ for (d in deps$display) {
+ inputs[[d]]$displayRevDeps <<- union(.self$inputs[[d]]$displayRevDeps, inputId)
+ }
+ }
+ },
+
+ init = function() {
+ if (!initialized) {
+ update(forceDeps = TRUE)
+ initialized <<- TRUE
+ }
+ return(.self)
+ },
+
+ isShared = function(name) {
+ idx <- which(names == name)
+ if (length(idx) == 0) stop("cannot find input ", name)
+ any(chartIds[idx] == 0)
+ },
+
+ isVisible = function(name, chartId = 1, inputId = NULL) {
+ i <- getInput(name, chartId, inputId)
+ eval(i$display, envir = i$env)
+ },
+
+ updateHTMLVisibility = function(name, chartId = 1, inputId = NULL) {
+ if (!is.null(session)) {
+ input <- getInput(name, chartId, inputId)
+ catIfDebug("Update visibility of", input$getID())
+ shiny::updateCheckboxInput(
+ session,
+ paste0(input$getID(), "_visible"),
+ value = eval(input$display, envir = input$env)
+ )
+ }
+ },
+
+ getDeps = function(input) {
+ deps <- lapply(input$params, extractVarsFromExpr)
+ deps <- do.call(c, deps)
+
+ displayDeps <- extractVarsFromExpr(input$display)
+
+ list(
+ params = names(inputs)[names %in% deps],
+ display = names(inputs)[names %in% displayDeps]
+ )
+ },
+
+ getInput = function(name, chartId = 1, inputId = NULL) {
+ if (!is.null(inputId)) {
+ if (!inputId %in% names(inputs)) stop("cannot find input with id", inputId)
+ return(inputs[[inputId]])
+ }
+ idx <- which(names == name & chartIds %in% c(0, chartId))
+ if (length(idx) == 0) stop("cannot find input with name", name)
+ inputs[[idx]]
+ },
+
+ getValue = function(name, chartId = 1, inputId = NULL) {
+ getInput(name, chartId, inputId)$value
+ },
+
+ getValues = function(chartId = 1) {
+ idx <- which(chartIds %in% c(0, chartId))
+ res <- lapply(names[idx], function(n) getValue(n, chartId))
+ names(res) <- names[idx]
+ res
+ },
+
+ setValue = function(name, value, chartId = 1, inputId = NULL, reactive = FALSE) {
+ input <- getInput(name, chartId, inputId)
+ oldValue <- input$value
+ res <- input$setValue(value, reactive = reactive)
+ if (!identical(oldValue, res)) updateRevDeps(input)
+ res
+ },
+
+ updateRevDeps = function(input, force = FALSE) {
+ if (!initialized && !force) return()
+ for (inputId in input$revDeps) {
+ revDepInput <- getInput(inputId = inputId)
+ if(!identical(revDepInput$value, revDepInput$updateValue())) {
+ updateRevDeps(revDepInput)
+ }
+ }
+ for (inputId in input$displayRevDeps) {
+ updateHTMLVisibility(inputId = inputId)
+ }
+ updateHTML()
+ },
+
+ update = function(forceDeps = FALSE) {
+ "Update all inputs"
+ for (input in inputs) {
+ if (!identical(input$value, input$updateValue())) updateRevDeps(input, force = forceDeps)
+ }
+ updateHTML()
+ },
+
+ updateHTML = function() {
+ if (!is.null(session)) {
+ for (input in inputs) {
+ input$updateHTML(session)
+ }
+ }
+ }
+ )
+)
diff --git a/R/input_utils.R b/R/input_utils.R
new file mode 100644
index 0000000..12f77c3
--- /dev/null
+++ b/R/input_utils.R
@@ -0,0 +1,66 @@
+#' Private function that creates a filtered list of initialised inputs.
+#'
+#' @param inputs list of uninitialized inputs
+#' @param names names of inputs to keep or drop
+#' @param drop should inputs that appear in argument "names" be dropped or keepped?
+#' @param env environment used to initilize parameters
+#'
+#' @return a list of inputs
+#' @noRd
+filterAndInitInputs <- function(inputs, names, drop = FALSE,
+ env = parent.frame(), newValues = list()) {
+ res <- list()
+ for (n in names(inputs)) {
+ i <- inputs[[n]]$copy()
+ if (n %in% names(newValues)) i$value <- newValues[[n]]
+ if (inputs[[n]]$type == "group") {
+ if (drop) {
+ if (n %in% names) next # Remove the whole group
+ else {
+ i$value <- filterAndInitInputs(inputs[[n]]$value, names, drop, env)
+ if (length(i$value) == 0) next
+ }
+ } else {
+ if (n %in% names) {
+ # Keep the whole group
+ i$value <- filterAndInitInputs(inputs[[n]]$value, names(i$value), drop, env)
+ } else {
+ i$value <- filterAndInitInputs(inputs[[n]]$value, names, drop, env)
+ if (length(i$value) == 0) next
+ }
+ }
+ } else {
+ if (!drop && ! n %in% names) next
+ if (drop && n %in% names) next
+ }
+ i$init(n, env)
+ res[[n]] <- i
+ }
+ res
+}
+
+#' Private function that flattens a list of inputs
+#'
+#' @param inputs list of initialized inputs
+#'
+#' @return
+#' List of initialized inputs. The difference with the input is that
+#' inputs that belong to groups are placed in top of the list, so it is easier
+#' to iterate over all the inputs. Specifically, the result of this function
+#' can be used to create in InputList object.
+#' @noRd
+flattenInputs <- function(inputs) {
+ res <- list()
+ if (is.null(names(inputs))) names(inputs) <- as.character(seq_along(inputs))
+ for (n in names(inputs)) {
+ if (is.list(inputs[[n]])) {
+ res <- append(res, flattenInputs(inputs[[n]]))
+ next
+ }
+ if (inputs[[n]]$type == "group") {
+ res <- append(res, flattenInputs(inputs[[n]]$value))
+ }
+ res[[n]] <- inputs[[n]]
+ }
+ res
+}
diff --git a/R/controls.R b/R/inputs.R
similarity index 51%
rename from R/controls.R
rename to R/inputs.R
index 411947c..b7fc51d 100644
--- a/R/controls.R
+++ b/R/inputs.R
@@ -1,469 +1,659 @@
-#Copyright © 2016 RTE Réseau de transport d’électricité
-
-#' Private function used to create input generator functions.
-#' @param type character string indicating the type of input
-#' @param inputFunction input generator function
-#' @param params A named list containing at least elements "value" and "label".
-#' Other elements need to be expressions that give the value of a given
-#' parameter. Use prepareParams() to construct this argument.
-#' @param valueVar name of the parameter containing the value in inputFunction.
-#' only useful if this parameter is not named "value"
-#' @param .display expression that evaluates to TRUE or FALSE
-#'
-#' @return a function (params) -> html. The function has some attributes:
-#' - params: parameters entered by the user
-#' - valueVar: names of arguments containing value of the input
-#' - type: character string containing the input type
-#' - display: expression that evaluates to TRUE or FALSE
-#' @noRd
-mwControlFactory <- function(type, inputFunction, params, valueVar = NULL, .display = NULL) {
-
- res <- function(params) {
- if (!is.null(valueVar)) {
- if (length(valueVar) == 1) params[[valueVar]] <- params$value
- else {
- for (i in 1:length(valueVar)) params[[valueVar[i]]] <- params$value[[i]]
- }
- params$value <- NULL
- } else {
- valueVar <- "value"
- }
- if (is.null(params$label)) params$label <- params$inputId
- do.call(inputFunction, params)
- }
-
- attr(res, "params") <- params
- attr(res, "valueVar") <- valueVar
- attr(res, "type") <- type
- attr(res, "display") <- lazyeval::expr_find(.display)
- res
-}
-
-prepareParams <- function(value, label, ...) {
- params <- lapply(lazyeval::lazy_dots(..., .follow_symbols = TRUE), function(x) x$expr)
- params$value <- value
- params$label <- label
- params
-}
-
-#' Add a Slider to a manipulateWidget gadget
-#'
-#' @param min
-#' The minimum value that can be selected.
-#' @param max
-#' The maximum value that can be selected.
-#' @param value
-#' Initial value of the slider A numeric vector of length one will create a
-#' regular slider; a numeric vector of length two will create a double-ended
-#' range slider
-#' @param label
-#' Display label for the control. If \code{NULL}, the name of the corresponding
-#' variable is used.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{sliderInput}}
-#' @param .display expression that evaluates to TRUE or FALSE, indicating when
-#' the input control should be shown/hidden.
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#'
-#' if (require(plotly)) {
-#'
-#' myWidget <- manipulateWidget(
-#' plot_ly(data.frame(x = 1:n, y = rnorm(n)), x=~x, y=~y, type = "scatter", mode = "markers"),
-#' n = mwSlider(1, 100, 10, label = "Number of values")
-#' )
-#'
-#' Sys.sleep(0.5)
-#'
-#' # Create a double ended slider to choose a range instead of a single value
-#' mydata <- data.frame(x = 1:100, y = rnorm(100))
-#'
-#' manipulateWidget(
-#' plot_ly(mydata[n[1]:n[2], ], x=~x, y=~y, type = "scatter", mode = "markers"),
-#' n = mwSlider(1, 100, c(1, 10), label = "Number of values")
-#' )
-#'
-#' }
-#'
-#' @export
-#' @family controls
-mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "slider",
- function(...) {tags$div(style = "padding:0 5px;", shiny::sliderInput(...))},
- prepareParams(min = min, max = max, value = value, label = label, ...),
- .display = .display
- )
-}
-
-#' Add a text input to a manipulateWidget gadget
-#'
-#' @param value
-#' Initial value of the text input.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{textInput}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#' if (require(plotly)) {
-#' mydata <- data.frame(x = 1:100, y = rnorm(100))
-#' manipulateWidget({
-#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = "markers") %>%
-#' layout(title = mytitle)
-#' },
-#' mytitle = mwText("Awesome title !")
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwText <- function(value = "", label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "text", shiny::textInput,
- prepareParams(value = value, label = label, ...),
- .display = .display
- )
-}
-
-#' Add a numeric input to a manipulateWidget gadget
-#'
-#' @param value
-#' Initial value of the numeric input.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{numericInput}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#'
-#' if (require(plotly)) {
-#' manipulateWidget({
-#' plot_ly(data.frame(x = 1:10, y = rnorm(10, mean, sd)), x=~x, y=~y,
-#' type = "scatter", mode = "markers")
-#' },
-#' mean = mwNumeric(0),
-#' sd = mwNumeric(1, min = 0, step = 0.1)
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwNumeric <- function(value, label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "numeric", shiny::numericInput,
- prepareParams(value = value, label = label, ...),
- .display = .display
- )
-}
-
-#' Add a password to a manipulateWidget gadget
-#'
-#' @param value
-#' Default value of the input.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{passwordInput}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#' if (require(plotly)) {
-#' manipulateWidget(
-#' {
-#' if (passwd != 'abc123') {
-#' plot_ly(type = "scatter", mode="markers") %>%
-#' layout(title = "Wrong password. True password is 'abc123'")
-#' } else {
-#' plot_ly(data.frame(x = 1:10, y = rnorm(10)), x=~x, y=~y, type = "scatter", mode = "markers")
-#' }
-#' },
-#' user = mwText(label = "Username"),
-#' passwd = mwPassword(label = "Password")
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "password", shiny::passwordInput,
- prepareParams(value = value, label = label, ...),
- .display = .display
- )
-}
-
-#' Add a Select list input to a manipulateWidget gadget
-#'
-#' @param choices
-#' Vector or list of choices. If it is named, then the names rather than the
-#' values are displayed to the user.
-#' @param value
-#' Initial value of the input. If not specified, the first choice is used.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{selectInput}}.
-#' @param multiple
-#' Is selection of multiple items allowed?
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#' if (require(plotly)) {
-#' mydata <- data.frame(x = 1:100, y = rnorm(100))
-#'
-#' manipulateWidget(
-#' {
-#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
-#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
-#' },
-#' type = mwSelect(c("points", "lines", "both"))
-#' )
-#'
-#' Sys.sleep(0.5)
-#'
-#' # Select multiple values
-#' manipulateWidget(
-#' {
-#' if (length(species) == 0) mydata <- iris
-#' else mydata <- iris[iris$Species %in% species,]
-#'
-#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
-#' color = ~droplevels(Species), type = "scatter", mode = "markers")
-#' },
-#' species = mwSelect(levels(iris$Species), multiple = TRUE)
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwSelect <- function(choices = value, value = NULL, label = NULL, ...,
- multiple = FALSE, .display = TRUE) {
- mwControlFactory(
- "select", shiny::selectInput,
- prepareParams(choices = choices, value = value, label = label, ..., multiple = multiple),
- valueVar = "selected",
- .display = .display
- )
-}
-
-#' Add a checkbox to a manipulateWidget gadget
-#'
-#' @param value
-#' Initial value of the input.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{checkboxInput}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#'
-#' if(require(plotly)) {
-#' manipulateWidget(
-#' {
-#' plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width,
-#' color = ~Species, type = "scatter", mode = "markers") %>%
-#' layout(showlegend = legend)
-#' },
-#' legend = mwCheckbox(TRUE, "Show legend")
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "checkbox", shiny::checkboxInput,
- prepareParams(value = value, label = label, ...),
- .display = .display
- )
-}
-
-#' Add radio buttons to a manipulateWidget gadget
-#'
-#' @param choices
-#' Vector or list of choices. If it is named, then the names rather than the
-#' values are displayed to the user.
-#' @param value
-#' Initial value of the input. If not specified, the first choice is used.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{radioButtons}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#' if (require(plotly)) {
-#' mydata <- data.frame(x = 1:100, y = rnorm(100))
-#'
-#' manipulateWidget(
-#' {
-#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
-#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
-#' },
-#' type = mwRadio(c("points", "lines", "both"))
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "radio", shiny::radioButtons,
- prepareParams(choices = choices, value = value, label = label, ...),
- valueVar = "selected",
- .display = .display
- )
-}
-
-#' Add a date picker to a manipulateWidget gadget
-#'
-#' @param value
-#' Default value of the input.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{dateInput}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#' if (require(dygraphs) && require(xts)) {
-#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
-#'
-#' manipulateWidget(
-#' dygraph(mydata) %>% dyEvent(date, "Your birthday"),
-#' date = mwDate("2017-03-27", label = "Your birthday date",
-#' min = "2017-01-01", max = "2017-12-31")
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "date", shiny::dateInput,
- prepareParams(value = value, label = label, ...),
- .display = .display
- )
-}
-
-#' Add a date range picker to a manipulateWidget gadget
-#'
-#' @param value
-#' Vector containing two dates (either Date objects pr a string in yyy-mm-dd
-#' format) representing the initial date range selected.
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{dateRangeInput}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#' if (require(dygraphs) && require(xts)) {
-#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
-#'
-#' manipulateWidget(
-#' dygraph(mydata) %>% dyShading(from=period[1], to = period[2], color = "#CCEBD6"),
-#' period = mwDateRange(c("2017-03-01", "2017-04-01"),
-#' min = "2017-01-01", max = "2017-12-31")
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...,
- .display = TRUE) {
- mwControlFactory(
- "dateRange", shiny::dateRangeInput,
- prepareParams(value = value, label = label, ...),
- valueVar = c("start", "end"),
- .display = .display
- )
-}
-
-#' Add a group of checkboxes to a manipulateWidget gadget
-#'
-#' @param choices
-#' Vector or list of choices. If it is named, then the names rather than the
-#' values are displayed to the user.
-#' @param value
-#' Vector containing the values initially selected
-#' @param ...
-#' Other arguments passed to function\code{\link[shiny]{checkboxGroupInput}}
-#' @inheritParams mwSlider
-#'
-#' @return
-#' A function that will generate the input control.
-#'
-#' @examples
-#' if (require(plotly)) {
-#' manipulateWidget(
-#' {
-#' if (length(species) == 0) mydata <- iris
-#' else mydata <- iris[iris$Species %in% species,]
-#'
-#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
-#' color = ~droplevels(Species), type = "scatter", mode = "markers")
-#' },
-#' species = mwCheckboxGroup(levels(iris$Species))
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = TRUE) {
- mwControlFactory(
- "checkboxGroup", shiny::checkboxGroupInput,
- prepareParams(choices = choices, value = value, label = label, ...),
- valueVar = "selected",
- .display = .display
- )
-}
-
-#' Group inputs in a collapsible box
-#'
-#' This function generates a collapsible box containing inputs. It can be useful
-#' when there are a lot of inputs and one wants to group them.
-#'
-#' @param ... inputs that will be grouped in the box
-#' @param .display expression that evaluates to TRUE or FALSE, indicating when
-#' the group should be shown/hidden.
-#'
-#' @return List of inputs
-#'
-#' @examples
-#' if(require(dygraphs)) {
-#' mydata <- data.frame(x = 1:100, y = rnorm(100))
-#' manipulateWidget(
-#' dygraph(mydata[range[1]:range[2], ],
-#' main = title, xlab = xlab, ylab = ylab),
-#' range = mwSlider(1, 100, c(1, 100)),
-#' "Graphical parameters" = mwGroup(
-#' title = mwText("Fictive time series"),
-#' xlab = mwText("X axis label"),
-#' ylab = mwText("Y axis label")
-#' )
-#' )
-#' }
-#'
-#' @export
-#' @family controls
-mwGroup <- function(..., .display = TRUE) {
- res <- list(...)
- attr(res, "display") <- lazyeval::expr_find(.display)
- res
-}
+#' Private function that converts ... in a list of expressions. This is
+#' similar to "substitute" but for the dots argument.
+#' @noRd
+dotsToExpr <- function() {
+ eval(substitute(alist(...), parent.frame()))
+}
+
+#' Private function that generates functions that generate HTML corresponding
+#' to a shiny input.
+#'
+#' @param func shiny function that generate the HTML of an input
+#' @param valueArgName name of the parameter of 'func' corresponding to the
+#' value of the input.
+#'
+#' @return
+#' A function that takes arguments id, label, value, params and returns
+#' shiny tag.
+#' @noRd
+htmlFuncFactory <- function(func, valueArgName = "value") {
+ function(id, label, value, params, ns = NULL) {
+ params$inputId <- id
+ params$label <- label
+ params[valueArgName] <- list(value)
+ do.call(func, params)
+ }
+}
+
+changeValueParam <- function(func, valueArgName) {
+ function(...) {
+ params <- list(...)
+ if ("value" %in% names(params)) {
+ params[[valueArgName]] <- params$value
+ params$value <- NULL
+ }
+ do.call(shiny::updateSelectInput, params)
+ }
+}
+
+#' Add a Slider to a manipulateWidget gadget
+#'
+#' @param min
+#' The minimum value that can be selected.
+#' @param max
+#' The maximum value that can be selected.
+#' @param value
+#' Initial value of the slider A numeric vector of length one will create a
+#' regular slider; a numeric vector of length two will create a double-ended
+#' range slider
+#' @param label
+#' Display label for the control. If \code{NULL}, the name of the corresponding
+#' variable is used.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{sliderInput}}
+#' @param .display expression that evaluates to TRUE or FALSE, indicating when
+#' the input control should be shown/hidden.
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#'
+#' if (require(plotly)) {
+#'
+#' myWidget <- manipulateWidget(
+#' plot_ly(data.frame(x = 1:n, y = rnorm(n)), x=~x, y=~y, type = "scatter", mode = "markers"),
+#' n = mwSlider(1, 100, 10, label = "Number of values")
+#' )
+#'
+#' Sys.sleep(0.5)
+#'
+#' # Create a double ended slider to choose a range instead of a single value
+#' mydata <- data.frame(x = 1:100, y = rnorm(100))
+#'
+#' manipulateWidget(
+#' plot_ly(mydata[n[1]:n[2], ], x=~x, y=~y, type = "scatter", mode = "markers"),
+#' n = mwSlider(1, 100, c(1, 10), label = "Number of values")
+#' )
+#'
+#' }
+#'
+#' @export
+#' @family controls
+mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ params$min <- substitute(min)
+ params$max <- substitute(max)
+ value <- substitute(value)
+ Input(
+ type = "slider", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if (is.null(x) || is.na(x)) return(c(params$min, params$max))
+ pmin(pmax(params$min, x, na.rm = TRUE), params$max, na.rm = TRUE)
+ },
+ htmlFunc = htmlFuncFactory(function(...) {
+ tags$div(style = "padding:0 5px;", shiny::sliderInput(...))
+ }),
+ htmlUpdateFunc = shiny::updateSliderInput
+ )
+}
+
+#' Add a text input to a manipulateWidget gadget
+#'
+#' @param value
+#' Initial value of the text input.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{textInput}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#' if (require(plotly)) {
+#' mydata <- data.frame(x = 1:100, y = rnorm(100))
+#' manipulateWidget({
+#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = "markers") %>%
+#' layout(title = mytitle)
+#' },
+#' mytitle = mwText("Awesome title !")
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwText <- function(value = "", label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ value <- substitute(value)
+ Input(
+ type = "text", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if(length(x) == 0) return("")
+ as.character(x)[1]
+ },
+ htmlFunc = htmlFuncFactory(shiny::textInput),
+ htmlUpdateFunc = shiny::updateTextInput
+ )
+}
+
+#' Add a numeric input to a manipulateWidget gadget
+#'
+#' @param value
+#' Initial value of the numeric input.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{numericInput}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#'
+#' if (require(plotly)) {
+#' manipulateWidget({
+#' plot_ly(data.frame(x = 1:10, y = rnorm(10, mean, sd)), x=~x, y=~y,
+#' type = "scatter", mode = "markers")
+#' },
+#' mean = mwNumeric(0),
+#' sd = mwNumeric(1, min = 0, step = 0.1)
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwNumeric <- function(value, label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ value <- substitute(value)
+ Input(
+ type = "numeric", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if (is.null(x) || !is.numeric(x)) return(NULL)
+ min(max(params$min, x), params$max)
+ },
+ htmlFunc = htmlFuncFactory(shiny::numericInput),
+ htmlUpdateFunc = shiny::updateNumericInput
+ )
+}
+
+#' Add a password to a manipulateWidget gadget
+#'
+#' @param value
+#' Default value of the input.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{passwordInput}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#' if (require(plotly)) {
+#' manipulateWidget(
+#' {
+#' if (passwd != 'abc123') {
+#' plot_ly(type = "scatter", mode="markers") %>%
+#' layout(title = "Wrong password. True password is 'abc123'")
+#' } else {
+#' plot_ly(data.frame(x = 1:10, y = rnorm(10)), x=~x, y=~y, type = "scatter", mode = "markers")
+#' }
+#' },
+#' user = mwText(label = "Username"),
+#' passwd = mwPassword(label = "Password")
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ value <- substitute(value)
+ Input(
+ type = "password", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if(length(x) == 0) return("")
+ as.character(x)[1]
+ },
+ htmlFunc = htmlFuncFactory(shiny::passwordInput),
+ htmlUpdateFunc = shiny::updateTextInput
+ )
+}
+
+#' Add a Select list input to a manipulateWidget gadget
+#'
+#' @param choices
+#' Vector or list of choices. If it is named, then the names rather than the
+#' values are displayed to the user.
+#' @param value
+#' Initial value of the input. If not specified, the first choice is used.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{selectInput}}.
+#' @param multiple
+#' Is selection of multiple items allowed?
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#' if (require(plotly)) {
+#' mydata <- data.frame(x = 1:100, y = rnorm(100))
+#'
+#' manipulateWidget(
+#' {
+#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
+#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
+#' },
+#' type = mwSelect(c("points", "lines", "both"))
+#' )
+#'
+#' Sys.sleep(0.5)
+#'
+#' # Select multiple values
+#' manipulateWidget(
+#' {
+#' if (length(species) == 0) mydata <- iris
+#' else mydata <- iris[iris$Species %in% species,]
+#'
+#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
+#' color = ~droplevels(Species), type = "scatter", mode = "markers")
+#' },
+#' species = mwSelect(levels(iris$Species), multiple = TRUE)
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwSelect <- function(choices = value, value = NULL, label = NULL, ...,
+ multiple = FALSE, .display = TRUE) {
+ params <- dotsToExpr()
+ params$choices <- substitute(choices)
+ params$multiple <- substitute(multiple)
+ value <- substitute(value)
+ Input(
+ type = "select", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ x <- intersect(x, unlist(params$choices))
+ if (params$multiple) return(x)
+ else if (length(x) > 0) return(x[1])
+ else return(params$choices[[1]])
+ },
+ htmlFunc = htmlFuncFactory(shiny::selectInput, "selected"),
+ htmlUpdateFunc = changeValueParam(shiny::updateSelectInput, "selected")
+ )
+}
+
+#' Add a checkbox to a manipulateWidget gadget
+#'
+#' @param value
+#' Initial value of the input.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{checkboxInput}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#'
+#' if(require(plotly)) {
+#' manipulateWidget(
+#' {
+#' plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width,
+#' color = ~Species, type = "scatter", mode = "markers") %>%
+#' layout(showlegend = legend)
+#' },
+#' legend = mwCheckbox(TRUE, "Show legend")
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ value <- substitute(value)
+ Input(
+ type = "checkbox", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if (is.null(x)) return(FALSE)
+ x <- as.logical(x)
+ if (is.na(x)) x <- FALSE
+ x
+ },
+ htmlFunc = htmlFuncFactory(shiny::checkboxInput),
+ htmlUpdateFunc = shiny::updateCheckboxInput
+ )
+}
+
+#' Add radio buttons to a manipulateWidget gadget
+#'
+#' @param choices
+#' Vector or list of choices. If it is named, then the names rather than the
+#' values are displayed to the user.
+#' @param value
+#' Initial value of the input. If not specified, the first choice is used.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{radioButtons}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#' if (require(plotly)) {
+#' mydata <- data.frame(x = 1:100, y = rnorm(100))
+#'
+#' manipulateWidget(
+#' {
+#' mode <- switch(type, points = "markers", lines = "lines", both = "markers+lines")
+#' plot_ly(mydata, x=~x, y=~y, type = "scatter", mode = mode)
+#' },
+#' type = mwRadio(c("points", "lines", "both"))
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ params$choices <- substitute(choices)
+ value <- substitute(value)
+ Input(
+ type = "radio", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if (length(params$choices) == 0) return(NULL)
+ if (is.null(x) || !x %in% unlist(params$choices)) return(params$choices[[1]])
+ x
+ },
+ htmlFunc = htmlFuncFactory(shiny::radioButtons, valueArgName = "selected"),
+ htmlUpdateFunc = changeValueParam(shiny::updateRadioButtons, "selected")
+ )
+}
+
+#' Add a date picker to a manipulateWidget gadget
+#'
+#' @param value
+#' Default value of the input.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{dateInput}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#' if (require(dygraphs) && require(xts)) {
+#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
+#'
+#' manipulateWidget(
+#' dygraph(mydata) %>% dyEvent(date, "Your birthday"),
+#' date = mwDate("2017-03-27", label = "Your birthday date",
+#' min = "2017-01-01", max = "2017-12-31")
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ value <- substitute(value)
+ Input(
+ type = "date", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if (length(x) == 0) x <- Sys.Date()
+ x <- as.Date(x)
+ if (!is.null(params$min)) params$min <- as.Date(params$min)
+ if (!is.null(params$max)) params$max <- as.Date(params$max)
+ x <- min(max(x, params$min), params$max)
+ },
+ htmlFunc = htmlFuncFactory(shiny::dateInput),
+ htmlUpdateFunc = shiny::updateDateInput
+ )
+}
+
+#' Add a date range picker to a manipulateWidget gadget
+#'
+#' @param value
+#' Vector containing two dates (either Date objects pr a string in yyy-mm-dd
+#' format) representing the initial date range selected.
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{dateRangeInput}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' An Input object
+#'
+#' @examples
+#' if (require(dygraphs) && require(xts)) {
+#' mydata <- xts(rnorm(365), order.by = as.Date("2017-01-01") + 0:364)
+#'
+#' manipulateWidget(
+#' dygraph(mydata) %>% dyShading(from=period[1], to = period[2], color = "#CCEBD6"),
+#' period = mwDateRange(c("2017-03-01", "2017-04-01"),
+#' min = "2017-01-01", max = "2017-12-31")
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...,
+ .display = TRUE) {
+
+ params <- dotsToExpr()
+ value <- substitute(value)
+ Input(
+ type = "dateRange", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ if (length(x) == 0) x <- c(Sys.Date(), Sys.Date())
+ else if (length(x) == 1) x <- c(x, Sys.Date())
+ x <- as.Date(x)
+ x[is.na(x)] <- Sys.Date()
+ if (!is.null(params$min)) {
+ params$min <- as.Date(params$min)
+ if(x[1] == Sys.Date()){
+ x[1] <- params$min
+ }
+ }
+ if (!is.null(params$max)) {
+ params$max <- as.Date(params$max)
+ if(x[2] == Sys.Date()){
+ x[2] <- params$max
+ }
+ }
+ x <- sapply(x, function(d) min(max(d, params$min), params$max))
+ as.Date(x, origin = "1970-01-01")
+ },
+ htmlFunc = function(id, label, value, params, ns) {
+ params$inputId <- id
+ params$label <- label
+ params$start <- value[[1]]
+ params$end <- value[[2]]
+ do.call(shiny::dateRangeInput, params)
+ },
+ htmlUpdateFunc = function(...) {
+ params <- list(...)
+ if ("value" %in% names(params)) {
+ params$start <- params$value[[1]]
+ params$end <- params$value[[2]]
+ params$value <- NULL
+ }
+ do.call(shiny::updateDateRangeInput, params)
+ }
+ )
+}
+
+#' Add a group of checkboxes to a manipulateWidget gadget
+#'
+#' @param choices
+#' Vector or list of choices. If it is named, then the names rather than the
+#' values are displayed to the user.
+#' @param value
+#' Vector containing the values initially selected
+#' @param ...
+#' Other arguments passed to function\code{\link[shiny]{checkboxGroupInput}}
+#' @inheritParams mwSlider
+#'
+#' @return
+#' A function that will generate the input control.
+#'
+#' @examples
+#' if (require(plotly)) {
+#' manipulateWidget(
+#' {
+#' if (length(species) == 0) mydata <- iris
+#' else mydata <- iris[iris$Species %in% species,]
+#'
+#' plot_ly(mydata, x = ~Sepal.Length, y = ~Sepal.Width,
+#' color = ~droplevels(Species), type = "scatter", mode = "markers")
+#' },
+#' species = mwCheckboxGroup(levels(iris$Species))
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = TRUE) {
+ params <- dotsToExpr()
+ params$choices <- substitute(choices)
+ value <- substitute(value)
+ Input(
+ type = "checkboxGroup", value = value, label = label, params = params,
+ display = substitute(.display),
+ validFunc = function(x, params) {
+ intersect(x, unlist(params$choices))
+ },
+ htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected"),
+ htmlUpdateFunc = changeValueParam(shiny::updateCheckboxGroupInput, "selected")
+ )
+}
+
+#' Shared Value
+#'
+#' This function creates a virtual input that can be used to store a dynamic
+#' shared variable that is accessible in inputs as well as in output.
+#'
+#' @param expr Expression used to compute the value of the input.
+#'
+#' @return An Input object of type "sharedValue".
+#'
+#' @examples
+#'
+#' if (require(plotly)) {
+#' # Plot the characteristics of a car and compare with the average values for
+#' # cars with same number of cylinders.
+#' # The shared variable 'subsetCars' is used to avoid subsetting multiple times
+#' # the data: this value is updated only when input 'cylinders' changes.
+#' colMax <- apply(mtcars, 2, max)
+#'
+#' plotCar <- function(cardata, carName) {
+#' carValues <- unlist(cardata[carName, ])
+#' carValuesRel <- carValues / colMax
+#'
+#' avgValues <- round(colMeans(cardata), 2)
+#' avgValuesRel <- avgValues / colMax
+#'
+#' plot_ly() %>%
+#' add_bars(x = names(cardata), y = carValuesRel, text = carValues,
+#' hoverinfo = c("x+text"), name = carName) %>%
+#' add_bars(x = names(cardata), y = avgValuesRel, text = avgValues,
+#' hoverinfo = c("x+text"), name = "average") %>%
+#' layout(barmode = 'group')
+#' }
+#'
+#' c <- manipulateWidget(
+#' plotCar(subsetCars, car),
+#' cylinders = mwSelect(c("4", "6", "8")),
+#' subsetCars = mwSharedValue(subset(mtcars, cylinders == cyl)),
+#' car = mwSelect(choices = row.names(subsetCars))
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwSharedValue <- function(expr = NULL) {
+ params <- list(expr = substitute(expr))
+ params$dynamic <- is.language(params$expr)
+ if (!params$dynamic) value <- params$expr
+ else value <- NULL
+ Input(
+ type = "sharedValue", value = value, label = NULL, params = params,
+ display = FALSE,
+ validFunc = function(x, params) {
+ if(params$dynamic) params$expr
+ else x
+ }
+ )
+}
+
+#' Group inputs in a collapsible box
+#'
+#' This function generates a collapsible box containing inputs. It can be useful
+#' when there are a lot of inputs and one wants to group them.
+#'
+#' @param ... inputs that will be grouped in the box
+#' @param .display expression that evaluates to TRUE or FALSE, indicating when
+#' the group should be shown/hidden.
+#'
+#' @return Input of type "group".
+#'
+#' @examples
+#' if(require(dygraphs)) {
+#' mydata <- data.frame(x = 1:100, y = rnorm(100))
+#' manipulateWidget(
+#' dygraph(mydata[range[1]:range[2], ],
+#' main = title, xlab = xlab, ylab = ylab),
+#' range = mwSlider(1, 100, c(1, 100)),
+#' "Graphical parameters" = mwGroup(
+#' title = mwText("Fictive time series"),
+#' xlab = mwText("X axis label"),
+#' ylab = mwText("Y axis label")
+#' )
+#' )
+#' }
+#'
+#' @export
+#' @family controls
+mwGroup <- function(..., .display = TRUE) {
+ inputs <- list(...)
+ if (is.null(names(inputs))) stop("All arguments need to be named.")
+ for (i in inputs) if (!inherits(i, "Input")) stop("All arguments need to be Input objects.")
+
+ Input(
+ type = "group", value = list(...), params = list(),
+ display = substitute(.display),
+ htmlFunc = function(id, label, value, params, ns) {
+ htmlElements <- lapply(value, function(x) x$getHTML(ns))
+
+ tags$div(
+ class="panel panel-default",
+ tags$div(
+ class="panel-heading collapsed",
+ style = "cursor: pointer;",
+ "data-toggle"="collapse",
+ "data-target"=paste0("#panel-body-", id),
+ tags$table(
+ tags$tbody(
+ tags$tr(
+ tags$td(class = "arrow"),
+ tags$td(label)
+ )
+ )
+ )
+ ),
+ tags$div(
+ class="panel-body collapse",
+ id=paste0("panel-body-", id),
+ shiny::tagList(htmlElements)
+ )
+ )
+ }
+ )
+}
diff --git a/R/manipulateWidget.R b/R/manipulate_widget.R
similarity index 85%
rename from R/manipulateWidget.R
rename to R/manipulate_widget.R
index be67e9e..7a7e7c5 100644
--- a/R/manipulateWidget.R
+++ b/R/manipulate_widget.R
@@ -25,6 +25,8 @@
#' @param .updateBtn Should an update button be added to the controls ? If
#' \code{TRUE}, then the graphic is updated only when the user clicks on the
#' update button.
+#' @param .saveBtn Should an save button be added to the controls ?
+#' @param .updateBtnInit In case of update button. Do you want to render graphics on init ?
#' @param .viewer Controls where the gadget should be displayed. \code{"pane"}
#' corresponds to the Rstudio viewer, \code{"window"} to a dialog window, and
#' \code{"browser"} to an external web browser.
@@ -47,6 +49,13 @@
#' \code{runtime: shiny}.
#' @param .height Height of the UI. Used only on Rmarkdown documents with option
#' \code{runtime: shiny}.
+#' @param .runApp (advanced usage) If true, a shiny gadget is started. If false,
+#' the function returns a \code{\link{MWController}} object. This object can be
+#' used to check with command line instructions the behavior of the application.
+#' (See help page of \code{\link{MWController}}). Notice that this parameter is
+#' always false in a non-interactive session (for instance when running tests of
+#' a package).
+#'
#'
#' @return
#' The result of the expression evaluated with the last values of the controls.
@@ -142,7 +151,7 @@
#' manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ],
#' main = title, xlab = xlab, ylab = ylab),
#' range = mwSlider(2001, 2100, c(2001, 2100)),
-#' "Graphical parameters" = list(
+#' "Graphical parameters" = mwGroup(
#' title = mwText("Fictive time series"),
#' xlab = mwText("X axis label"),
#' ylab = mwText("Y axis label")
@@ -212,12 +221,13 @@
#'
#' @export
#'
-manipulateWidget <- function(.expr, ..., .updateBtn = FALSE,
+manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE,
+ .updateBtnInit = FALSE,
.viewer = c("pane", "window", "browser"),
.compare = NULL,
.compareOpts = compareOptions(),
.return = function(widget, envs) {widget},
- .width = NULL, .height = NULL) {
+ .width = NULL, .height = NULL, .runApp = TRUE) {
# check if we are in runtime shiny
isRuntimeShiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny")
@@ -240,43 +250,17 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE,
}
}
- # Evaluate a first time .expr to determine the class of the output
- controls <- preprocessControls(list(...), .compare, env = .env,
- ncharts = .compareOpts$ncharts)
-
- initWidgets <- lapply(controls$env$ind, function(e) {
- eval(.expr, envir = e)
- })
-
- # Get shiny output and render functions
- if (is(initWidgets[[1]], "htmlwidget")) {
- cl <- class(initWidgets[[1]])[1]
- pkg <- attr(initWidgets[[1]], "package")
-
- renderFunName <- ls(getNamespace(pkg), pattern = "^render")
- renderFunction <- getFromNamespace(renderFunName, pkg)
-
- OutputFunName <- ls(getNamespace(pkg), pattern = "Output$")
- outputFunction <- getFromNamespace(OutputFunName, pkg)
- useCombineWidgets <- FALSE
- } else {
- renderFunction <- renderCombineWidgets
- outputFunction <- combineWidgetsOutput
- useCombineWidgets <- TRUE
- }
-
dims <- .getRowAndCols(.compareOpts$ncharts, .compareOpts$nrow, .compareOpts$ncol)
- ui <- mwUI(controls, dims$nrow, dims$ncol, outputFunction, okBtn = !isRuntimeShiny,
- updateBtn = .updateBtn, areaBtns = length(.compare) > 0, border = isRuntimeShiny)
- server <- mwServer(.expr, controls, initWidgets,
- renderFunction,
- .updateBtn,
- .return,
- dims$nrow, dims$ncol,
- useCombineWidgets)
+ # Initialize inputs
+ inputs <- initInputs(list(...), env = .env, compare = .compare,
+ ncharts = .compareOpts$ncharts)
+ # Initialize controller
+ controller <- MWController(.expr, inputs, autoUpdate = list(value = !.updateBtn, initBtn = .updateBtnInit),
+ nrow = dims$nrow, ncol = dims$ncol,
+ returnFunc = .return)
- if (interactive()) {
+ if (.runApp & interactive()) {
# We are in an interactive session so we start a shiny gadget
.viewer <- switch(
.viewer,
@@ -284,13 +268,24 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE,
window = shiny::dialogViewer("manipulateWidget"),
browser = shiny::browserViewer()
)
+
+ ui <- mwModuleUI("ui", border = FALSE, okBtn = TRUE, saveBtn = .saveBtn,
+ width = "100%", height = "100%")
+ server <- function(input, output, session) {
+ mwModule("ui", controller)
+ }
+
shiny::runGadget(ui, server, viewer = .viewer)
- } else if (isRuntimeShiny) {
+ } else if (.runApp & isRuntimeShiny) {
# We are in Rmarkdown document with shiny runtime. So we start a shiny app
+ ui <- mwModuleUI("ui", margin = c("20px", 0), width = "100%", height = "100%")
+ server <- function(input, output, session) {
+ mwModule("ui", controller)
+ }
shiny::shinyApp(ui = ui, server = server, options = list(width = .width, height = .height))
} else {
- # Other cases (Rmarkdown or non interactive execution). We return the initial
- # widget to not block the R execution.
- mwReturn(initWidgets, .return, controls$env$ind, dims$nrow, dims$ncol)
+ # Other cases (Rmarkdown or non interactive execution). We return the controller
+ # to not block the R execution.
+ controller
}
}
diff --git a/R/module_ui.R b/R/module_ui.R
new file mode 100644
index 0000000..4def30e
--- /dev/null
+++ b/R/module_ui.R
@@ -0,0 +1,133 @@
+#' Add a manipulateWidget to a shiny application
+#'
+#' These two functions can be used to include a manipulateWidget object in a shiny application.
+#' \code{mwModuleUI} must be used in the UI to generate the required HTML elements and add
+#' javascript and css dependencies. \code{mwModule} must be called once in the server function
+#' of the application.
+#'
+#' @param id A unique string that identifies the module
+#' @param controller Object of class \code{\link{MWController}} returned by
+#' \code{\link{manipulateWidget}} when parameter \code{.runApp} is
+#' \code{FALSE}.
+#' @param ... named arguments containing reactive values. They can be used to send data from
+#' the main shiny application to the module.
+#'
+#' @return \code{mwModuleUI} returns the required HTML elements for the module. mwModule is only
+#' used for its side effects.
+#'
+#' @examples
+#' if (interactive() & require("dygraphs")) {
+#' require("shiny")
+#' ui <- fillPage(
+#' fillRow(
+#' flex = c(NA, 1),
+#' div(
+#' textInput("title", label = "Title", value = "glop"),
+#' selectInput("series", "series", choices = c("series1", "series2", "series3"))
+#' ),
+#' mwModuleUI("ui", height = "100%")
+#' ))
+#'
+#' server <- function(input, output, session) {
+#' mydata <- data.frame(
+#' year = 2000+1:100,
+#' series1 = rnorm(100),
+#' series2 = rnorm(100),
+#' series3 = rnorm(100)
+#' )
+#'
+#' c <- manipulateWidget(
+#' {
+#' dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title)
+#' },
+#' range = mwSlider(2001, 2100, c(2001, 2050)),
+#' series = mwSharedValue(),
+#' title = mwSharedValue(), .runApp = FALSE,
+#' .compare = "range"
+#' )
+#' #
+#' mwModule("ui", c, title = reactive(input$title), series = reactive(input$series))
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#'
+#' }
+#'
+#' @export
+mwModule <- function(id, controller, ...) {
+ shiny::callModule(controller$getModuleServer(), id, ...)
+}
+
+
+#' @param border Should a border be added to the module?
+#' @param okBtn Should the UI contain the OK button?
+#' @param saveBtn Should the UI contain the save button?
+#' @param margin Margin to apply around the module UI. Should be one two or four valid css
+#' units.
+#' @param width Width of the module UI.
+#' @param height Height of the module UI.
+#' @param header Tag or list of tags to display as a common header above all tabPanels.
+#' @param footer Tag or list of tags to display as a common footer below all tabPanels
+#' @param fluidRow Include module in a fluidRow ? Can be usefull in a shiny app. Defaut to FALSE
+#'
+#' @rdname mwModule
+#' @export
+mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin = 0,
+ width = "100%", height = 400, header = NULL, footer = NULL,
+ fluidRow = FALSE) {
+
+ ns <- shiny::NS(id)
+ for (i in seq_along(margin)) {
+ margin[i] <- shiny::validateCssUnit(margin[i])
+ }
+
+ margin <-paste(margin, collapse = " ")
+
+ class <- ""
+ if (border) class <- c(class, "with-border")
+ if(!okBtn) class <- c(class, "without-ok")
+ if(!saveBtn) class <- c(class, "without-save")
+ class <- paste(class, collapse = " ")
+
+ if(fluidRow){
+ res <- shiny::fluidRow(
+ shiny::column(12,
+ header,
+ shiny::uiOutput(ns("ui"), container = function(...) {
+ tags$div(style=sprintf("width:%s;height:%s;padding:%s",
+ shiny::validateCssUnit(width),
+ shiny::validateCssUnit(height),
+ margin),
+ class = class,
+ ...)
+ }),
+ footer
+ )
+ )
+ } else {
+ res <- shiny::tagList(
+ header,
+ shiny::uiOutput(ns("ui"), container = function(...) {
+ tags$div(style=sprintf("width:%s;height:%s;padding:%s",
+ shiny::validateCssUnit(width),
+ shiny::validateCssUnit(height),
+ margin),
+ class = class,
+ ...)
+ }),
+ footer
+ )
+ }
+
+
+ htmldep <- htmltools::htmlDependency(
+ "manipulateWidget",
+ "0.7.0",
+ system.file("manipulate_widget", package = "manipulateWidget"),
+ script = "manipulate_widget.js",
+ style = "manipulate_widget.css"
+ )
+
+ htmltools::attachDependencies(res, htmldep, TRUE)
+}
diff --git a/R/mwServer.R b/R/mwServer.R
deleted file mode 100644
index 60a3217..0000000
--- a/R/mwServer.R
+++ /dev/null
@@ -1,79 +0,0 @@
-#' Private function that returns a shiny server function to use in manipulateWidget
-#'
-#' @param .expr see manipulateWidget
-#' @param controls Object returned by function preprocessControls
-#' @param widgets A list of the widgets to show, in their initial state
-#' @param renderFunction Function to use to render the widgets
-#' @param .display see manipulateWidget
-#' @param .compareLayout see manipulateWidget
-#' @param .updateBtn see manipulateWidget
-#'
-#' @return A server function that can be used in runGadget.
-#'
-#' @noRd
-#'
-mwServer <- function(.expr, controls, widgets,
- renderFunction,
- .updateBtn, .return, nrow, ncol, useCombineWidgets) {
-
-
- function(input, output, session) {
- message("Click on the 'OK' button to return to the R session.")
- # Ensure that initial values of select inputs with multiple = TRUE are in
- # same order than the user asked.
- selectInputList <- subset(controls$desc, type == "select" & multiple)
- for (i in seq_len(nrow(selectInputList))) {
- shiny::updateSelectInput(
- session,
- selectInputList$name[i],
- selected = selectInputList$initValues[[i]]
- )
- }
-
- updateModule <- function(i) {
- # Initialize the widgets with their first evaluation
- if (useCombineWidgets) widgets[[i]] <- combineWidgets(widgets[[i]])
- output[[paste0("output", i)]] <- renderFunction(widgets[[i]])
-
- desc <- subset(controls$desc, mod %in% c(0, i))
-
- # Set the reactive environment of the modules. envs[[i]] is a reactive
- # value containing the module environment.
- moduleEnv <- reactive({
- input$.update
-
- for (j in seq_len(nrow(desc))) {
- if (.updateBtn) v <- isolate(input[[desc$inputId[j]]])
- else v <- input[[desc$inputId[j]]]
- assign(desc$name[j], v, envir = desc$env[[j]])
- }
- controls$env$ind[[i]]
- })
-
- # Update inputs and widget of the module
- observe({
- showHideControls(desc, session, moduleEnv())
-
- # Skip first evaluation, since widgets have already been rendered with
- # initial parameters
- if (get(".initial", envir = moduleEnv())) {
- assign(".initial", FALSE, envir = moduleEnv())
- assign(".session", session, envir = moduleEnv())
- } else {
- desc <<- updateControls(desc, session, moduleEnv())
- res <- eval(.expr, envir = moduleEnv())
- if (useCombineWidgets) res <- combineWidgets(res)
- if (is(res, "htmlwidget")) {
- output[[paste0("output", i)]] <- renderFunction(res)
- }
- }
- })
- }
-
- for (i in seq_len(controls$nmod)) {
- updateModule(i)
- }
-
- observeEvent(input$done, onDone(.expr, controls, .return, nrow, ncol))
- }
-}
diff --git a/R/mwServer_helpers.R b/R/mwServer_helpers.R
deleted file mode 100644
index 2eac373..0000000
--- a/R/mwServer_helpers.R
+++ /dev/null
@@ -1,120 +0,0 @@
-#' Dynamically show/hide controls in the UI
-#'
-#' @param .display expression that evaluates to a named list of boolean
-#' @param desc subset of controls$desc containing only shared inputs and inputs
-#' for the current module
-#' @param session shiny session
-#' @param env module environment
-#'
-#' @noRd
-showHideControls <- function(desc, session, env) {
- displayBool <- lapply(desc$display, eval, envir = env)
- for (i in seq_along(displayBool)) {
- if (is.logical(displayBool[[i]])) {
- shiny::updateCheckboxInput(
- session,
- inputId = paste0(desc$inputId[i], "_visible"),
- value = displayBool[[i]]
- )
- }
- }
-}
-
-#' Dynamically set input parameters like choices, minimal or maximal values, etc.
-#'
-#' @param .updateInputs expression that evaluate to a named list of lists
-#' @inheritParams showHideControls
-#'
-#' @return data.frame 'desc' with updated column params
-#' @noRd
-updateControls <- function(desc, session, env) {
-
- for (i in seq_len(nrow(desc))) {
- newParams <- evalParams(desc$params[[i]], env)
-
- args <- list(session = session, inputId = desc$inputId[i])
- updateRequired <- FALSE
-
- for (p in setdiff(names(newParams), c("value", "label"))) {
- if (identical(newParams[[p]], desc$currentParams[[i]][[p]])) {
- next
- }
-
- updateRequired <- TRUE
- args[[p]] <- newParams[[p]]
-
- # Special case: update value of select input when choices are modified
- if (p == "choices" & desc$type[i] == "select") {
- actualSelection <- get(desc$name[i], envir = env)
- if (desc$multiple[[i]]) {
- args$selected <- intersect(actualSelection, newParams[[p]])
- } else {
- if (actualSelection %in% newParams[[p]]) {
- args$selected <- actualSelection
- }
- }
- }
-
- desc$currentParams[[i]][[p]] <- newParams[[p]]
- }
-
- if (updateRequired) {
- updateInputFun <- getUpdateInputFun(desc$type[i])
- do.call(updateInputFun, args)
- }
- }
-
- desc
-}
-
-#' Private function that returns the function to use to update some type of inputs
-#' @noRd
-getUpdateInputFun <- function(type) {
- switch(
- type,
- slider = shiny::updateSliderInput,
- text = shiny::updateTextInput,
- numeric = shiny::updateNumericInput,
- password = shiny::updateTextInput,
- select = shiny::updateSelectInput,
- checkbox = shiny::updateCheckboxInput,
- radio = shiny::updateRadioButtons,
- date = shiny::updateDateInput,
- dateRange = shiny::updateDateRangeInput,
- checkboxGroup = shiny::updateCheckboxGroupInput
- )
-}
-
-#' Function called when user clicks on the "Done" button. It stops the shiny
-#' gadget and returns the final htmlwidget
-#'
-#' @param .expr Expression that generates a htmlwidget
-#' @param controls Object created with function preprocessControls
-#'
-#' @return a htmlwidget
-#' @noRd
-onDone <- function(.expr, controls, .return = function(w, e) {w}, nrow = NULL, ncol = NULL) {
- widgets <- lapply(controls$env$ind, function(e) {
- assign(".initial", TRUE, envir = e)
- assign(".session", NULL, envir = e)
- eval(.expr, envir = e)
- })
-
- shiny::stopApp(mwReturn(widgets, .return, controls$env$ind, nrow, ncol))
-}
-
-#' Function that takes a list of widgets and returns the first one if there is
-#' only one or a combinedWidget with all widgets combined.
-#'
-#' @param widgets list of htmlwidgets
-#'
-#' @return a htmlwidget
-#' @noRd
-mwReturn <- function(widgets, .return, envs, nrow = NULL, ncol = NULL) {
- if (length(widgets) == 1) {
- finalWidget <- widgets[[1]]
- } else {
- finalWidget <- combineWidgets(list = widgets, nrow = nrow, ncol = ncol)
- }
- .return(finalWidget, envs)
-}
diff --git a/R/mwUI.R b/R/mwUI.R
deleted file mode 100644
index 0145b95..0000000
--- a/R/mwUI.R
+++ /dev/null
@@ -1,140 +0,0 @@
-#' Private function that generates the general layout of the application
-#'
-#' @param controls Object returned by preprocessControls
-#' @param ncol Number of columns in the chart area.
-#' @param nrow Number of rows in the chart area.
-#' @param outputFun Function that generates the html elements that will contain
-#' a given widget
-#' @param okBtn Should the OK Button be added to the UI ?
-#' @param updateBtn Should the updateBtn be added to the UI ? Currently unused.
-#'
-#' @return shiny tags
-#'
-#' @noRd
-mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL,
- okBtn = TRUE, updateBtn = FALSE, areaBtns = TRUE, border = FALSE) {
-
- htmldep <- htmltools::htmlDependency(
- "manipulateWidget",
- "0.7.0",
- system.file("manipulate_widget", package = "manipulateWidget"),
- script = "manipulate_widget.js",
- style = "manipulate_widget.css"
- )
-
- showSettings <- controls$nmod == 1 || length(controls$controls$shared) > 0
- if (border) class <- "mw-container with-border"
- else class <- "mw-container"
-
- container <- fillPage(
- tags$div(
- class = class,
- fillRow(
- flex = c(NA, NA, 1),
- .uiMenu(controls$nmod, nrow, ncol, showSettings, okBtn, updateBtn, areaBtns),
- .uiControls(controls),
- .uiChartarea(controls$nmod, nrow, ncol, outputFun)
- )
- )
- )
-
- htmltools::attachDependencies(container, htmldep, TRUE)
-}
-
-.uiControls <- function(controls) {
- controls <- c(list(controls$controls$shared), controls$controls$ind)
- controls <- unname(lapply(controls, function(x) {
- if (length(x) == 0) return(NULL)
- tags$div(class = "mw-inputs", mwControlsUI(x))
- }))
-
- controls$class <- "mw-input-container"
- do.call(tags$div, controls)
-}
-
-.uiChartarea <- function(ncharts, nrow, ncol, outputFun) {
- outputEls <- lapply(seq_len(nrow * ncol), function(i) {
- if (i > ncharts) return(tags$div())
- outputId <- paste0("output", i)
- if (is.null(outputFun)) {
- el <- combineWidgetsOutput(outputId, width = "100%", height = "100%")
- } else {
- el <- outputFun(outputId, width = "100%", height = "100%")
- }
- tags$div(class="mw-chart", el)
- })
-
- outputEls <- split(outputEls, (1:(ncol*nrow) - 1) %/% ncol)
- rows <- lapply(outputEls, function(x) {
- do.call(shiny::fillRow, x)
- })
-
- do.call(shiny::fillCol, unname(rows))
-}
-
-.uiMenu <- function(ncharts, nrow, ncol, settingsBtn, okBtn, updateBtn, areaBtns) {
- container <- tags$div(
- class="mw-menu"
- )
-
- if (settingsBtn) {
- settingsBtn <- tags$div(
- class = "mw-btn mw-btn-settings",
- tags$div(
- class = "bt1",
- icon("gears")
- ),
- tags$div(class="right-arrow")
- )
- container <- tagAppendChild(container, settingsBtn)
- }
-
- if (areaBtns && ncharts > 1) {
- container <- tagAppendChild(container, .uiChartBtns(ncharts, nrow, ncol))
- }
-
- if (updateBtn) {
- updateBtn <- tags$div(
- class = "mw-btn mw-btn-update",
- shiny::actionButton(".update", "", icon = shiny::icon("refresh"), class = "bt1")
- )
- container <- tagAppendChild(container, updateBtn)
- }
-
- if (okBtn) {
- okBtn <- shiny::actionButton("done", "OK", class = "mw-btn mw-btn-ok")
- container <- tagAppendChild(container, okBtn)
- }
- container
-}
-
-.uiChartBtns <- function(ncharts, nrow, ncol) {
- btns <- lapply(seq_len(ncharts), function(i) {
- tags$div(
- class = "mw-btn mw-btn-area",
- .uiChartIcon(i, nrow, ncol),
- tags$div(class="right-arrow")
- )
- })
-
- btns$class <- "mw-chart-selection"
-
- do.call(tags$div, btns)
-}
-
-.uiChartIcon <- function(i, nrow, ncol) {
- WIDTH <- 42
- HEIGHT <- 28
- PAD <- 2
- i <- i - 1
-
- w <- (WIDTH - 2 * PAD) / ncol
- h <- (HEIGHT - 2 * PAD) / nrow
-
- chartIconStyle <- sprintf("width:%spx;height:%spx;left:%spx;top:%spx;",
- w, h, w * (i%%ncol) + PAD, h * (i %/% ncol) + PAD)
- tags$div(
- class = "mw-icon-areachart",
- tags$div(class="mw-icon-chart", style=chartIconStyle)
- )
-}
diff --git a/R/mwUI_controls.R b/R/mwUI_controls.R
deleted file mode 100644
index d16861f..0000000
--- a/R/mwUI_controls.R
+++ /dev/null
@@ -1,86 +0,0 @@
-# Copyright © 2016 RTE Réseau de transport d’électricité
-
-#' Generate controls UI of a manipulateWidget gadget
-#'
-#' This function can be used if you want to create a custom UI for your gadget
-#' but desire to use the controls generated by function \code{manipulateWidget}
-#'
-#' @param controlList List of input controls.
-#'
-#' @return
-#' A \code{shiny.tag.list} that can be used to construct a UI for a shiny
-#' gadget.
-#'
-#' @noRd
-#'
-mwControlsUI <- function(controlList) {
- if (length(controlList) == 0) return(NULL)
-
- ids <- names(controlList)
-
- controls <- mapply(
- function(f, id) {
- if(is.list(f)) {
- ctrls <- mwControlsUI(f)
- label <- attr(f, "params")$label
- if (is.null(label)) label <- id
- id <- gsub("[^a-zA-Z0-9]", "_", id)
- res <- tags$div(
- class="panel panel-default",
- tags$div(
- class="panel-heading collapsed",
- style = "cursor: pointer;",
- "data-toggle"="collapse",
- "data-target"=paste0("#panel-body-", id),
- tags$table(
- tags$tbody(
- tags$tr(
- tags$td(class = "arrow"),
- tags$td(label)
- )
- )
- )
- ),
- tags$div(
- class="panel-body collapse",
- id=paste0("panel-body-", id),
- ctrls
- )
- )
-
- } else {
- params <- attr(f, "params")
- params$inputId <- id
- params$width <- "100%"
-
- res <- f(params)
- }
-
- shiny::conditionalPanel(
- condition = sprintf("input.%s_visible", id),
- res
- )
- },
- f = controlList, id = ids,
- SIMPLIFY = FALSE, USE.NAMES = FALSE
- )
-
- vis_checkboxes <- lapply(ids, function(id) {
- id <- gsub("[^a-zA-Z0-9]", "_", id)
- shiny::checkboxInput(paste0(id, "_visible"), "", value = TRUE)
- })
- vis_checkboxes$style <- "display:none"
-
- controls <- append(controls, list(do.call(tags$div, vis_checkboxes)))
-
- do.call(tags$div, controls)
-}
-
-.controlsCol <- function(controls) {
- do.call(tags$div, controls)
-}
-
-.controlsRow <- function(controls) {
- controls$height <- "100px"
- do.call(shiny::fillRow, controls)
-}
diff --git a/R/mw_ui.R b/R/mw_ui.R
new file mode 100644
index 0000000..40b08fc
--- /dev/null
+++ b/R/mw_ui.R
@@ -0,0 +1,161 @@
+#' Private function that generates the general layout of the application
+#'
+#' @param ns namespace function created with shiny::NS(). Useful to create
+#' modules.
+#' @param inputs Object returned by preprocessInputs
+#' @param ncol Number of columns in the chart area.
+#' @param nrow Number of rows in the chart area.
+#' @param outputFun Function that generates the html elements that will contain
+#' a given widget
+#' @param okBtn Should the OK Button be added to the UI ?
+#' @param saveBtn Should the Save Button be added to the UI ?
+#' @param updateBtn Should the updateBtn be added to the UI ? Currently unused.
+#' @param width, height Must be a valid CSS unit (like "100%", "400px", "auto") or a number,
+#' which will be coerced to a string and have "px" appended. Default to "100%" & "400px"
+#'
+#' @return shiny tags
+#'
+#' @noRd
+mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL,
+ okBtn = TRUE, saveBtn = TRUE, updateBtn = FALSE,
+ areaBtns = TRUE, border = FALSE,
+ width = "100%", height = "400px") {
+
+ htmldep <- htmltools::htmlDependency(
+ "manipulateWidget",
+ "0.7.0",
+ system.file("manipulate_widget", package = "manipulateWidget"),
+ script = "manipulate_widget.js",
+ style = "manipulate_widget.css"
+ )
+
+ showSettings <- inputs$ncharts == 1 || length(inputs$inputs$shared) > 0
+ if (border) class <- "mw-container with-border"
+ else class <- "mw-container"
+
+ container <- fillPage(
+ tags$div(
+ class = class,
+ style = paste("width:", width, ";height:", height, ";"),
+ fillRow(
+ flex = c(NA, NA, 1),
+ .uiMenu(ns, inputs$ncharts, nrow, ncol, showSettings, okBtn, saveBtn, updateBtn, areaBtns),
+ .uiInputs(ns, inputs),
+ .uiChartarea(ns, inputs$ncharts, nrow, ncol, outputFun)
+ )
+ )
+ )
+
+ htmltools::attachDependencies(container, htmldep, TRUE)
+}
+
+.uiInputs <- function(ns, inputs) {
+ inputs <- c(list(inputs$inputs$shared), inputs$inputs$ind)
+ ids <- ns(c("mw-shared-inputs", paste0("mw-ind-inputs-", 1:(length(inputs) - 1))))
+ inputs <- mapply(function(x, id) {
+ if (length(x) == 0) return(NULL)
+ content <- lapply(x, function(i) i$getHTML(ns))
+ tags$div(class = "mw-inputs", id = id, shiny::tagList(content))
+ }, x = inputs, id = ids, USE.NAMES = FALSE, SIMPLIFY = FALSE)
+
+ inputs$class <- "mw-input-container"
+ do.call(tags$div, inputs)
+}
+
+.uiChartarea <- function(ns, ncharts, nrow, ncol, outputFun) {
+ outputEls <- lapply(seq_len(nrow * ncol), function(i) {
+ if (i > ncharts) return(tags$div())
+ outputId <- ns(paste0("output_", i))
+ if (is.null(outputFun)) {
+ el <- combineWidgetsOutput(outputId, width = "100%", height = "100%")
+ } else {
+ el <- outputFun(outputId, width = "100%", height = "100%")
+ }
+ style <- sprintf("float:left;width:%s%%;height:%s%%",
+ floor(100 / ncol), floor(100 / nrow))
+ tags$div(class="mw-chart", el, style = style)
+ })
+
+ tags$div(
+ style = "height:100%;width:100%",
+ shiny::tagList(outputEls)
+ )
+}
+
+.uiMenu <- function(ns, ncharts, nrow, ncol, settingsBtn, okBtn, saveBtn, updateBtn, areaBtns) {
+ container <- tags$div(
+ class="mw-menu"
+ )
+
+ if (settingsBtn) {
+ settingsBtn <- tags$div(
+ class = "mw-btn mw-btn-settings",
+ onclick = sprintf("select(this, '%s')", ns("mw-shared-inputs")),
+ tags$div(
+ class = "bt1",
+ icon("gears")
+ ),
+ tags$div(class="right-arrow")
+ )
+ container <- tagAppendChild(container, settingsBtn)
+ }
+
+ if (areaBtns && ncharts > 1) {
+ container <- tagAppendChild(container, .uiChartBtns(ns, ncharts, nrow, ncol))
+ }
+
+ if (updateBtn) {
+ updateBtn <- tags$div(
+ class = "mw-btn mw-btn-update",
+ shiny::actionButton(ns(".update"), "", icon = shiny::icon("refresh"), class = "bt1")
+ )
+ container <- tagAppendChild(container, updateBtn)
+ }
+
+ if (okBtn) {
+ okBtnInput <- shiny::actionButton(ns("done"), "OK", class = "mw-btn mw-btn-ok")
+ container <- tagAppendChild(container, okBtnInput)
+ }
+
+ if (saveBtn) {
+ bottom_px <- ifelse(okBtn, "bottom: 80px;", "bottom: 30px;")
+ saveBtnInput <- shiny::downloadButton(ns("save"), label = "", class = "mw-btn mw-btn-save",
+ style = bottom_px)
+ container <- tagAppendChild(container, saveBtnInput)
+ }
+
+ container
+}
+
+.uiChartBtns <- function(ns, ncharts, nrow, ncol) {
+ ids <- ns(paste0("mw-ind-inputs-", seq_len(ncharts)))
+ btns <- lapply(seq_len(ncharts), function(i) {
+ tags$div(
+ class = "mw-btn mw-btn-area",
+ onclick = sprintf("select(this,'%s')", ids[i]),
+ .uiChartIcon(i, nrow, ncol),
+ tags$div(class="right-arrow")
+ )
+ })
+
+ btns$class <- "mw-chart-selection"
+
+ do.call(tags$div, btns)
+}
+
+.uiChartIcon <- function(i, nrow, ncol) {
+ WIDTH <- 42
+ HEIGHT <- 28
+ PAD <- 2
+ i <- i - 1
+
+ w <- (WIDTH - 2 * PAD) / ncol
+ h <- (HEIGHT - 2 * PAD) / nrow
+
+ chartIconStyle <- sprintf("width:%spx;height:%spx;left:%spx;top:%spx;",
+ w, h, w * (i%%ncol) + PAD, h * (i %/% ncol) + PAD)
+ tags$div(
+ class = "mw-icon-areachart",
+ tags$div(class="mw-icon-chart", style=chartIconStyle)
+ )
+}
diff --git a/R/on_done.R b/R/on_done.R
new file mode 100644
index 0000000..9da447e
--- /dev/null
+++ b/R/on_done.R
@@ -0,0 +1,19 @@
+#' Function called when user clicks on the "Done" button. It stops the shiny
+#' gadget and returns the final htmlwidget
+#'
+#' @param .expr Expression that generates a htmlwidget
+#' @param controls Object created with function preprocessControls
+#'
+#' @return a htmlwidget
+#' @noRd
+onDone <- function(controller, stopApp = TRUE) {
+ for (env in controller$envs$ind) {
+ assign(".initial", TRUE, envir = env)
+ assign(".session", NULL, envir = env)
+ }
+ controller$updateCharts()
+ res <- controller$returnCharts()
+
+ if (stopApp) shiny::stopApp(res)
+ else return(res)
+}
diff --git a/R/preprocessControls.R b/R/preprocessControls.R
deleted file mode 100644
index 5856ee1..0000000
--- a/R/preprocessControls.R
+++ /dev/null
@@ -1,250 +0,0 @@
-#' Private function that transforms the list of inputs as it is expressed by the
-#' user in a convenient object.
-#'
-#' @param controls list of controls
-#' @param compare list describing how comparison should be done
-#' @param env environment
-#'
-#' @return
-#' An object with the following structure:
-#' -nmod: number of modules (1 for no comparison, 2 for a single comparison, etc.)
-#' - desc: A data.frame containing a description of all inputs that will be
-#' created in the UI. It contains the following columns:
-#' - name: parameter name
-#' - initValue: initial value of the parameter
-#' - type: type of input
-#' - level: level in the UI (1 = root element)
-#' - multiple: only for select input. Are multiple values allowed?
-#' - params: parameters for the input
-#' - inputId: Id of the input in the UI
-#' - mod: module index. For convenience, shared controls are in module 0
-#' - env: environment
-#' - env:
-#' - shared: environment containing the value of shared inputs
-#' - ind: list of environments, one for each module
-#' - controls:
-#' - shared: list of shared inputs
-#' - ind: list of list of individual inputs (one for each module)
-#'
-#' @noRd
-preprocessControls <- function(controls, compare = NULL, env, ncharts) {
- # Initialize object returned by the function
- res <- list(
- desc = data.frame(),
- env = list(
- shared = new.env(parent = env),
- ind = list()
- ),
- controls = list(
- shared = list(),
- ind = list()
- )
- )
-
- res$env$shared$.initial <- TRUE
- res$env$shared$.session <- NULL
- res$env$shared$.id <- 1
- res$env$shared$.output <- "output1"
-
- # Number of modules to create
- nmod <- ncharts
-
- res$nmod <- nmod
-
- # Init environments and control list for each module
- for (i in seq_len(nmod)) {
- res$env$ind[[i]] <- new.env(parent = res$env$shared)
- res$env$ind[[i]]$.id <- i
- res$env$ind[[i]]$.initial <- TRUE
- res$env$ind[[i]]$.session <- NULL
- res$env$ind[[i]]$.output <- paste0("output", i)
- res$controls$ind[[i]] <- list()
- }
-
- # Quit function here if there is not any control
- if (length(controls) == 0) return(res)
-
- # controls description #######################################################
-
- controlsDesc <- getControlDesc(controls)
- controlsDesc$inputId <- gsub("[^a-zA-Z0-9]", "_", controlsDesc$name)
- controlsDesc$mod <- 0
-
- # Check if groups have to be compared. if so indicate that the controls belonging
- # to these groups need to be compared.
- groupnames <- controlsDesc$name[controlsDesc$type == "group"]
- while (any(names(compare) %in% groupnames)) {
- addToCompare <- controlsDesc$name[controlsDesc$group %in% names(compare)]
- addToCompare <- sapply(addToCompare, function(x) NULL,
- simplify = FALSE, USE.NAMES = TRUE)
-
- compare[intersect(names(compare), groupnames)] <- NULL
- compare <- append(compare, addToCompare)
- }
-
- controlsDescShared <- subset(controlsDesc, !name %in% names(compare))
- tmp <- list()
- for (i in seq_len(nrow(controlsDescShared))) {
- assign(controlsDescShared$name[i], controlsDescShared$initValue[[i]],
- envir = res$env$shared)
-
- tmp[[i]] <- res$env$shared
- }
- controlsDescShared$env <- tmp
-
- controlsDescInd <- subset(controlsDesc, name %in% names(compare))
-
- if (nrow(controlsDescInd) > 0) {
- controlsDescInd <- lapply(seq_len(nmod), function(i) {
- out <- controlsDescInd
- out$inputId <- paste0(out$inputId, i)
- out$mod <- i
-
- tmp <- list()
- for (j in seq_len(nrow(out))) {
- if (out$name[j] %in% names(compare) && !is.null(compare[[out$name[j]]])) {
- value <- compare[[out$name[j]]][[i]]
- out$initValue[[j]] <- value
- } else {
- value <- out$initValue[[j]]
- }
- assign(out$name[j], value, envir = res$env$ind[[i]])
- tmp[[j]] <- res$env$ind[[i]]
- }
- out$env <- tmp
- out
- })
- controlsDescInd <- do.call(rbind, controlsDescInd)
- }
-
- res$desc <- rbind(controlsDescShared, controlsDescInd)
-
- # Correct initial values #####################################################
-
- oldValue <- list()
- k <- 0
-
- # Updating input parameters may have an incidence on input value and reversely.
- # We update values and parameters in a loop until values are stable.
- # If after 10 loops values are still changing, we give up!
- while(TRUE) {
- if (k == 10) stop("Cannot set initial values. Is there a circular dependency between parameters?")
-
- # Correct initial values
- res$desc$initValue <- getInitValue(res$desc)
- if (identical(oldValue, res$desc$initValue)) break
- for (i in seq_len(nrow(res$desc))) {
- if (res$desc$type[i] == "group") next
- res$desc$params[[i]]$value <- res$desc$initValue[[i]]
- assign(res$desc$name[i], res$desc$initValue[[i]], envir = res$desc$env[[i]])
- }
-
- oldValue <- res$desc$initValue
- k <- k + 1
- }
-
- # Store the current value of input parameters
- res$desc$currentParams <- lapply(seq_len(nrow(res$desc)), function(i) {
- evalParams(res$desc$params[[i]], res$desc$env[[i]])
- })
-
- # List of controls for UI ####################################################
-
- res$controls$shared <- filterControls(controls, names(compare), drop = TRUE)
- res$controls$shared <- setValueAndParams(res$controls$shared, res$desc)
-
- for (i in seq_len(nmod)) {
- res$controls$ind[[i]] <- filterControls(controls, names(compare))
- res$controls$ind[[i]] <- addSuffixToControls(res$controls$ind[[i]], i)
- res$controls$ind[[i]] <- setValueAndParams(res$controls$ind[[i]], res$desc)
- }
-
- res
-}
-
-evalParams <- function(params, env) {
- lapply(params, function(x) {
- tryCatch(eval(x, envir = env), silent = TRUE, error = function(e) {NULL})
- })
-}
-
-getInitValue <- function(desc) {
- type <- desc$type
- value <- desc$initValue
- params <- desc$params
- lapply(seq_along(type), function(i) {
- v <- value[[i]]
- p <- evalParams(params[[i]], desc$env[[i]])
-
- if (type[i] == "slider") {
- v[v < p$min] <- p$min
- v[v > p$max] <- p$max
- } else if (type[i] %in% c("text", "password")) {
- if (is.null(v) || is.na(v)) {
- v <- ""
- } else {
- v <- as.character(v)
- }
- } else if (type[i] == "numeric") {
- if (length(v) == 0 || !is.numeric(v)) {
- v <- NA_real_
- }
- if (!is.na(v)) {
- if (!is.null(p$min) && v < p$min) {
- v <- p$min
- }
- if (!is.null(p$max) && v > p$max) {
- v <- p$max
- }
- }
- } else if (type[i] == "select") {
- if (is.null(v) || !all(v %in% p$choices)) {
- if (is.null(p$multiple) || !p$multiple) {
- v <- p$choices[[1]]
- } else {
- v <- intersect(v, p$choices)
- }
- }
- } else if (type[i] == "checkbox") {
- if (is.null(v) || !is.logical(v)) {
- v <- FALSE
- }
- } else if (type[i] == "radio") {
- if (is.null(v) || !all(v %in% p$choices)) {
- v <- p$choices[[1]]
- }
- } else if (type[i] == "date") {
-
- } else if (type[i] == "dateRange") {
-
- } else if (type[i] == "checkboxGroup") {
- if (is.null(v) || !all(v %in% p$choices)) {
- v <- intersect(v, p$choices)
- }
- }
-
- v
- })
-}
-
-setValueAndParams <- function(controls, desc) {
- name <- desc$inputId
- initValue <- desc$initValue
- params <- desc$currentParams
-
- setValueAndParamsIter <- function(x) {
- for (n in names(x)) {
- if (is.list(x[[n]])) {
- x[[n]] <- setValueAndParamsIter(x[[n]])
- } else {
- i <- which(name == n)
- attr(x[[n]], "params") <- params[[i]]
- attr(x[[n]], "params")$value <- initValue[[i]]
- }
- }
-
- x
- }
-
- setValueAndParamsIter(controls)
-}
diff --git a/R/staticImage.R b/R/static_image.R
similarity index 100%
rename from R/staticImage.R
rename to R/static_image.R
diff --git a/R/zzz.R b/R/zzz.R
index fa8420a..74225d6 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -1,87 +1,87 @@
-# Copyright © 2016 RTE Réseau de transport d’électricité
-
-#' @name manipulateWidget-package
-#'
-#' @title Add even more interactivity to interactive charts
-#'
-#' @description
-#' This package is largely inspired by the \code{manipulate} package from
-#' Rstudio. It can be used to easily create graphical interface that let the
-#' user modify the data or the parameters of an interactive chart. It also
-#' provides the \code{\link{combineWidgets}} function to easily combine multiple
-#' interactive charts in a single view.
-#'
-#' @details
-#' \code{\link{manipulateWidget}} is the main function of the package. It
-#' accepts an expression that generates an interactive chart (and more precisely
-#' an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you
-#' have never heard about it) and a set of controls created with functions
-#' \code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change
-#' values within the expression. Each time the user modifies the value of a
-#' control, the expression is evaluated again and the chart is updated. Consider
-#' the following code:
-#'
-#' \code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))}
-#'
-#' It will generate a graphical interface with a select input on its left with
-#' options "BE", "DE", "ES", "FR". By default, at the beginning the value of the
-#' variable \code{country} will be equal to the first choice of the
-#' corresponding input. So the function will first execute
-#' \code{myPlotFun("BE")} and the result will be displayed in the main panel of
-#' the interface. If the user changes the value to "FR", then the expression
-#' \code{myPlotFun("FR")} is evaluated and the new result is displayed.
-#'
-#' The interface also contains a button "Done". When the user clicks on it, the
-#' last chart is returned. It can be stored in a variable, be modified by the
-#' user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package
-#' \code{htmlwidgets} or converted to a static image file with package
-#' \code{webshot}.
-#'
-#' Finally one can easily create complex layouts thanks to function
-#' \code{\link{combineWidgets}}. For instance, assume we want to see a map that
-#' displays values of some variable for a given year, but on its right side we also
-#' want to see the distributions of three variables. Then we could write:
-#'
-#' \preformatted{
-#' myPlotFun <- function(year, variable) {
-#' combineWidgets(
-#' ncol = 2, colSize = c(3, 1),
-#' myMap(year, variable),
-#' combineWidgets(
-#' ncol = 1,
-#' myHist(year, "V1"),
-#' myHist(year, "V2"),
-#' myHist(year, "V3"),
-#' )
-#' )
-#' }
-#'
-#' manipulateWidget(
-#' myPlotFun(year, variable),
-#' year = mwSlider(2000, 2016, value = 2000),
-#' variable = mwSelect(c("V1", "V2", "V3"))
-#' )
-#' }
-#'
-#' Of course, \code{\link{combineWidgets}} can be used outside of
-#' \code{\link{manipulateWidget}}. For instance, it can be used in an
-#' Rmarkdown document to easily put together interactive charts.
-#'
-#' For more concrete examples of usage, you should look at the documentation and
-#' especially the examples of \code{\link{manipulateWidget}} and
-#' \code{\link{combineWidgets}}.
-#'
-#' @seealso \code{\link{manipulateWidget}}, \code{\link{combineWidgets}}
-#'
-#' @rdname manipulateWidget-package
-#' @docType package
-#' @importFrom shiny tags observe observeEvent reactive isolate icon tagAppendChild
-#' @importFrom shiny tagAppendChildren fillPage fillRow
-#' @importFrom miniUI miniContentPanel miniPage miniTabPanel miniTabstripPanel gadgetTitleBar
-#' @importFrom htmlwidgets getDependency
-#' @importFrom methods is
-#' @importFrom utils getFromNamespace
-#' @importFrom stats runif
-NULL
-#
-globalVariables(c("mod", "multiple", "name", "type"))
+# Copyright © 2016 RTE Réseau de transport d’électricité
+
+#' @name manipulateWidget-package
+#'
+#' @title Add even more interactivity to interactive charts
+#'
+#' @description
+#' This package is largely inspired by the \code{manipulate} package from
+#' Rstudio. It can be used to easily create graphical interface that let the
+#' user modify the data or the parameters of an interactive chart. It also
+#' provides the \code{\link{combineWidgets}} function to easily combine multiple
+#' interactive charts in a single view.
+#'
+#' @details
+#' \code{\link{manipulateWidget}} is the main function of the package. It
+#' accepts an expression that generates an interactive chart (and more precisely
+#' an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you
+#' have never heard about it) and a set of controls created with functions
+#' \code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change
+#' values within the expression. Each time the user modifies the value of a
+#' control, the expression is evaluated again and the chart is updated. Consider
+#' the following code:
+#'
+#' \code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))}
+#'
+#' It will generate a graphical interface with a select input on its left with
+#' options "BE", "DE", "ES", "FR". By default, at the beginning the value of the
+#' variable \code{country} will be equal to the first choice of the
+#' corresponding input. So the function will first execute
+#' \code{myPlotFun("BE")} and the result will be displayed in the main panel of
+#' the interface. If the user changes the value to "FR", then the expression
+#' \code{myPlotFun("FR")} is evaluated and the new result is displayed.
+#'
+#' The interface also contains a button "Done". When the user clicks on it, the
+#' last chart is returned. It can be stored in a variable, be modified by the
+#' user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package
+#' \code{htmlwidgets} or converted to a static image file with package
+#' \code{webshot}.
+#'
+#' Finally one can easily create complex layouts thanks to function
+#' \code{\link{combineWidgets}}. For instance, assume we want to see a map that
+#' displays values of some variable for a given year, but on its right side we also
+#' want to see the distributions of three variables. Then we could write:
+#'
+#' \preformatted{
+#' myPlotFun <- function(year, variable) {
+#' combineWidgets(
+#' ncol = 2, colSize = c(3, 1),
+#' myMap(year, variable),
+#' combineWidgets(
+#' ncol = 1,
+#' myHist(year, "V1"),
+#' myHist(year, "V2"),
+#' myHist(year, "V3"),
+#' )
+#' )
+#' }
+#'
+#' manipulateWidget(
+#' myPlotFun(year, variable),
+#' year = mwSlider(2000, 2016, value = 2000),
+#' variable = mwSelect(c("V1", "V2", "V3"))
+#' )
+#' }
+#'
+#' Of course, \code{\link{combineWidgets}} can be used outside of
+#' \code{\link{manipulateWidget}}. For instance, it can be used in an
+#' Rmarkdown document to easily put together interactive charts.
+#'
+#' For more concrete examples of usage, you should look at the documentation and
+#' especially the examples of \code{\link{manipulateWidget}} and
+#' \code{\link{combineWidgets}}.
+#'
+#' @seealso \code{\link{manipulateWidget}}, \code{\link{combineWidgets}}
+#'
+#' @rdname manipulateWidget-package
+#' @docType package
+#' @importFrom shiny tags observe observeEvent reactive isolate icon tagAppendChild
+#' @importFrom shiny tagAppendChildren fillPage fillRow
+#' @importFrom miniUI miniContentPanel miniPage miniTabPanel miniTabstripPanel gadgetTitleBar
+#' @importFrom htmlwidgets getDependency
+#' @importFrom methods is new setRefClass
+#' @importFrom utils getFromNamespace
+#' @importFrom stats runif
+NULL
+#
+globalVariables(c("mod", "multiple", "name", "type"))
diff --git a/README.Rmd b/README.Rmd
index a3197ba..0ddde97 100644
--- a/README.Rmd
+++ b/README.Rmd
@@ -95,14 +95,15 @@ myPlotFun <- function(distribution, range, title) {
value = randomFun(n = diff(range) + 1)
)
combineWidgets(
- ncol = 2, colsize = c(2, 1),
+ ncol = 1, rowsize = c(2, 1),
dygraph(myData, main = title),
combineWidgets(
+ ncol = 2,
plot_ly(x = myData$value, type = "histogram"),
paste(
- "The graph on the left represents a random time series generated using a ",
+ "The graph above represents a random time series generated using a ",
distribution, "distribution function.
",
- "The chart above represents the empirical distribution of the generated values."
+ "The chart on the left represents the empirical distribution of the generated values."
)
)
)
diff --git a/README.md b/README.md
index 08dd4fd..2fac5d7 100644
--- a/README.md
+++ b/README.md
@@ -2,6 +2,8 @@ Add more interactivity to interactive charts
================
[](http://cran.r-project.org/package=manipulateWidget) [](http://cran.r-project.org/package=manipulateWidget) [](https://travis-ci.org/rte-antares-rpackage/manipulateWidget) [](https://ci.appveyor.com/project/rte-antares-rpackage/manipulatewidget/branch/master)
+[](https://codecov.io/gh/rte-antares-rpackage/manipulateWidget)
+
`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.
diff --git a/inst/examples/example-mwSharedValue.R b/inst/examples/example-mwSharedValue.R
new file mode 100644
index 0000000..aee302d
--- /dev/null
+++ b/inst/examples/example-mwSharedValue.R
@@ -0,0 +1,47 @@
+ui <- fillPage(
+ fillRow(
+ flex = c(NA, 1),
+ div(
+ textInput("title", label = "Title", value = "glop"),
+ sliderInput("obs", "Number of observations:",
+ min = 10, max = 1000, value = 500)
+ ),
+ mwModuleUI("ui", height = "100%")
+ )
+)
+
+server <- function(input, output, session) {
+
+ data <- reactive({
+ if(runif(1) > 0.5){
+ data.frame(
+ year = 2000+1:input$obs,
+ series1 = rnorm(input$obs),
+ series2 = rnorm(input$obs),
+ series3 = rnorm(input$obs)
+ )
+ } else {
+ data.frame(
+ year = 2000+1:input$obs,
+ series1 = rnorm(input$obs),
+ series2 = rnorm(input$obs)
+ )
+ }
+ })
+
+ c <- manipulateWidget(
+ {
+ dygraph(data[range[1]:range[2] - 2000, c("year", series)], main = title)
+ },
+ range = mwSlider(min = 2010,
+ max = 2001 + (nrow(data)-1), c(2001, 2001 + (nrow(data)-1))),
+ series = mwSelect(choices = colnames(data)[-1],
+ value = {colnames(data)[3]}, .display = TRUE),
+ title = mwSharedValue(),
+ data = mwSharedValue(), .runApp = FALSE,
+ .compare = "range"
+ )
+ mwModule("ui", c, title = reactive(input$title), data = data)
+}
+
+shinyApp(ui, server)
diff --git a/inst/examples/example-reactive_values.R b/inst/examples/example-reactive_values.R
new file mode 100644
index 0000000..80bf304
--- /dev/null
+++ b/inst/examples/example-reactive_values.R
@@ -0,0 +1,43 @@
+require(manipulateWidget)
+require(dygraphs)
+
+ui <- fillPage(
+ fillRow(
+ flex = c(NA, 1),
+ div(
+ textInput("title", label = "Title", value = "glop"),
+ selectInput("series", "series", choices = c("series1", "series2", "series3"))
+ ),
+ mwModuleUI("ui", height = "400px")
+ )
+)
+
+range = 2001
+server <- function(input, output, session) {
+ mydata <- data.frame(
+ year = 2000+1:100,
+ series1 = rnorm(100),
+ series2 = rnorm(100),
+ series3 = rnorm(100)
+ )
+
+ c <- manipulateWidget(
+ {
+ dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title)
+ },
+ range = mwSlider(range, 2100, c(2010, 2050)),
+ series = mwSharedValue(),
+ title = mwSharedValue(
+ {"init"}
+ ), .runApp = FALSE,
+ .compare = "range"
+ )
+
+ titre <- reactive({
+ input$title
+ })
+
+ mwModule("ui", c, title = titre, series = reactive(input$series))
+}
+
+shinyApp(ui, server)
diff --git a/inst/examples/manipulateWidget.Rmd b/inst/examples/example-runtime_shiny.Rmd
similarity index 100%
rename from inst/examples/manipulateWidget.Rmd
rename to inst/examples/example-runtime_shiny.Rmd
diff --git a/inst/examples/example-two_mods_one_app.R b/inst/examples/example-two_mods_one_app.R
new file mode 100644
index 0000000..06bcc6e
--- /dev/null
+++ b/inst/examples/example-two_mods_one_app.R
@@ -0,0 +1,57 @@
+library(dygraphs)
+library(plotly)
+library(shiny)
+
+
+mydata <- data.frame(
+ year = 2000+1:100,
+ series1 = rnorm(100),
+ series2 = rnorm(100),
+ series3 = rnorm(100)
+)
+
+c <- manipulateWidget(
+ combineWidgets(dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title)),
+ range = mwSlider(2001, 2100, c(2001, 2100)),
+ series = mwSelect(c("series1", "series2", "series3")),
+ title = mwText("Fictive time series"),
+ .compare = c("title", "series"), .runApp = FALSE
+)
+
+dt <- data.frame (
+ x = sort(runif(100)),
+ y = rnorm(100)
+)
+
+myPlot <- function(type, lwd) {
+ if (type == "points") {
+ plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers")
+ } else {
+ plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd))
+ }
+}
+
+c2 <- manipulateWidget(
+ combineWidgets(myPlot(type, lwd)),
+ type = mwSelect(c("points", "lines"), "points"),
+ lwd = mwSlider(1, 10, 1, .display = type == "lines"), .runApp = FALSE
+)
+
+ui <- navbarPage(
+ "Test manipulateWidget",
+ tabPanel(
+ "Module 1",
+ mwModuleUI("mod1", height = "800px")
+ ),
+ tabPanel(
+ "Module 2",
+ mwModuleUI("mod2", height = "800px")
+ )
+)
+
+server <- function(input, output, session) {
+ mwModule("mod1", c)
+ mwModule("mod2", c2)
+}
+
+shinyApp(ui, server)
diff --git a/inst/manipulate_widget/manipulate_widget.css b/inst/manipulate_widget/manipulate_widget.css
index 9f65ff5..70c72a3 100644
--- a/inst/manipulate_widget/manipulate_widget.css
+++ b/inst/manipulate_widget/manipulate_widget.css
@@ -38,7 +38,7 @@
border-color: transparent transparent transparent #2b7be2;
}
-.active .right-arrow {
+.active>.right-arrow {
display: block;
}
@@ -53,7 +53,7 @@
background-color: #2b7be2;
}
-.bt1 {
+.bt1, .btn.bt1 {
color: #4e9cff;
text-align: center;
vertical-align: bottom;
@@ -106,8 +106,8 @@
}
-/* OK button */
-.mw-btn-ok {
+/* OK and save buttons button */
+.btn.mw-btn-ok, .btn.mw-btn-save {
margin: 0 3px;
width: 44px;
height: 44px;
@@ -124,7 +124,7 @@
padding:0;
}
-.mw-btn-ok:hover, .mw-btn-ok:active, .mw-btn-ok:focus {
+.btn.mw-btn-ok:hover, .btn.mw-btn-ok:active, .btn.mw-btn-ok:focus, .btn.mw-btn-save:hover, .btn.mw-btn-save:focus, .btn.mw-btn-save:active {
color: white;
background-color: #0b946c;
}
@@ -179,6 +179,14 @@ html, body {
padding: 30px 0;
}
+.without-ok .mw-btn-ok {
+ display: none;
+}
+
+.without-save .mw-btn-save {
+ display: none;
+}
+
.with-border > div {
border:solid 1px #ccc;
border-radius: 5px;
diff --git a/inst/manipulate_widget/manipulate_widget.js b/inst/manipulate_widget/manipulate_widget.js
index 4b9629e..3bfe938 100644
--- a/inst/manipulate_widget/manipulate_widget.js
+++ b/inst/manipulate_widget/manipulate_widget.js
@@ -1,29 +1,23 @@
-$( document ).ready(function() {
- $(".mw-btn-settings,.mw-btn-area")
- .click(select)
- .each(function(i) {
- $(this).data("index", i);
- });
-});
-
-function select(e) {
- var el = $(e.currentTarget);
+function select(el, id) {
+ el = $(el);
var active = el.hasClass("active");
$(".mw-btn-settings,.mw-btn-area").removeClass("active");
$(".mw-inputs").css("display", "none");
if (!active) {
- el.addClass("active");
- var i = el.data("index");
- $(".mw-inputs").eq(i).css("display", "block");
+ el.addClass("active");
+ $("#" + id).css("display", "block");
}
-
+
// Resize all widgets
var widgets = HTMLWidgets.findAll(document, ".mw-chart>.html-widget");
+ var ids = $.map($(".mw-chart>.html-widget"), function(x, i) {return x.id});
var container;
if (widgets) {
for (var i = 0; i < widgets.length; i++) {
- container = document.getElementById("output" + (i + 1));
+ container = document.getElementById(ids[i]);
+ if (widgets[i]) {
HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]);
+ }
}
}
}
diff --git a/man/MWController-class.Rd b/man/MWController-class.Rd
new file mode 100644
index 0000000..a3a60ef
--- /dev/null
+++ b/man/MWController-class.Rd
@@ -0,0 +1,77 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/controller.R
+\docType{class}
+\name{MWController-class}
+\alias{MWController-class}
+\alias{MWController}
+\title{Controller object of a manipulateWidget application}
+\description{
+\code{MWController} is a reference class that is used to manage interaction
+with data and update of the view created by manipulateWidget. Only users who
+desire to create automatic tests for applications created with
+\code{\link{manipulateWidget}} should care about this object.
+}
+\section{Fields}{
+
+\describe{
+\item{\code{ncharts}}{Number of charts in the application}
+
+\item{\code{nrow}}{Number of rows.}
+
+\item{\code{ncol}}{Number of columns.}
+
+\item{\code{autoUpdate}}{Boolean indicating if charts should be automatically
+updated when a value changes. list with \code{value} and \code{initBtn} (not autoUpdate, if want first charts on init)}
+}}
+
+\section{Methods}{
+
+\describe{
+\item{\code{getParams(name, chartId = 1)}}{Get parameters of an input for a given chart}
+
+\item{\code{getValue(name, chartId = 1)}}{Get the value of a variable for a given chart.}
+
+\item{\code{getValues(chartId = 1)}}{Get all values for a given chart.}
+
+\item{\code{isVisible(name, chartId = 1)}}{Indicates if a given input is visible}
+
+\item{\code{returnCharts()}}{Return all charts.}
+
+\item{\code{setValue(name, value, chartId = 1, reactive = FALSE)}}{Update the value of a variable for a given chart.}
+
+\item{\code{updateCharts()}}{Update all charts.}
+}}
+
+\section{Testing a manipulateWidget application}{
+
+When \code{\link{manipulateWidget}} is used in a test script, it returns a
+\code{MWController} object instead of starting a shiny gadget. This object has
+methods to modify inputs values and check the state of the application. This
+can be useful to automatically checks if your application behaves like desired.
+Here is some sample code that uses package \code{testthat}:
+
+\preformatted{
+library("testthat")
+
+controller <- manipulateWidget(
+ x + y,
+ x = mwSlider(0, 10, 5),
+ y = mwSlider(0, x, 0),
+ .compare = "y"
+)
+
+test_that("Two charts are created", {
+ expect_equal(controller$ncharts, 2)
+})
+
+test_that("Parameter 'max' of 'y' is updated when 'x' changes", {
+ expect_equal(controller$getParams("y", 1)$max, 5)
+ expect_equal(controller$getParams("y", 2)$max, 5)
+ controller$setValue("x", 3)
+ expect_equal(controller$getParams("y", 1)$max, 3)
+ expect_equal(controller$getParams("y", 2)$max, 3)
+})
+
+}
+}
+
diff --git a/man/combineWidgets-shiny.Rd b/man/combineWidgets-shiny.Rd
index 8a6dab2..51e1617 100644
--- a/man/combineWidgets-shiny.Rd
+++ b/man/combineWidgets-shiny.Rd
@@ -1,30 +1,30 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/combineWidgets.R
-\name{combineWidgets-shiny}
-\alias{combineWidgets-shiny}
-\alias{combineWidgetsOutput}
-\alias{renderCombineWidgets}
-\title{Shiny bindings for combineWidgets}
-\usage{
-combineWidgetsOutput(outputId, width = "100\%", height = "400px")
-
-renderCombineWidgets(expr, env = parent.frame(), quoted = FALSE)
-}
-\arguments{
-\item{outputId}{output variable to read from}
-
-\item{width, height}{Must be a valid CSS unit (like \code{'100\%'},
-\code{'400px'}, \code{'auto'}) or a number, which will be coerced to a
-string and have \code{'px'} appended.}
-
-\item{expr}{An expression that generates a combineWidgets}
-
-\item{env}{The environment in which to evaluate \code{expr}.}
-
-\item{quoted}{Is \code{expr} a quoted expression (with \code{quote()})? This
-is useful if you want to save an expression in a variable.}
-}
-\description{
-Output and render functions for using combineWidgets within Shiny
-applications and interactive Rmd documents.
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/combine_widgets.R
+\name{combineWidgets-shiny}
+\alias{combineWidgets-shiny}
+\alias{combineWidgetsOutput}
+\alias{renderCombineWidgets}
+\title{Shiny bindings for combineWidgets}
+\usage{
+combineWidgetsOutput(outputId, width = "100\%", height = "400px")
+
+renderCombineWidgets(expr, env = parent.frame(), quoted = FALSE)
+}
+\arguments{
+\item{outputId}{output variable to read from}
+
+\item{width, height}{Must be a valid CSS unit (like \code{'100\%'},
+\code{'400px'}, \code{'auto'}) or a number, which will be coerced to a
+string and have \code{'px'} appended.}
+
+\item{expr}{An expression that generates a combineWidgets}
+
+\item{env}{The environment in which to evaluate \code{expr}.}
+
+\item{quoted}{Is \code{expr} a quoted expression (with \code{quote()})? This
+is useful if you want to save an expression in a variable.}
+}
+\description{
+Output and render functions for using combineWidgets within Shiny
+applications and interactive Rmd documents.
+}
diff --git a/man/combineWidgets.Rd b/man/combineWidgets.Rd
index 80e43c5..350f35e 100644
--- a/man/combineWidgets.Rd
+++ b/man/combineWidgets.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/combineWidgets.R
+% Please edit documentation in R/combine_widgets.R
\name{combineWidgets}
\alias{combineWidgets}
\title{Combine several interactive plots}
diff --git a/man/compareOptions.Rd b/man/compareOptions.Rd
index afa189a..1473d72 100644
--- a/man/compareOptions.Rd
+++ b/man/compareOptions.Rd
@@ -1,53 +1,53 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/compareOptions.R
-\name{compareOptions}
-\alias{compareOptions}
-\title{Options for comparison mode}
-\usage{
-compareOptions(ncharts = NULL, nrow = NULL, ncol = NULL)
-}
-\arguments{
-\item{ncharts}{Number of charts to generate.}
-
-\item{nrow}{Number of rows. If \code{NULL}, the function tries to pick the
-best number of rows given the number of charts and columns.}
-
-\item{ncol}{Number of columns. If \code{NULL}, the function tries to pick the
-best number of columns given the number of charts and rows.}
-}
-\value{
-List of options
-}
-\description{
-This function generates a list of options that are used by
-\code{\link{manipulateWidget}} to compare multiple charts.
-}
-\examples{
-if (require(dygraphs)) {
-
- mydata <- data.frame(
- year = 2000+1:100,
- series1 = rnorm(100),
- series2 = rnorm(100),
- series3 = rnorm(100)
- )
- manipulateWidget(
- dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
- range = mwSlider(2001, 2100, c(2001, 2100)),
- series = mwSelect(c("series1", "series2", "series3")),
- title = mwText("Fictive time series"),
- .compare = list(title = NULL, series = NULL),
- .compareOpts = compareOptions(ncharts = 4)
- )
-
- manipulateWidget(
- dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
- range = mwSlider(2001, 2100, c(2001, 2100)),
- series = mwSelect(c("series1", "series2", "series3")),
- title = mwText("Fictive time series"),
- .compare = list(title = NULL, series = NULL),
- .compareOpts = compareOptions(ncharts = 3, nrow = 3)
- )
-}
-
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/compare_options.R
+\name{compareOptions}
+\alias{compareOptions}
+\title{Options for comparison mode}
+\usage{
+compareOptions(ncharts = NULL, nrow = NULL, ncol = NULL)
+}
+\arguments{
+\item{ncharts}{Number of charts to generate.}
+
+\item{nrow}{Number of rows. If \code{NULL}, the function tries to pick the
+best number of rows given the number of charts and columns.}
+
+\item{ncol}{Number of columns. If \code{NULL}, the function tries to pick the
+best number of columns given the number of charts and rows.}
+}
+\value{
+List of options
+}
+\description{
+This function generates a list of options that are used by
+\code{\link{manipulateWidget}} to compare multiple charts.
+}
+\examples{
+if (require(dygraphs)) {
+
+ mydata <- data.frame(
+ year = 2000+1:100,
+ series1 = rnorm(100),
+ series2 = rnorm(100),
+ series3 = rnorm(100)
+ )
+ manipulateWidget(
+ dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
+ range = mwSlider(2001, 2100, c(2001, 2100)),
+ series = mwSelect(c("series1", "series2", "series3")),
+ title = mwText("Fictive time series"),
+ .compare = list(title = NULL, series = NULL),
+ .compareOpts = compareOptions(ncharts = 4)
+ )
+
+ manipulateWidget(
+ dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title),
+ range = mwSlider(2001, 2100, c(2001, 2100)),
+ series = mwSelect(c("series1", "series2", "series3")),
+ title = mwText("Fictive time series"),
+ .compare = list(title = NULL, series = NULL),
+ .compareOpts = compareOptions(ncharts = 3, nrow = 3)
+ )
+}
+
+}
diff --git a/man/knit_print.MWController.Rd b/man/knit_print.MWController.Rd
new file mode 100644
index 0000000..56b2410
--- /dev/null
+++ b/man/knit_print.MWController.Rd
@@ -0,0 +1,16 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/controller.R
+\name{knit_print.MWController}
+\alias{knit_print.MWController}
+\title{knit_print method for MWController object}
+\usage{
+knit_print.MWController(x, ...)
+}
+\arguments{
+\item{x}{MWController object}
+
+\item{...}{arguments passed to function knit_print}
+}
+\description{
+knit_print method for MWController object
+}
diff --git a/man/manipulateWidget-package.Rd b/man/manipulateWidget-package.Rd
index d9f1629..3e6211f 100644
--- a/man/manipulateWidget-package.Rd
+++ b/man/manipulateWidget-package.Rd
@@ -1,76 +1,76 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/zzz.R
-\docType{package}
-\name{manipulateWidget-package}
-\alias{manipulateWidget-package}
-\title{Add even more interactivity to interactive charts}
-\description{
-This package is largely inspired by the \code{manipulate} package from
-Rstudio. It can be used to easily create graphical interface that let the
-user modify the data or the parameters of an interactive chart. It also
-provides the \code{\link{combineWidgets}} function to easily combine multiple
-interactive charts in a single view.
-}
-\details{
-\code{\link{manipulateWidget}} is the main function of the package. It
-accepts an expression that generates an interactive chart (and more precisely
-an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you
-have never heard about it) and a set of controls created with functions
-\code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change
-values within the expression. Each time the user modifies the value of a
-control, the expression is evaluated again and the chart is updated. Consider
-the following code:
-
-\code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))}
-
-It will generate a graphical interface with a select input on its left with
-options "BE", "DE", "ES", "FR". By default, at the beginning the value of the
-variable \code{country} will be equal to the first choice of the
-corresponding input. So the function will first execute
-\code{myPlotFun("BE")} and the result will be displayed in the main panel of
-the interface. If the user changes the value to "FR", then the expression
-\code{myPlotFun("FR")} is evaluated and the new result is displayed.
-
-The interface also contains a button "Done". When the user clicks on it, the
-last chart is returned. It can be stored in a variable, be modified by the
-user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package
-\code{htmlwidgets} or converted to a static image file with package
-\code{webshot}.
-
-Finally one can easily create complex layouts thanks to function
-\code{\link{combineWidgets}}. For instance, assume we want to see a map that
-displays values of some variable for a given year, but on its right side we also
-want to see the distributions of three variables. Then we could write:
-
-\preformatted{
-myPlotFun <- function(year, variable) {
- combineWidgets(
- ncol = 2, colSize = c(3, 1),
- myMap(year, variable),
- combineWidgets(
- ncol = 1,
- myHist(year, "V1"),
- myHist(year, "V2"),
- myHist(year, "V3"),
- )
- )
-}
-
-manipulateWidget(
- myPlotFun(year, variable),
- year = mwSlider(2000, 2016, value = 2000),
- variable = mwSelect(c("V1", "V2", "V3"))
-)
-}
-
-Of course, \code{\link{combineWidgets}} can be used outside of
-\code{\link{manipulateWidget}}. For instance, it can be used in an
-Rmarkdown document to easily put together interactive charts.
-
-For more concrete examples of usage, you should look at the documentation and
-especially the examples of \code{\link{manipulateWidget}} and
-\code{\link{combineWidgets}}.
-}
-\seealso{
-\code{\link{manipulateWidget}}, \code{\link{combineWidgets}}
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/zzz.R
+\docType{package}
+\name{manipulateWidget-package}
+\alias{manipulateWidget-package}
+\title{Add even more interactivity to interactive charts}
+\description{
+This package is largely inspired by the \code{manipulate} package from
+Rstudio. It can be used to easily create graphical interface that let the
+user modify the data or the parameters of an interactive chart. It also
+provides the \code{\link{combineWidgets}} function to easily combine multiple
+interactive charts in a single view.
+}
+\details{
+\code{\link{manipulateWidget}} is the main function of the package. It
+accepts an expression that generates an interactive chart (and more precisely
+an \code{htmlwidget} object. See \url{http://www.htmlwidgets.org/} if you
+have never heard about it) and a set of controls created with functions
+\code{mwSlider}, \code{mwCheckbox}... which are used to dynamically change
+values within the expression. Each time the user modifies the value of a
+control, the expression is evaluated again and the chart is updated. Consider
+the following code:
+
+\code{manipulateWidget(myPlotFun(country), country = mwSelect(c("BE", "DE", "ES", "FR")))}
+
+It will generate a graphical interface with a select input on its left with
+options "BE", "DE", "ES", "FR". By default, at the beginning the value of the
+variable \code{country} will be equal to the first choice of the
+corresponding input. So the function will first execute
+\code{myPlotFun("BE")} and the result will be displayed in the main panel of
+the interface. If the user changes the value to "FR", then the expression
+\code{myPlotFun("FR")} is evaluated and the new result is displayed.
+
+The interface also contains a button "Done". When the user clicks on it, the
+last chart is returned. It can be stored in a variable, be modified by the
+user, saved as a html file with \code{\link[htmlwidgets]{saveWidget}} from package
+\code{htmlwidgets} or converted to a static image file with package
+\code{webshot}.
+
+Finally one can easily create complex layouts thanks to function
+\code{\link{combineWidgets}}. For instance, assume we want to see a map that
+displays values of some variable for a given year, but on its right side we also
+want to see the distributions of three variables. Then we could write:
+
+\preformatted{
+myPlotFun <- function(year, variable) {
+ combineWidgets(
+ ncol = 2, colSize = c(3, 1),
+ myMap(year, variable),
+ combineWidgets(
+ ncol = 1,
+ myHist(year, "V1"),
+ myHist(year, "V2"),
+ myHist(year, "V3"),
+ )
+ )
+}
+
+manipulateWidget(
+ myPlotFun(year, variable),
+ year = mwSlider(2000, 2016, value = 2000),
+ variable = mwSelect(c("V1", "V2", "V3"))
+)
+}
+
+Of course, \code{\link{combineWidgets}} can be used outside of
+\code{\link{manipulateWidget}}. For instance, it can be used in an
+Rmarkdown document to easily put together interactive charts.
+
+For more concrete examples of usage, you should look at the documentation and
+especially the examples of \code{\link{manipulateWidget}} and
+\code{\link{combineWidgets}}.
+}
+\seealso{
+\code{\link{manipulateWidget}}, \code{\link{combineWidgets}}
+}
diff --git a/man/manipulateWidget.Rd b/man/manipulateWidget.Rd
index e65918f..1c9baab 100644
--- a/man/manipulateWidget.Rd
+++ b/man/manipulateWidget.Rd
@@ -1,13 +1,14 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/manipulateWidget.R
+% Please edit documentation in R/manipulate_widget.R
\name{manipulateWidget}
\alias{manipulateWidget}
\title{Add Controls to Interactive Plots}
\usage{
-manipulateWidget(.expr, ..., .updateBtn = FALSE, .viewer = c("pane",
- "window", "browser"), .compare = NULL, .compareOpts = compareOptions(),
+manipulateWidget(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE,
+ .updateBtnInit = FALSE, .viewer = c("pane", "window", "browser"),
+ .compare = NULL, .compareOpts = compareOptions(),
.return = function(widget, envs) { widget }, .width = NULL,
- .height = NULL)
+ .height = NULL, .runApp = TRUE)
}
\arguments{
\item{.expr}{expression to evaluate that returns an interactive plot of class
@@ -26,6 +27,10 @@ named "txt" and "nb".}
\code{TRUE}, then the graphic is updated only when the user clicks on the
update button.}
+\item{.saveBtn}{Should an save button be added to the controls ?}
+
+\item{.updateBtnInit}{In case of update button. Do you want to render graphics on init ?}
+
\item{.viewer}{Controls where the gadget should be displayed. \code{"pane"}
corresponds to the Rstudio viewer, \code{"window"} to a dialog window, and
\code{"browser"} to an external web browser.}
@@ -53,6 +58,13 @@ is null, two or more if it has been defined.}
\item{.height}{Height of the UI. Used only on Rmarkdown documents with option
\code{runtime: shiny}.}
+
+\item{.runApp}{(advanced usage) If true, a shiny gadget is started. If false,
+the function returns a \code{\link{MWController}} object. This object can be
+used to check with command line instructions the behavior of the application.
+(See help page of \code{\link{MWController}}). Notice that this parameter is
+always false in a non-interactive session (for instance when running tests of
+a package).}
}
\value{
The result of the expression evaluated with the last values of the controls.
@@ -162,7 +174,7 @@ if (require(dygraphs)) {
manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ],
main = title, xlab = xlab, ylab = ylab),
range = mwSlider(2001, 2100, c(2001, 2100)),
- "Graphical parameters" = list(
+ "Graphical parameters" = mwGroup(
title = mwText("Fictive time series"),
xlab = mwText("X axis label"),
ylab = mwText("Y axis label")
diff --git a/man/mwCheckbox.Rd b/man/mwCheckbox.Rd
index 9da8537..21437ed 100644
--- a/man/mwCheckbox.Rd
+++ b/man/mwCheckbox.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwCheckbox}
\alias{mwCheckbox}
\title{Add a checkbox to a manipulateWidget gadget}
@@ -42,6 +42,6 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwDateRange}}, \code{\link{mwDate}},
\code{\link{mwGroup}}, \code{\link{mwNumeric}},
\code{\link{mwPassword}}, \code{\link{mwRadio}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwCheckboxGroup.Rd b/man/mwCheckboxGroup.Rd
index 4a32251..a9bdfa1 100644
--- a/man/mwCheckboxGroup.Rd
+++ b/man/mwCheckboxGroup.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwCheckboxGroup}
\alias{mwCheckboxGroup}
\title{Add a group of checkboxes to a manipulateWidget gadget}
@@ -46,6 +46,6 @@ Other controls: \code{\link{mwCheckbox}},
\code{\link{mwDateRange}}, \code{\link{mwDate}},
\code{\link{mwGroup}}, \code{\link{mwNumeric}},
\code{\link{mwPassword}}, \code{\link{mwRadio}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwDate.Rd b/man/mwDate.Rd
index 84c2c4e..424e6ac 100644
--- a/man/mwDate.Rd
+++ b/man/mwDate.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwDate}
\alias{mwDate}
\title{Add a date picker to a manipulateWidget gadget}
@@ -40,6 +40,6 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
\code{\link{mwGroup}}, \code{\link{mwNumeric}},
\code{\link{mwPassword}}, \code{\link{mwRadio}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwDateRange.Rd b/man/mwDateRange.Rd
index 93c0673..8c2bc12 100644
--- a/man/mwDateRange.Rd
+++ b/man/mwDateRange.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwDateRange}
\alias{mwDateRange}
\title{Add a date range picker to a manipulateWidget gadget}
@@ -20,7 +20,7 @@ variable is used.}
the input control should be shown/hidden.}
}
\value{
-A function that will generate the input control.
+An Input object
}
\description{
Add a date range picker to a manipulateWidget gadget
@@ -42,6 +42,6 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwCheckbox}}, \code{\link{mwDate}},
\code{\link{mwGroup}}, \code{\link{mwNumeric}},
\code{\link{mwPassword}}, \code{\link{mwRadio}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwGroup.Rd b/man/mwGroup.Rd
index 3c6ee1c..328a6ce 100644
--- a/man/mwGroup.Rd
+++ b/man/mwGroup.Rd
@@ -1,45 +1,45 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
-\name{mwGroup}
-\alias{mwGroup}
-\title{Group inputs in a collapsible box}
-\usage{
-mwGroup(..., .display = TRUE)
-}
-\arguments{
-\item{...}{inputs that will be grouped in the box}
-
-\item{.display}{expression that evaluates to TRUE or FALSE, indicating when
-the group should be shown/hidden.}
-}
-\value{
-List of inputs
-}
-\description{
-This function generates a collapsible box containing inputs. It can be useful
-when there are a lot of inputs and one wants to group them.
-}
-\examples{
-if(require(dygraphs)) {
- mydata <- data.frame(x = 1:100, y = rnorm(100))
- manipulateWidget(
- dygraph(mydata[range[1]:range[2], ],
- main = title, xlab = xlab, ylab = ylab),
- range = mwSlider(1, 100, c(1, 100)),
- "Graphical parameters" = mwGroup(
- title = mwText("Fictive time series"),
- xlab = mwText("X axis label"),
- ylab = mwText("Y axis label")
- )
- )
-}
-
-}
-\seealso{
-Other controls: \code{\link{mwCheckboxGroup}},
- \code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
- \code{\link{mwDate}}, \code{\link{mwNumeric}},
- \code{\link{mwPassword}}, \code{\link{mwRadio}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/inputs.R
+\name{mwGroup}
+\alias{mwGroup}
+\title{Group inputs in a collapsible box}
+\usage{
+mwGroup(..., .display = TRUE)
+}
+\arguments{
+\item{...}{inputs that will be grouped in the box}
+
+\item{.display}{expression that evaluates to TRUE or FALSE, indicating when
+the group should be shown/hidden.}
+}
+\value{
+Input of type "group".
+}
+\description{
+This function generates a collapsible box containing inputs. It can be useful
+when there are a lot of inputs and one wants to group them.
+}
+\examples{
+if(require(dygraphs)) {
+ mydata <- data.frame(x = 1:100, y = rnorm(100))
+ manipulateWidget(
+ dygraph(mydata[range[1]:range[2], ],
+ main = title, xlab = xlab, ylab = ylab),
+ range = mwSlider(1, 100, c(1, 100)),
+ "Graphical parameters" = mwGroup(
+ title = mwText("Fictive time series"),
+ xlab = mwText("X axis label"),
+ ylab = mwText("Y axis label")
+ )
+ )
+}
+
+}
+\seealso{
+Other controls: \code{\link{mwCheckboxGroup}},
+ \code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
+ \code{\link{mwDate}}, \code{\link{mwNumeric}},
+ \code{\link{mwPassword}}, \code{\link{mwRadio}},
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
+}
diff --git a/man/mwModule.Rd b/man/mwModule.Rd
new file mode 100644
index 0000000..4bf7a96
--- /dev/null
+++ b/man/mwModule.Rd
@@ -0,0 +1,92 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/module_ui.R
+\name{mwModule}
+\alias{mwModule}
+\alias{mwModuleUI}
+\title{Add a manipulateWidget to a shiny application}
+\usage{
+mwModule(id, controller, ...)
+
+mwModuleUI(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin = 0,
+ width = "100\%", height = 400, header = NULL, footer = NULL,
+ fluidRow = FALSE)
+}
+\arguments{
+\item{id}{A unique string that identifies the module}
+
+\item{controller}{Object of class \code{\link{MWController}} returned by
+\code{\link{manipulateWidget}} when parameter \code{.runApp} is
+\code{FALSE}.}
+
+\item{...}{named arguments containing reactive values. They can be used to send data from
+the main shiny application to the module.}
+
+\item{border}{Should a border be added to the module?}
+
+\item{okBtn}{Should the UI contain the OK button?}
+
+\item{saveBtn}{Should the UI contain the save button?}
+
+\item{margin}{Margin to apply around the module UI. Should be one two or four valid css
+units.}
+
+\item{width}{Width of the module UI.}
+
+\item{height}{Height of the module UI.}
+
+\item{header}{Tag or list of tags to display as a common header above all tabPanels.}
+
+\item{footer}{Tag or list of tags to display as a common footer below all tabPanels}
+
+\item{fluidRow}{Include module in a fluidRow ? Can be usefull in a shiny app. Defaut to FALSE}
+}
+\value{
+\code{mwModuleUI} returns the required HTML elements for the module. mwModule is only
+used for its side effects.
+}
+\description{
+These two functions can be used to include a manipulateWidget object in a shiny application.
+\code{mwModuleUI} must be used in the UI to generate the required HTML elements and add
+javascript and css dependencies. \code{mwModule} must be called once in the server function
+of the application.
+}
+\examples{
+if (interactive() & require("dygraphs")) {
+ require("shiny")
+ ui <- fillPage(
+ fillRow(
+ flex = c(NA, 1),
+ div(
+ textInput("title", label = "Title", value = "glop"),
+ selectInput("series", "series", choices = c("series1", "series2", "series3"))
+ ),
+ mwModuleUI("ui", height = "100\%")
+ ))
+
+ server <- function(input, output, session) {
+ mydata <- data.frame(
+ year = 2000+1:100,
+ series1 = rnorm(100),
+ series2 = rnorm(100),
+ series3 = rnorm(100)
+ )
+
+ c <- manipulateWidget(
+ {
+ dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title)
+ },
+ range = mwSlider(2001, 2100, c(2001, 2050)),
+ series = mwSharedValue(),
+ title = mwSharedValue(), .runApp = FALSE,
+ .compare = "range"
+ )
+ #
+ mwModule("ui", c, title = reactive(input$title), series = reactive(input$series))
+ }
+
+ shinyApp(ui, server)
+
+
+}
+
+}
diff --git a/man/mwNumeric.Rd b/man/mwNumeric.Rd
index 7a7fee5..e8721da 100644
--- a/man/mwNumeric.Rd
+++ b/man/mwNumeric.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwNumeric}
\alias{mwNumeric}
\title{Add a numeric input to a manipulateWidget gadget}
@@ -41,6 +41,6 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
\code{\link{mwDate}}, \code{\link{mwGroup}},
\code{\link{mwPassword}}, \code{\link{mwRadio}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwPassword.Rd b/man/mwPassword.Rd
index 4d19461..b8b41d2 100644
--- a/man/mwPassword.Rd
+++ b/man/mwPassword.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwPassword}
\alias{mwPassword}
\title{Add a password to a manipulateWidget gadget}
@@ -45,6 +45,6 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
\code{\link{mwDate}}, \code{\link{mwGroup}},
\code{\link{mwNumeric}}, \code{\link{mwRadio}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwRadio.Rd b/man/mwRadio.Rd
index 2f9972e..91fa8ca 100644
--- a/man/mwRadio.Rd
+++ b/man/mwRadio.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwRadio}
\alias{mwRadio}
\title{Add radio buttons to a manipulateWidget gadget}
@@ -45,6 +45,6 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
\code{\link{mwDate}}, \code{\link{mwGroup}},
\code{\link{mwNumeric}}, \code{\link{mwPassword}},
- \code{\link{mwSelect}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwSelect}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwSelect.Rd b/man/mwSelect.Rd
index 7d3a197..b8125c3 100644
--- a/man/mwSelect.Rd
+++ b/man/mwSelect.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwSelect}
\alias{mwSelect}
\title{Add a Select list input to a manipulateWidget gadget}
@@ -62,6 +62,6 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
\code{\link{mwDate}}, \code{\link{mwGroup}},
\code{\link{mwNumeric}}, \code{\link{mwPassword}},
- \code{\link{mwRadio}}, \code{\link{mwSlider}},
- \code{\link{mwText}}
+ \code{\link{mwRadio}}, \code{\link{mwSharedValue}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
}
diff --git a/man/mwSharedValue.Rd b/man/mwSharedValue.Rd
new file mode 100644
index 0000000..0d1dc47
--- /dev/null
+++ b/man/mwSharedValue.Rd
@@ -0,0 +1,59 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/inputs.R
+\name{mwSharedValue}
+\alias{mwSharedValue}
+\title{Shared Value}
+\usage{
+mwSharedValue(expr = NULL)
+}
+\arguments{
+\item{expr}{Expression used to compute the value of the input.}
+}
+\value{
+An Input object of type "sharedValue".
+}
+\description{
+This function creates a virtual input that can be used to store a dynamic
+shared variable that is accessible in inputs as well as in output.
+}
+\examples{
+
+if (require(plotly)) {
+ # Plot the characteristics of a car and compare with the average values for
+ # cars with same number of cylinders.
+ # The shared variable 'subsetCars' is used to avoid subsetting multiple times
+ # the data: this value is updated only when input 'cylinders' changes.
+ colMax <- apply(mtcars, 2, max)
+
+ plotCar <- function(cardata, carName) {
+ carValues <- unlist(cardata[carName, ])
+ carValuesRel <- carValues / colMax
+
+ avgValues <- round(colMeans(cardata), 2)
+ avgValuesRel <- avgValues / colMax
+
+ plot_ly() \%>\%
+ add_bars(x = names(cardata), y = carValuesRel, text = carValues,
+ hoverinfo = c("x+text"), name = carName) \%>\%
+ add_bars(x = names(cardata), y = avgValuesRel, text = avgValues,
+ hoverinfo = c("x+text"), name = "average") \%>\%
+ layout(barmode = 'group')
+ }
+
+ c <- manipulateWidget(
+ plotCar(subsetCars, car),
+ cylinders = mwSelect(c("4", "6", "8")),
+ subsetCars = mwSharedValue(subset(mtcars, cylinders == cyl)),
+ car = mwSelect(choices = row.names(subsetCars))
+ )
+}
+
+}
+\seealso{
+Other controls: \code{\link{mwCheckboxGroup}},
+ \code{\link{mwCheckbox}}, \code{\link{mwDateRange}},
+ \code{\link{mwDate}}, \code{\link{mwGroup}},
+ \code{\link{mwNumeric}}, \code{\link{mwPassword}},
+ \code{\link{mwRadio}}, \code{\link{mwSelect}},
+ \code{\link{mwSlider}}, \code{\link{mwText}}
+}
diff --git a/man/mwSlider.Rd b/man/mwSlider.Rd
index fe74512..7d2adbe 100644
--- a/man/mwSlider.Rd
+++ b/man/mwSlider.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwSlider}
\alias{mwSlider}
\title{Add a Slider to a manipulateWidget gadget}
@@ -57,5 +57,5 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwDate}}, \code{\link{mwGroup}},
\code{\link{mwNumeric}}, \code{\link{mwPassword}},
\code{\link{mwRadio}}, \code{\link{mwSelect}},
- \code{\link{mwText}}
+ \code{\link{mwSharedValue}}, \code{\link{mwText}}
}
diff --git a/man/mwText.Rd b/man/mwText.Rd
index c739398..0da8287 100644
--- a/man/mwText.Rd
+++ b/man/mwText.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/controls.R
+% Please edit documentation in R/inputs.R
\name{mwText}
\alias{mwText}
\title{Add a text input to a manipulateWidget gadget}
@@ -41,5 +41,5 @@ Other controls: \code{\link{mwCheckboxGroup}},
\code{\link{mwDate}}, \code{\link{mwGroup}},
\code{\link{mwNumeric}}, \code{\link{mwPassword}},
\code{\link{mwRadio}}, \code{\link{mwSelect}},
- \code{\link{mwSlider}}
+ \code{\link{mwSharedValue}}, \code{\link{mwSlider}}
}
diff --git a/man/staticPlot.Rd b/man/staticPlot.Rd
index 5b44070..c6d8ffa 100644
--- a/man/staticPlot.Rd
+++ b/man/staticPlot.Rd
@@ -1,54 +1,54 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/staticImage.R
-\name{staticPlot}
-\alias{staticPlot}
-\alias{staticImage}
-\title{Include a static image in a combinedWidgets}
-\usage{
-staticPlot(expr, width = 600, height = 400)
-
-staticImage(file, style = "max-width:100\%\%;max-height:100\%\%")
-}
-\arguments{
-\item{expr}{Expression that creates a static plot.}
-
-\item{width}{Width of the image to create.}
-
-\item{height}{Height of the image to create.}
-
-\item{file}{path of the image to include.}
-
-\item{style}{CSS style to apply to the image.}
-}
-\value{
-a \code{shiny.tag} object containing the HTML code required to include
-the image or the plot in a \code{combinedWidgets} object.
-}
-\description{
-\code{staticPlot} is a function that generates a static plot and then return
-the HTML code needed to include the plot in a combinedWidgets.
-\code{staticImage} is a more general function that generates the HTML code
-necessary to include any image file.
-}
-\examples{
-staticPlot(hist(rnorm(100)))
-
-if (require(plotly)) {
- data(iris)
-
- combineWidgets(
- plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
- staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
- )
-
- # You can also embed static images in the header, footer, left or right
- # columns of a combinedWidgets. The advantage is that the space allocated
- # to the static plot will be constant when the window is resized.
-
- combineWidgets(
- plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
- footer = staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
- )
-}
-
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/static_image.R
+\name{staticPlot}
+\alias{staticPlot}
+\alias{staticImage}
+\title{Include a static image in a combinedWidgets}
+\usage{
+staticPlot(expr, width = 600, height = 400)
+
+staticImage(file, style = "max-width:100\%\%;max-height:100\%\%")
+}
+\arguments{
+\item{expr}{Expression that creates a static plot.}
+
+\item{width}{Width of the image to create.}
+
+\item{height}{Height of the image to create.}
+
+\item{file}{path of the image to include.}
+
+\item{style}{CSS style to apply to the image.}
+}
+\value{
+a \code{shiny.tag} object containing the HTML code required to include
+the image or the plot in a \code{combinedWidgets} object.
+}
+\description{
+\code{staticPlot} is a function that generates a static plot and then return
+the HTML code needed to include the plot in a combinedWidgets.
+\code{staticImage} is a more general function that generates the HTML code
+necessary to include any image file.
+}
+\examples{
+staticPlot(hist(rnorm(100)))
+
+if (require(plotly)) {
+ data(iris)
+
+ combineWidgets(
+ plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
+ staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
+ )
+
+ # You can also embed static images in the header, footer, left or right
+ # columns of a combinedWidgets. The advantage is that the space allocated
+ # to the static plot will be constant when the window is resized.
+
+ combineWidgets(
+ plot_ly(iris, x = ~Sepal.Length, type = "histogram", nbinsx = 20),
+ footer = staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300)
+ )
+}
+
+}
diff --git a/man/summary.MWController.Rd b/man/summary.MWController.Rd
new file mode 100644
index 0000000..f11cf5b
--- /dev/null
+++ b/man/summary.MWController.Rd
@@ -0,0 +1,16 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/controller.R
+\name{summary.MWController}
+\alias{summary.MWController}
+\title{summary method for MWController object}
+\usage{
+\method{summary}{MWController}(object, ...)
+}
+\arguments{
+\item{object}{MWController object}
+
+\item{...}{Not use}
+}
+\description{
+summary method for MWController object
+}
diff --git a/manipulateWidget.Rproj b/manipulateWidget.Rproj
index 6daccaa..488ba32 100644
--- a/manipulateWidget.Rproj
+++ b/manipulateWidget.Rproj
@@ -18,4 +18,4 @@ StripTrailingWhitespace: Yes
BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
-PackageRoxygenize: rd,collate,namespace
+PackageRoxygenize: rd,collate,namespace,vignette
diff --git a/tests/testthat/helper-input_class.R b/tests/testthat/helper-input_class.R
new file mode 100644
index 0000000..377ce71
--- /dev/null
+++ b/tests/testthat/helper-input_class.R
@@ -0,0 +1,31 @@
+test_input <- function(input, values = NULL, expectedValues = NULL, name = "myInput") {
+ describe(paste("input", input$type), {
+ it ("is correctly initialized", {
+ env <- initEnv(parent.frame(), 1)
+ input$init(name, env)
+
+ expect_initialized(input)
+ expect_equal(input$env, env)
+ expect_equal(input$label, name)
+ if(!"call" %in% class(input$value)){
+ expect_equal(input$value, get(name, envir = env))
+ } else {
+ expect_equal(evalValue(input$value, parent.frame()), get(name, envir = env))
+ }
+ expect_is(input$params, "list")
+ })
+
+ it ("sets valid values", {
+ for (i in seq_along(values)) {
+ input$setValue(values[[i]])
+ expect_equal(input$value, expectedValues[[i]])
+ expect_equal(get(name, envir = input$env), expectedValues[[i]])
+ }
+ })
+ })
+}
+
+expect_initialized <- function(input) {
+ expect_is(input, "Input")
+ expect(!emptyField(input$name) & !emptyField(input$env), "Input unitialized")
+}
diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R
new file mode 100644
index 0000000..2ff682b
--- /dev/null
+++ b/tests/testthat/test-controller.R
@@ -0,0 +1,102 @@
+context("MWController class")
+
+describe("MWController", {
+ it("can be created with the result of initInputs()", {
+ inputs <- initInputs(list(a = mwText("a"), b = mwText("b")))
+ expr <- expression(paste(a, b))
+ controller <- MWController(expr, inputs)$init()
+ controller$updateCharts()
+ expect_is(controller$charts, "list")
+ expect_length(controller$charts, 1)
+ expect_equal(controller$charts[[1]]$widgets[[1]], "a b")
+ })
+
+ it("creates multiple charts in comparison mode", {
+ inputs <- initInputs(list(a = mwText("a"), b = mwText("b")), compare = "b",
+ ncharts = 3)
+ expr <- expression(paste(a, b))
+ controller <- MWController(expr, inputs)$init()
+ controller$updateCharts()
+ expect_is(controller$charts, "list")
+ expect_length(controller$charts, 3)
+ for (o in controller$charts) expect_equal(o$widgets[[1]], "a b")
+ })
+
+ it ("does not update charts if values do not change", {
+ inputs <- initInputs(list(a = mwText("a"), b = mwText("b")))
+ expr <- expression(print("chart updated"))
+ expect_output(controller <- MWController(expr, inputs)$init(), "chart updated")
+ expect_output(controller$updateCharts(), "chart updated")
+ # Update a with different value
+ expect_output(controller$setValue("a", "b"), "chart updated")
+ # Update a with same value
+ expect_silent(controller$setValue("a", "b"))
+ })
+
+ it("creates a copy that is completely autonomous", {
+ inputs <- initInputs(list(a = mwText("a"), b = mwText("b")))
+ expr <- expression(paste(a, b))
+ controller1 <- MWController(expr, inputs)$init()
+ controller2 <- controller1$clone()
+
+ controller1$setValue("a", "test")
+ expect_equal(controller1$getValue("a"), "test")
+ expect_equal(controller2$getValue("a"), "a")
+ expect_true(controller2$initialized)
+ expect_true(controller2$inputList$initialized)
+ })
+
+ it("accesses parameters of a given input", {
+ inputs <- initInputs(list(a = mwSelect(c("a", "b", "c")), b = mwText("b")))
+ expr <- expression(paste(a, b))
+ controller <- MWController(expr, inputs)$init()
+ expect_equal(controller$getParams("a")$choices, c("a", "b", "c"))
+ })
+
+ it("generates server and ui functions", {
+ inputs <- initInputs(list(a = mwSelect(c("a", "b", "c")), b = mwText("b")))
+ expr <- expression(paste(a, b))
+ controller <- MWController(expr, inputs)$init()
+ ui <- controller$getModuleUI()
+ server <- controller$getModuleServer()
+ expect_is(ui, "function")
+ expect_is(server, "function")
+ expect_equal(names(formals(server)), c("input", "output", "session", "..."))
+ })
+
+ it("does not update values or create charts until it is initialized", {
+ inputs <- initInputs(list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)))
+ expr <- expression(paste(x, y))
+ controller <- MWController(expr, inputs)
+ expect_length(controller$charts, 0)
+ expect_equal(controller$getValue("y"), 0)
+ controller$setValue("x", 3)
+ expect_length(controller$charts, 0)
+ expect_equal(controller$getValue("y"), 0)
+ controller$init()
+ expect_length(controller$charts, 1)
+ expect_equal(controller$charts[[1]]$widgets[[1]], "3 3")
+ expect_equal(controller$getValue("y"), 3)
+ })
+})
+
+describe("summary.MWController", {
+ it("prints information about controller", {
+ controller <- manipulateWidget(
+ d$value,
+ a = mwSelect(c("a", "b", "c")),
+ b = mwSelect(c("a", "b", "c"), "b"),
+ c = mwSelect(c("a", "b", "c"), c("a", "b"), multiple = TRUE),
+ d = mwSharedValue(data.frame(value = 1)),
+ .runApp = FALSE
+ )
+ expect_output(summary(controller), "List of inputs")
+ # Indicates NULL values
+ expect_output(summary(controller), "NULL")
+ # paste values if multiple values
+ expect_output(summary(controller), "a, b")
+ # for complicated objects, indicates the class of object
+ controller$init()
+ expect_output(summary(controller), "data.frame")
+ })
+})
diff --git a/tests/testthat/test-get_output_and_render_func.R b/tests/testthat/test-get_output_and_render_func.R
new file mode 100644
index 0000000..37211bc
--- /dev/null
+++ b/tests/testthat/test-get_output_and_render_func.R
@@ -0,0 +1,22 @@
+context("getOutputAndRenderFunc")
+
+describe("getOutputAndRenderFunc", {
+ if(require("leaflet")){
+ it ("returns output and render functions of a widget", {
+ widget <- leaflet()
+ res <- getOutputAndRenderFunc(widget)
+ expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets"))
+ expect_equal(res$outputFunc, leaflet::leafletOutput)
+ expect_equal(res$renderFunc, leaflet::renderLeaflet)
+ expect_equal(res$useCombineWidgets, FALSE)
+ })
+
+ it ("returns combineWidgets output and render functions if x is not an htmlwidget", {
+ res <- getOutputAndRenderFunc("test")
+ expect_named(res, c("outputFunc", "renderFunc", "useCombineWidgets"))
+ expect_equal(res$outputFunc, combineWidgetsOutput)
+ expect_equal(res$renderFunc, renderCombineWidgets)
+ expect_equal(res$useCombineWidgets, TRUE)
+ })
+ }
+})
diff --git a/tests/testthat/test-init_inputs.R b/tests/testthat/test-init_inputs.R
new file mode 100644
index 0000000..71bc0e4
--- /dev/null
+++ b/tests/testthat/test-init_inputs.R
@@ -0,0 +1,72 @@
+context("initInputs")
+
+# Helper function that checks the structure of the object returned by initInputs.
+# It returns the said object for further testing
+test_structure <- function(inputs, compare = NULL, ncharts = 1) {
+ res <- initInputs(inputs, compare = compare, ncharts = ncharts)
+
+ inputList <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
+ inputList <- flattenInputs(inputList)
+
+ expect_is(res, "list")
+ expect_named(res, c("envs", "inputs", "inputList", "ncharts"))
+ expect_is(res$envs, "list")
+ expect_named(res$envs, c("shared", "ind"))
+ expect_is(res$envs$ind, "list")
+ expect_length(res$envs$ind, ncharts)
+
+ expect_is(res$inputs, "list")
+ expect_named(res$inputs, c("shared", "ind"))
+ expect_is(res$inputs$ind, "list")
+ expect_length(res$inputs$ind, ncharts)
+
+ expect_is(res$inputList, "InputList")
+ expectedLength <- length(inputList) + length(compare) * (ncharts - 1)
+ # inexact when one tries to compare grouped inputs
+ expect_length(res$inputList$inputs, expectedLength)
+
+ sharedInputs <- setdiff(names(inputList), names(compare))
+ expected_names <- paste0("shared_", sharedInputs)
+ if (length(compare) > 0) {
+ for (i in seq_len(ncharts)) {
+ expected_names <- append(
+ expected_names,
+ paste0("output_", i, "_", names(compare))
+ )
+ }
+ }
+
+ expect_true(all(expected_names %in% names(res$inputList$inputs)))
+
+ res
+}
+
+describe("initInputs", {
+ it("generates correct structure", {
+ test_structure(list(a = mwText(), b = mwText()))
+ })
+
+ it("handles grouped inputs", {
+ test_structure(list(grp = mwGroup(a = mwText(), b = mwText())))
+ })
+
+ it("still works if ncharts > 1", {
+ test_structure(list(grp = mwGroup(a = mwText(), b = mwText())), ncharts = 2)
+ })
+
+ it("prepares inputs for comparison", {
+ test_structure(list(a = mwText(), b = mwText()), ncharts = 2,
+ compare = list(a = NULL))
+ })
+
+ it("prepares inputs for comparison with different initial values", {
+ res <- test_structure(list(a = mwText(), b = mwText()), ncharts = 2,
+ compare = list(a = c("a", "b")))
+
+ })
+
+ it("throws errors if inputs are not inputs or not named", {
+ expect_error(initInputs(list(mwText())), "All arguments need to be named.")
+ expect_error(initInputs(list(a = 1)), "All arguments need to be Input objects.")
+ })
+})
diff --git a/tests/testthat/test-input_class.R b/tests/testthat/test-input_class.R
new file mode 100644
index 0000000..889b4f9
--- /dev/null
+++ b/tests/testthat/test-input_class.R
@@ -0,0 +1,44 @@
+context("Input class")
+
+describe("Input", {
+ inputTPL <- Input(
+ type = "test",
+ value = 0,
+ params = list(
+ min = expression(0),
+ max = expression(10)
+ ),
+ display = expression(TRUE),
+ validFunc = function(x, params) {
+ min(max(params$min, x), params$max)
+ },
+ htmlFunc = htmlFuncFactory(shiny::numericInput)
+ )
+
+ # Basic check
+ test_input(inputTPL$copy(), c(5, -20, 20), c(5, 0, 10))
+
+ it("correctly updates value when environment changes", {
+ myInput <- inputTPL$copy()
+ myInput$params$min <- expression(minx)
+
+ env <- initEnv(parent.frame(), 1)
+ assign("minx", 0, envir = env)
+ myInput$init("x", env)
+ expect_equal(myInput$value, 0)
+
+ assign("minx", 5, envir = env)
+ expect_equal(myInput$updateValue(), 5)
+ expect_equal(myInput$value, 5)
+ expect_equal(get("x", envir = env), 5)
+ })
+
+ it("returns a valid ID (in a JS point of view)", {
+ myInput <- inputTPL$copy()
+ env <- initEnv(parent.frame(), 1)
+ myInput$init("invalid.name", env)
+
+ expect_equal(myInput$getID(), "output_1_invalid_name")
+ })
+
+})
diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R
new file mode 100644
index 0000000..2c10167
--- /dev/null
+++ b/tests/testthat/test-input_list_class.R
@@ -0,0 +1,103 @@
+context("InputList class")
+
+describe("InputList", {
+ it ("correctly updates values when an input value changes", {
+ inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
+ inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
+ inputList <- InputList(inputs)$init()
+
+ expect_equal(inputList$inputs$output_1_y$value, 5)
+
+ inputList$setValue(inputId = "output_1_x", value = 7)
+ expect_equal(inputList$inputs$output_1_y$value, 7)
+ })
+
+ it("detects dependencies between inputs", {
+ inputs <- list(
+ x = mwSlider(0, 10, 5),
+ y = mwSlider(x, 10, 0, .display = z > 3),
+ z = mwSlider(0, x, 0)
+ )
+ inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
+ inputList <- InputList(inputs)$init()
+ expect_equal(inputList$getDeps(inputList$inputs$output_1_x),
+ list(params = character(), display = character()))
+ expect_length(inputList$inputs$output_1_y$revDeps, 0)
+ expect_equal(inputList$getDeps(inputList$inputs$output_1_y),
+ list(params = "output_1_x", display = "output_1_z"))
+ expect_equal(inputList$inputs$output_1_x$revDeps, c("output_1_y", "output_1_z"))
+ expect_equal(inputList$inputs$output_1_z$displayRevDeps, c("output_1_y"))
+ })
+
+ inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(0, 10, 0))
+ inputs2 <- list(x = mwSlider(0, 10, 6), y = mwSlider(0, 10, 1))
+ inputs <- c(
+ filterAndInitInputs(list(shared = mwText("test")), c(), TRUE,
+ initEnv(parent.frame(), 0)),
+ filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1)),
+ filterAndInitInputs(inputs2, c(), TRUE, initEnv(parent.frame(), 2))
+ )
+ inputList <- InputList(inputs)$init()
+
+ it ("gets and updates an input by name and chartId", {
+ # Get Input
+ # Individual inputs
+ expect_equal(inputList$getInput("x", 1)$value, 5)
+ expect_equal(inputList$getInput("x", 2)$value, 6)
+ # Shared inputs
+ expect_equal(inputList$getInput("shared", 1)$value, "test")
+ expect_equal(inputList$getInput("shared", 2)$value, "test")
+
+ # Get input value
+ # Individual inputs
+ expect_equal(inputList$getValue("x", 1), 5)
+ expect_equal(inputList$getValue("x", 2), 6)
+ # Shared inputs
+ expect_equal(inputList$getValue("shared", 1), "test")
+ expect_equal(inputList$getValue("shared", 2), "test")
+
+ # Update input value
+ # Individual inputs
+ expect_equal(inputList$setValue("x", 4, 1), 4)
+ expect_equal(inputList$setValue("x", 5, 2), 5)
+ expect_equal(inputList$getValue("x", 1), 4)
+ expect_equal(inputList$getValue("x", 2), 5)
+ # Shared inputs
+ expect_equal(inputList$setValue("shared", "test1", 1), "test1")
+ expect_equal(inputList$getValue("shared", 1), "test1")
+ expect_equal(inputList$setValue("shared", "test2", 1), "test2")
+ expect_equal(inputList$getValue("shared", 2), "test2")
+
+ it ("gets all values for one chart", {
+ for (i in 1:2) {
+ values <- inputList$getValues(i)
+ expect_is(values, "list")
+ expect_named(values, c("shared", "x", "y"), ignore.order = TRUE)
+ for (n in c("shared", "x", "y")) {
+ expect_equal(values[[n]], inputList$getValue(n, i))
+ }
+ }
+ })
+
+ it ("indicates if an input is shared or not", {
+ expect_true(inputList$isShared("shared"))
+ expect_true(! inputList$isShared("x"))
+ expect_true(! inputList$isShared("y"))
+ })
+
+ it ("does not modify values until it is initialized", {
+ inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0))
+ inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1))
+ inputList <- InputList(inputs)
+
+ expect_equal(inputList$inputs$output_1_y$value, 0)
+ inputList$setValue(inputId = "output_1_x", value = 7)
+ expect_equal(inputList$inputs$output_1_y$value, 0)
+
+ inputList$init()
+ expect_equal(inputList$inputs$output_1_y$value, 7)
+ inputList$setValue(inputId = "output_1_x", value = 8)
+ expect_equal(inputList$inputs$output_1_y$value, 8)
+ })
+ })
+})
diff --git a/tests/testthat/test-input_utils.R b/tests/testthat/test-input_utils.R
new file mode 100644
index 0000000..570834e
--- /dev/null
+++ b/tests/testthat/test-input_utils.R
@@ -0,0 +1,111 @@
+context("Input utils")
+
+describe("filterAndInitInputs", {
+
+ it ("returns a filtered list of initialized inputs", {
+ inputs <- list(a = mwText(), b = mwText(), c = mwText())
+
+ # Keep inputs
+ filteredInputs <- filterAndInitInputs(inputs, c("a", "b"))
+ expect_is(filteredInputs, "list")
+ expect_length(filteredInputs, 2)
+ expect_equal(names(filteredInputs), c("a", "b"))
+ for (i in filteredInputs) {
+ expect_is(i, "Input")
+ expect_initialized(i)
+ }
+
+ # Drop inputs
+ filteredInputs <- filterAndInitInputs(inputs, c("a", "b"), drop = TRUE)
+ expect_is(filteredInputs, "list")
+ expect_length(filteredInputs, 1)
+ expect_equal(names(filteredInputs), c("c"))
+ for (i in filteredInputs) {
+ expect_is(i, "Input")
+ expect_initialized(i)
+ }
+ })
+
+ it ("filters grouped inputs", {
+ inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
+
+ # Keep inputs
+ filteredInputs <- filterAndInitInputs(inputs, c("a", "c"))
+ expect_is(filteredInputs, "list")
+ expect_length(filteredInputs, 2)
+ expect_equal(names(filteredInputs), c("grp", "c"))
+ for (i in filteredInputs) {
+ expect_initialized(i)
+ }
+ expect_is(filteredInputs$grp$value, "list")
+ expect_length(filteredInputs$grp$value, 1)
+ expect_equal(names(filteredInputs$grp$value), "a")
+ expect_initialized(filteredInputs$grp$value$a)
+
+ # Drop inputs
+ filteredInputs <- filterAndInitInputs(inputs, c("a", "c"), drop = TRUE)
+ expect_is(filteredInputs, "list")
+ expect_length(filteredInputs, 1)
+ expect_equal(names(filteredInputs), c("grp"))
+ for (i in filteredInputs) {
+ expect_is(i, "Input")
+ expect_initialized(i)
+ }
+ expect_is(filteredInputs$grp$value, "list")
+ expect_length(filteredInputs$grp$value, 1)
+ expect_equal(names(filteredInputs$grp$value), "b")
+ expect_initialized(filteredInputs$grp$value$b)
+ })
+
+ it ("removes empty groups", {
+ inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
+ filteredInputs <- filterAndInitInputs(inputs, c("c"))
+ expect_is(filteredInputs, "list")
+ expect_length(filteredInputs, 1)
+ expect_equal(names(filteredInputs), c("c"))
+ })
+
+ it ("selects/removes a whole group", {
+ inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
+ filteredInputs <- filterAndInitInputs(inputs, c("grp"))
+ expect_is(filteredInputs, "list")
+ expect_length(filteredInputs, 1)
+ expect_equal(names(filteredInputs), c("grp"))
+ expect_is(filteredInputs$grp$value, "list")
+ expect_length(filteredInputs$grp$value, 2)
+ expect_equal(names(filteredInputs$grp$value), c("a", "b"))
+ expect_initialized(filteredInputs$grp$value$a)
+ expect_initialized(filteredInputs$grp$value$b)
+
+ filteredInputs <- filterAndInitInputs(inputs, c("grp"), TRUE)
+ expect_is(filteredInputs, "list")
+ expect_length(filteredInputs, 1)
+ expect_equal(names(filteredInputs), c("c"))
+ })
+
+ it ("updates initial value of an input", {
+ inputs <- list(a = mwText(), b = mwText(), c = mwText())
+ filteredInputs <- filterAndInitInputs(inputs, "a", newValues = list(a = "test"))
+ expect_equal(filteredInputs$a$value, "test")
+ expect_equal(filteredInputs$a$env$a, "test")
+ })
+})
+
+describe("flattenInputs", {
+ it ("flattens grouped inputs", {
+ inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
+ inputs <- filterAndInitInputs(inputs, c(), TRUE)
+ inputList <- flattenInputs(inputs)
+ expect_is(inputList, "list")
+ expect_length(inputList, 4)
+ expect_true(all(c("a", "b", "c", "grp") %in% names(inputList)))
+ for (i in inputList) expect_initialized(i)
+ })
+
+ it("returns a list that can be used to create an InputList object", {
+ inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText())
+ inputs <- filterAndInitInputs(inputs, c(), TRUE, env = initEnv(parent.frame(), 1))
+ inputList <- flattenInputs(inputs)
+ expect_silent(InputList(inputs = inputList))
+ })
+})
diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R
new file mode 100644
index 0000000..b0a8493
--- /dev/null
+++ b/tests/testthat/test-inputs.R
@@ -0,0 +1,104 @@
+context("Shiny inputs")
+
+# Slider
+test_input(mwSlider(0, 10, 0), c(5, -20, 20), c(5, 0, 10))
+# Slider with two values
+test_input(
+ mwSlider(0, 10, 0),
+ list(c(5, 7), c(-20, 20), c(-20, 5), c(5, 20)),
+ list(c(5, 7), c(0, 10), c(0, 5), c(5, 10))
+)
+
+# Text
+test_input(mwText(), list("1", 1, NULL), list("1", "1", ""))
+
+# Numeric
+test_input(mwNumeric(0), list(5, -20, 20, NULL, "a"), list(5, -20, 20, NULL, NULL))
+test_input(mwNumeric(0, min = 0, max = 10), c(5, -20, 20), c(5, 0, 10))
+
+# Password
+test_input(mwPassword(), list("1", 1, NULL), list("1", "1", ""))
+
+# Select
+test_input(mwSelect(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1))
+test_input(
+ mwSelect(1:4, multiple = TRUE),
+ list(1, 5, NULL, 3:5),
+ list(1, integer(0), integer(0), 3:4)
+)
+# Select where choices have distinct label and values
+test_input(
+ mwSelect(list(a = 1, b = 2)),
+ list(1, 2, 5, NULL),
+ list(1, 2, 1, 1)
+)
+test_input(
+ mwSelect(list(a = 1, b = 2), multiple = TRUE),
+ list(1, 2, 5, NULL, 1:3),
+ list(1, 2, integer(0), integer(0), 1:2)
+)
+
+# Checkbox
+test_input(
+ mwCheckbox(),
+ list(TRUE, FALSE, NULL, NA, "test"),
+ list(TRUE, FALSE, FALSE, FALSE, FALSE)
+)
+
+# Radio buttons
+test_input(mwRadio(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1))
+test_input(
+ mwRadio(list(a = 1, b = 2)),
+ list(1, 2, 5, NULL),
+ list(1, 2, 1, 1)
+)
+
+# Date picker
+test_input(
+ mwDate(),
+ list(Sys.Date(), "2017-01-01", NULL),
+ list(Sys.Date(), as.Date("2017-01-01"), Sys.Date())
+)
+# Date with min and max dates
+test_input(
+ mwDate(min = "2017-01-01", max = "2017-12-31"),
+ list("2017-06-01", "2016-06-01", "2018-06-01"),
+ list(as.Date("2017-06-01"), as.Date("2017-01-01"), as.Date("2017-12-31"))
+)
+
+
+# Date range
+defaultRange <- c(Sys.Date(), Sys.Date())
+test_input(
+ mwDateRange(),
+ list(defaultRange, as.character(defaultRange), NULL),
+ list(defaultRange, defaultRange, defaultRange)
+)
+# Date range with min and max dates
+test_input(
+ mwDateRange(min = "2017-01-01", max = "2017-12-31"),
+ list(c("2016-01-01", "2018-01-01")),
+ list(as.Date(c("2017-01-01", "2017-12-31")))
+)
+
+# Checkbox group
+test_input(
+ mwCheckboxGroup(1:4),
+ list(1, 5, NULL, 3:5),
+ list(1, integer(0), integer(0), 3:4)
+)
+test_input(
+ mwCheckboxGroup(list(a = 1, b = 2)),
+ list(1, 2, 5, NULL, 1:3),
+ list(1, 2, integer(0), integer(0), 1:2)
+)
+
+# Groups of input
+test_input(mwGroup(a = mwText(), b = mwText()))
+test_that("mwGroup throws an error if an argument is not named", {
+ expect_error(mwGroup(mwText()), "All arguments need to be named.")
+})
+test_that("mwGroup throws an error if an argument is not an input", {
+ expect_error(mwGroup(a = 1), "All arguments need to be Input objects.")
+})
+
diff --git a/tests/testthat/test-manipulate_widget.R b/tests/testthat/test-manipulate_widget.R
new file mode 100644
index 0000000..8e52388
--- /dev/null
+++ b/tests/testthat/test-manipulate_widget.R
@@ -0,0 +1,134 @@
+context("manipulateWidget")
+
+describe("manipulateWidget", {
+ it("returns an uninitialized MWController in a non interactive situation", {
+ c <- manipulateWidget(
+ paste(a, b),
+ a = mwSelect(c("a", "b", "c")),
+ b = mwText("test"),
+ .compare = "a", .runApp = FALSE
+ )
+ expect_true(!c$initialized)
+ })
+
+ it("creates two charts when .compare is a character vector", {
+ c <- manipulateWidget(
+ paste(a, b),
+ a = mwSelect(c("a", "b", "c")),
+ b = mwText("test"),
+ .compare = "a", .runApp = FALSE
+ )
+ c$init()
+ expect_equal(c$ncharts, 2)
+ expect_equal(c$getValue("a", 1), "a")
+ expect_equal(c$getValue("a", 2), "a")
+ })
+
+ it("creates two charts when .compare is a named list with null values", {
+ c <- manipulateWidget(
+ paste(a, b),
+ a = mwSelect(c("a", "b", "c")),
+ b = mwText("test"),
+ .compare = list(a = NULL), .runApp = FALSE
+ )
+ c$init()
+ expect_equal(c$ncharts, 2)
+ expect_equal(c$getValue("a", 1), "a")
+ expect_equal(c$getValue("a", 2), "a")
+ })
+
+ it("sets different values when .compare is a named list with non null values", {
+ c <- manipulateWidget(
+ paste(a, b),
+ a = mwSelect(c("a", "b", "c")),
+ b = mwText("test"),
+ .compare = list(a = list("a", "b")), .runApp = FALSE
+ )
+ c$init()
+ expect_equal(c$ncharts, 2)
+ expect_equal(c$getValue("a", 1), "a")
+ expect_equal(c$getValue("a", 2), "b")
+ expect_equal(c$charts[[1]]$widgets[[1]], "a test")
+ expect_equal(c$charts[[2]]$widgets[[1]], "b test")
+ })
+
+ it ("creates more than two charts", {
+ c <- manipulateWidget(
+ paste(a, b),
+ a = mwSelect(c("a", "b", "c")),
+ b = mwText("test"),
+ .compare = list(a = list("a", "b", "c")),
+ .compareOpts = compareOptions(ncharts = 3), .runApp = FALSE
+ )
+ c$init()
+ expect_equal(c$ncharts, 3)
+ expect_equal(c$getValue("a", 1), "a")
+ expect_equal(c$getValue("a", 2), "b")
+ expect_equal(c$getValue("a", 2), "b")
+ expect_equal(c$charts[[1]]$widgets[[1]], "a test")
+ expect_equal(c$charts[[2]]$widgets[[1]], "b test")
+ expect_equal(c$charts[[3]]$widgets[[1]], "c test")
+ })
+
+ it ("updates dynamic inputs", {
+ c <- manipulateWidget(
+ x + y,
+ x = mwSlider(0, 10, 5),
+ y = mwSlider(0, x, 4), .runApp = FALSE
+ )
+ c$init()
+ expect_equal(c$getParams("y")$max, 5)
+ c$setValue("x", 3)
+ expect_equal(c$getParams("y")$max, 3)
+ expect_equal(c$getValue("y"), 3)
+ })
+
+ it ("conditionally shows/hides inputs", {
+ c <- manipulateWidget(
+ x + y,
+ x = mwSlider(0, 10, 0),
+ y = mwSlider(0, 10, 0, .display = x < 5), .runApp = FALSE
+ )
+ c$init()
+ expect_true(c$isVisible("y"))
+ c$setValue("x", 6)
+ expect_true(!c$isVisible("y"))
+ })
+
+ it ("shares values between inputs and outputs", {
+ c <- manipulateWidget(
+ x2 + y,
+ x = mwSlider(0, 10, 5),
+ x2 = mwSharedValue(x * 2),
+ y = mwSlider(0, x2, 0), .runApp = FALSE
+ )
+ c$init()
+ expect_equal(c$getParams("y")$max, 10)
+ expect_equal(c$charts[[1]]$widgets[[1]], 10)
+ c$setValue("x", 8)
+ expect_equal(c$getValue("x2"), 16)
+ expect_equal(c$getParams("y")$max, 16)
+ expect_equal(c$charts[[1]]$widgets[[1]], 16)
+
+ })
+
+ it ("modifies a sharedInput when it is not dynamic", {
+ c <- manipulateWidget(
+ x2 + y,
+ x = mwSlider(0, 10, 5),
+ x2 = mwSharedValue(1),
+ x3 = mwSharedValue(x + x2),
+ y = mwSlider(0, x2, 0), .runApp = FALSE
+ )
+ c$init()
+ expect_equal(c$getParams("y")$max, 1)
+ expect_equal(c$charts[[1]]$widgets[[1]], 1)
+ c$setValue("x2", 8)
+ expect_equal(c$getValue("x2"), 8)
+ expect_equal(c$getValue("x3"), 13)
+ expect_equal(c$getParams("y")$max, 8)
+ expect_equal(c$charts[[1]]$widgets[[1]], 8)
+ c$setValue("x3", 10) # Dynamic shared input. Should not have any effect
+ expect_equal(c$getValue("x3"), 13)
+ })
+})
diff --git a/tests/testthat/test-mwModuleUI.R b/tests/testthat/test-mwModuleUI.R
new file mode 100644
index 0000000..9357f53
--- /dev/null
+++ b/tests/testthat/test-mwModuleUI.R
@@ -0,0 +1,23 @@
+context("mwModuleUI function")
+
+describe("mwModuleUI function", {
+
+ it("Correct mwModuleUI", {
+ # missing id
+ expect_error(mwModuleUI())
+
+ # default
+ def_mw_ui <- mwModuleUI(id = "def")
+ expect_is(def_mw_ui, "shiny.tag.list")
+ expect_equal(def_mw_ui[[2]]$name, "div")
+ expect_equal(def_mw_ui[[2]]$attribs$id, "def-ui")
+ expect_true(grepl("border", def_mw_ui[[2]]$attribs$class))
+
+ # parameters
+ def_mw_ui <- mwModuleUI(id = "def", border = FALSE)
+ expect_false(grepl("border", def_mw_ui[[2]]$attribs$class))
+
+ def_mw_ui <- mwModuleUI(id = "def", height = "100%")
+ expect_true(grepl("height:100%", def_mw_ui[[2]]$attribs$style))
+ })
+})
diff --git a/tests/testthat/test-mwServer.R b/tests/testthat/test-mwServer.R
deleted file mode 100644
index e9caf93..0000000
--- a/tests/testthat/test-mwServer.R
+++ /dev/null
@@ -1,103 +0,0 @@
-context("mwServer")
-
-controlsSpec <- list(x1 = mwText("value1"), x2 = mwSelect(1:3))
-expr <- expression(combineWidgets(paste(x1, x2)))
-compare <- list(x2 = list(1, 2, 3))
-
-# showHideControls #############################################################
-
-describe("showHideControls", {
- visible <- list(x1_visible = TRUE, x2_visible = TRUE)
- controlsSpec <- list(x1 = mwText("value1", .display = x2 == 1),
- x2 = mwSelect(1:3, .display = FALSE))
- controls <- preprocessControls(controlsSpec, env = parent.frame(), ncharts = 1)
-
- it("changes visibility of inputs", {
-
- with_mock(
- `shiny::updateCheckboxInput` = function(session, inputId, value) {
- visible[[inputId]] <<- value
- },
- {
- it ("Initial visibility", {
- showHideControls(controls$desc, NULL, controls$env$ind[[1]])
- expect_true(visible$x1_visible)
- expect_false(visible$x2_visible)
- })
-
- it ("visibility after input update", {
- assign("x2", 2, envir = controls$env$ind[[1]])
- showHideControls(controls$desc, NULL, controls$env$ind[[1]])
- expect_false(visible$x1_visible)
- expect_false(visible$x2_visible)
- })
- }
- )
- })
-})
-
-# updateControls ###############################################################
-
-describe("updateControls", {
- controlsSpec <- list(x1 = mwNumeric(0, min = x2), x2 = mwSelect(0:3))
- controls <- preprocessControls(controlsSpec, env = parent.frame(), ncharts = 1)
- desc <- controls$desc
- env <- controls$env$ind[[1]]
-
- with_mock(
- `manipulateWidget:::getUpdateInputFun` = function(type) {
- function(...) print(paste("update", type))
- },
- {
- it ("updates control parameters", {
- assign("x2", 1L, envir = env)
- expect_output(desc <<- updateControls(desc, NULL, env),
- "update numeric")
- expect_equal(desc$currentParams[[2]]$min, 1)
- })
- it ("does nothing if parameters are not modified", {
- expect_silent(desc <<- updateControls(desc, NULL, env))
- expect_equal(desc$currentParams[[2]]$min, 1)
- })
- }
- )
-})
-
-# onDone #######################################################################
-
-describe("onDone", {
- controls <- preprocessControls(controlsSpec, env = parent.frame(), ncharts = 1)
- controlsCompare <- preprocessControls(controlsSpec, compare, env = parent.frame(), ncharts = 3)
-
- it ("stops the shiny gadget and returns a htmlwidget", {
- with_mock(
- `shiny::stopApp` = function(x) {
- print("Stop gadget")
- x
- },
- expect_output(res <- onDone(expr, controls), "Stop gadget"),
- expect_is(res, "htmlwidget"),
- expect_equal(length(res$widgets), 1),
- expect_equal(res$widgets[[1]], "value1 1")
- )
- })
-
- it ("returns a combined widget if comparison", {
- with_mock(
- `shiny::stopApp` = function(x) {
- print("Stop gadget")
- x
- },
- {
- expr <- expression(paste(x1, x2))
- expect_output(res <- onDone(expr, controlsCompare), "Stop gadget")
- expect_is(res, "combineWidgets")
- expect_equal(length(res$widgets), 3)
- for (i in 1:3) {
- expect_equal(res$widgets[[i]], paste("value1", compare$x2[[i]]))
- }
- }
- )
- })
-
-})
diff --git a/tests/testthat/test-on_done.R b/tests/testthat/test-on_done.R
new file mode 100644
index 0000000..dbc6ad6
--- /dev/null
+++ b/tests/testthat/test-on_done.R
@@ -0,0 +1,45 @@
+context("onDone")
+
+describe("onDone", {
+ it ("stops the shiny gadget and returns a htmlwidget", {
+ with_mock(
+ `shiny::stopApp` = function(x) {
+ print("Stop gadget")
+ x
+ },
+ {
+ inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)))
+ expr <- expression(combineWidgets(paste(x1, x2)))
+ controller <- MWController(expr, inputs)$init()
+
+ expect_output(res <- onDone(controller), "Stop gadget")
+ expect_is(res, "htmlwidget")
+ expect_equal(length(res$widgets), 1)
+ expect_equal(res$widgets[[1]], "value1 1")
+ }
+ )
+ })
+
+ it ("returns a combined widget if comparison", {
+ suppressWarnings({with_mock(
+ `shiny::stopApp` = function(x) {
+ print("Stop gadget")
+ x
+ },
+ {
+ compare <- list(x2 = list(1, 2, 3))
+ inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)),
+ compare = compare, ncharts = 3)
+ expr <- expression(paste(x1, x2))
+ controller <- MWController(expr, inputs)$init()
+ expect_output(res <- onDone(controller), "Stop gadget")
+ expect_is(res, "combineWidgets")
+ expect_equal(length(res$widgets), 3)
+ for (i in 1:3) {
+ expect_equal(res$widgets[[i]]$widgets[[1]], paste("value1", compare$x2[[i]]))
+ }
+ }
+ )})
+ })
+
+})
diff --git a/tests/testthat/test-preprocessControls.R b/tests/testthat/test-preprocessControls.R
deleted file mode 100644
index e0564c0..0000000
--- a/tests/testthat/test-preprocessControls.R
+++ /dev/null
@@ -1,194 +0,0 @@
-context("preprocessControls")
-
-describe("preprocessControls", {
-
- controls <- list(
- x1 = mwText(value = "value1", label = "label1"),
- x2 = mwSelect(choices = 1:3, value = 2, label = "label2"),
- x3 = mwSelect(4:6, 1, multiple = TRUE, label = "label3")
- )
-
- controlsPrepro <- preprocessControls(controls, env = parent.frame(), ncharts = 1)
- desc <- controlsPrepro$desc
-
- describe("Controls description", {
-
- it("is a data.frame", {
- expect_is(desc, "data.frame")
- expectedColumns <- c("name", "initValue", "type", "level", "multiple",
- "params", "inputId", "mod", "env")
- expect_true(all(expectedColumns %in% names(desc)))
- })
-
- it ("reads correct values", {
- expect_equal(desc$name, c(".root", names(controls)))
- expect_equal(desc$type, c("group", "text", "select", "select"))
- expect_equal(desc$initValue, list(NULL, "value1", 2, integer()))
- expect_equal(desc$multiple, c(NA, NA, FALSE, TRUE))
- expect_equal(desc$inputId, gsub("[^a-zA-Z0-9]", "_", desc$name))
- })
- })
-
- describe("Environments", {
- it ("creates a shared environment", {
- expect_is(controlsPrepro$env$shared, "environment")
- })
-
- it ("defines shared variables in shared environment", {
- sharedEnv <- controlsPrepro$env$shared
- expect_true(exists("x1", envir = sharedEnv))
- expect_true(exists("x2", envir = sharedEnv))
- expect_true(exists("x3", envir = sharedEnv))
- expect_equal(get("x1", envir = sharedEnv), desc$initValue[[2]])
- expect_equal(get("x2", envir = sharedEnv), desc$initValue[[3]])
- expect_equal(get("x3", envir = sharedEnv), desc$initValue[[4]])
- })
-
- it ("creates an individual environment", {
- expect_equal(length(controlsPrepro$env$ind), 1)
- expect_is(controlsPrepro$env$ind[[1]], "environment")
- })
-
- it("can access shared variables from individual environment", {
- indEnv <- controlsPrepro$env$ind[[1]]
- expect_equal(get("x1", envir = indEnv), desc$initValue[[2]])
- expect_equal(get("x2", envir = indEnv), desc$initValue[[3]])
- expect_equal(get("x3", envir = indEnv), desc$initValue[[4]])
- })
- })
-
- describe("Control list", {
- sharedControls <- controlsPrepro$controls$shared
- indControls <- controlsPrepro$controls$ind
-
- it ("creates a list of shared and individual controls", {
- expect_equal(length(sharedControls), length(controls))
- expect_equal(names(sharedControls), desc$inputId[-1])
- for (ctrl in sharedControls) {
- expect_is(ctrl, "function")
- }
-
- expect_equal(length(indControls), 1)
- expect_equal(length(indControls[[1]]), 0)
- })
- })
-
- describe("Comparison", {
- x3Values <- as.list(sample(4:6, 3, replace = TRUE))
- compare <- list(x2 = NULL, x3 = x3Values)
- controlsPrepro <- preprocessControls(controls, compare, env = parent.frame(), ncharts = 3)
- desc <- controlsPrepro$desc
- envs <- controlsPrepro$env
- ctrlList <- controlsPrepro$controls
-
- it ("adds individual inputs in description", {
- expect_equal(nrow(desc), 8)
- expect_equal(desc$name, c(".root", "x1", "x2", "x3", "x2", "x3", "x2", "x3"))
- expect_equal(desc$inputId, c("_root", "x1", "x21", "x31", "x22", "x32", "x23", "x33"))
- expect_equal(desc$mod, c(0, 0, 1, 1, 2, 2, 3, 3))
- expect_equal(desc$initValue, list(NULL, "value1", 2, x3Values[[1]], 2, x3Values[[2]], 2, x3Values[[3]]))
- })
-
- it ("creates an individual environment for each module", {
- expect_equal(length(envs$ind), 3)
- for (i in 1:3) {
- expect_equal(get("x1", envir = envs$ind[[i]]), "value1")
- expect_equal(get("x3", envir = envs$ind[[i]]), x3Values[[i]])
- }
- })
-
- it ("creates a control list for each module", {
- expect_equal(names(ctrlList$shared), "x1")
- expect_equal(length(ctrlList$ind), 3)
- for (i in 1:3) {
- expect_equal(names(ctrlList$ind[[i]]), paste0(c("x2", "x3"), i))
- }
- })
-
- it("compares a group of inputs", {
- controls <- list(
- group = mwGroup(
- x1 = mwText(value = "value1", label = "label1"),
- x2 = mwSelect(choices = 1:3, value = 2, label = "label2")
- ),
- x3 = mwSelect(4:6, 1, multiple = TRUE, label = "label3")
- )
- compare <- list(group = NULL)
- controlsPrepro <- preprocessControls(controls, compare, env = parent.frame(), ncharts = 2)
- compare2 <- list(x1 = NULL, x2 = NULL)
- controlsPrepro2 <- preprocessControls(controls, compare2, env = parent.frame(), ncharts = 2)
- expect_equal(controlsPrepro, controlsPrepro2)
- })
-
- })
-
- describe("Update inputs", {
- controls <- list(
- x1 = mwText(value = "value1", label = "label1"),
- x2 = mwSelect(choices = 4:6, value = 2, label = "label2"),
- x3 = mwSelect(x2 * 1:3, 1, multiple = TRUE, label = "label3")
- )
-
- controlsPrepro <- preprocessControls(controls, env = parent.frame(), ncharts = 1)
- desc <- controlsPrepro$desc
- envs <- controlsPrepro$env
- ctrlList <- controlsPrepro$controls
-
- it ("updates params in description and control list", {
- expect_equal(desc$currentParams[[3]]$choices, c(4:6))
- expect_equal(desc$currentParams[[4]]$choices, c(4, 8, 12))
- expect_equal(attr(ctrlList$shared$x2, "params")$choices, c(4:6))
- expect_equal(attr(ctrlList$shared$x3, "params")$choices, c(4, 8, 12))
- })
-
- it ("updates initial values if required", {
- expect_equal(desc$initValue, list(NULL, "value1", 4, integer()))
- })
-
- it ("updates inputs of each module", {
- controls <- list(
- x1 = mwText(value = "value1", label = "label1"),
- x2 = mwSelect(choices = 1:3, label = "label2"),
- x3 = mwSelect(x2 * 1:3, 1, multiple = TRUE, label = "label3")
- )
- compare <- list(x2 = list(1, 2, 3), x3 = NULL)
- controlsPrepro <- preprocessControls(controls, compare, env = parent.frame(), ncharts = 3)
- desc <- controlsPrepro$desc
- envs <- controlsPrepro$env
- ctrlList <- controlsPrepro$controls
-
- for (i in 1:3) {
- expect_equal(desc$currentParams[[3 + (i-1) * 2]]$choices, c(1:3))
- expect_equal(desc$currentParams[[4 + (i-1) * 2]]$choices, 1:3 * compare$x2[[i]])
- expect_equal(attr(ctrlList$ind[[i]]$x2, "params")$choices, c(1:3))
- expect_equal(attr(ctrlList$ind[[i]]$x3, "params")$choices, 1:3 * compare$x2[[i]])
- }
- })
- })
-
- describe("scope", {
- it ("can access parent environment", {
- parent <- new.env()
- assign("test", "testValue", envir = parent)
-
- controlsPrepro <- preprocessControls(controls, env = parent, ncharts = 1)
- expect_equal(get("test", envir = controlsPrepro$env$ind[[1]]), "testValue")
- })
- })
-
- describe("special variables", {
-
- it("can access .id variable", {
- controls <- list(x = mwNumeric(0, min = .id))
- controlsPrepro <- preprocessControls(controls, env = parent.frame(), ncharts = 1)
- expect_equal(controlsPrepro$desc$currentParams[[2]]$min, 1)
- expect_equal(controlsPrepro$desc$initValue[[2]], 1)
-
- controlsPrepro <- preprocessControls(controls, compare = list(x = NULL), env = parent.frame(), ncharts = 2)
- expect_equal(controlsPrepro$desc$currentParams[[2]]$min, 1)
- expect_equal(controlsPrepro$desc$currentParams[[3]]$min, 2)
- expect_equal(controlsPrepro$desc$initValue[[2]], 1)
- expect_equal(controlsPrepro$desc$initValue[[3]], 2)
- })
- })
-})
diff --git a/tests/testthat/test-staticPlot.R b/tests/testthat/test-staticPlot.R
new file mode 100644
index 0000000..efa3661
--- /dev/null
+++ b/tests/testthat/test-staticPlot.R
@@ -0,0 +1,25 @@
+context("Static plot & image")
+
+describe("Static plot & image", {
+ it("returns a combineWidget with both static plot and image", {
+
+ tmp_png <- tempfile(fileext = ".png")
+ png(file = tmp_png, bg = "transparent")
+ plot(1:10)
+ dev.off()
+
+ c <- combineWidgets(
+ staticPlot(hist(iris$Sepal.Length, breaks = 20), height = 300),
+ staticImage(tmp_png)
+ )
+
+ expect_is(c, "combineWidgets")
+ expect_length(c$widgets, 2)
+
+ # # check saveWidget and so preRenderCombinedWidgets
+ # tmp_html <- tempfile(fileext = ".html")
+ # htmlwidgets::saveWidget(c, tmp_html)
+ # expect_true(file.exists(tmp_html))
+
+ })
+})