From ed872dac272d71781e3603f78c8c9d320310fc81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Thu, 13 Jul 2017 17:24:53 +0200 Subject: [PATCH 001/101] draft of classes Input and InputList --- R/input.R | 139 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 139 insertions(+) create mode 100644 R/input.R diff --git a/R/input.R b/R/input.R new file mode 100644 index 0000000..df7574e --- /dev/null +++ b/R/input.R @@ -0,0 +1,139 @@ + +Input <- setRefClass( + "Input", + fields = c("type", "name", "idFunc", "label", "value", "display", "params", "env", + "validFunc", "htmlFunc", "htmlUpdateFunc", + "lastParams", "changedParams", "valueHasChanged"), + + methods = list( + init = function() { + valueHasChanged <<- FALSE + changedParams <<- list() + if (emptyField(label) || is.null(label)) label <<- name + assign(name, value, envir = env) + lastParams <<- evalParams(params, env) + }, + + getID = function() { + idFunc(get(".output", envir = env), name) + }, + + setValue = function(newValue) { + if (!emptyField(validFunc)) value <<- validFunc(newValue, getParams()) + assign(name, value, envir = env) + value + }, + + updateValue = function() { + oldValue <- value + if (!emptyField(validFunc)) value <<- validFunc(value, getParams()) + if (oldValue != value) { + valueHasChanged <<- TRUE + assign(name, value, envir = env) + } + value + }, + + getParams = function() { + oldParams <- lastParams + lastParams <<- evalParams(params, env) + + if(emptyField(changedParams)) changedParams <<- list() + for (n in names(lastParams)) { + if (lastParams[[n]] != oldParams[[n]]) changedParams[[n]] <<- lastParams[[n]] + } + + lastParams + }, + + getHTML = function() { + if (emptyField(htmlFunc)) return(NULL) + else htmlFunc(getID(), label, value, lastParams) + }, + + updateHTML = function(session) { + if (emptyField(htmlFunc)) return() + if (valueHasChanged || length(changedParams) > 0) { + htmlFunc(session, getID(), label, value, lastParams) + valueHasChanged <<- FALSE + changedParams <<- list() + } + } + ) +) + +mwNumeric2 <- function(min, max, value, label = NULL, ..., .display = TRUE) { + params <- prepareParams(min = min, max = max, value = value, label = label, ...) + Input( + type = "numeric", + idFunc = function(oid, name) paste(oid, name, sep = "_"), + value = value, + params = params + ) +} + +env <- new.env() +assign(".output", "output1", env) + +a = Input( + type = "numeric", + name = "x", + idFunc = function(oid, name) paste(oid, name, sep = "_"), + label = "x", + value = 5, + params = list(max = expression(10), min = expression(0)), + validFunc = function(x, params) { + min(max(params$min, x), params$max) + }, + env = env +) +a$init() + +b = Input( + type = "numeric", + name = "y", + idFunc = function(oid, name) paste(oid, name, sep = "_"), + value = 1, + params = list(max = expression(x), min = expression(0)), + validFunc = function(x, params) { + min(max(params$min, x), params$max) + }, + env = env +) +b$init() + +InputList <- setRefClass( + "InputList", + fields = c("inputs", "ids", "shiny"), + methods = list( + initialize = function(..., shinyMode = TRUE) { + inputs <<- list(...) + names(inputs) <<- sapply(inputs, function(x) {x$getID()}) + shiny <<- shinyMode + }, + + setValue = function(inputId, newVal) { + inputs[[inputId]]$setValue(newVal) + update() + }, + + update = function(session = NULL) { + n <- 0 + while(TRUE) { + n <- n + 1 + valueHasChanged <- sapply(inputs, function(x) { + x$value != x$updateValue() + }) + if (all(!valueHasChanged) | n > 10) break + } + + if (!is.null(session)) { + for (input in inputs) input$updateHTML(session) + } + } + ) +) + +myInputs <- InputList(a, b) + +emptyField <- function(x) inherits(x, "uninitializedField") From 9d599350d9bc1b6e5c2587ee48f13122908414fa Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 10:48:36 +0200 Subject: [PATCH 002/101] Improve classes Input and InputList --- R/input.R | 139 ---------------------------- R/input_class.R | 98 ++++++++++++++++++++ R/input_list_class.R | 42 +++++++++ tests/testthat/helper-input_class.R | 25 +++++ tests/testthat/test-input_class.R | 44 +++++++++ 5 files changed, 209 insertions(+), 139 deletions(-) delete mode 100644 R/input.R create mode 100644 R/input_class.R create mode 100644 R/input_list_class.R create mode 100644 tests/testthat/helper-input_class.R create mode 100644 tests/testthat/test-input_class.R diff --git a/R/input.R b/R/input.R deleted file mode 100644 index df7574e..0000000 --- a/R/input.R +++ /dev/null @@ -1,139 +0,0 @@ - -Input <- setRefClass( - "Input", - fields = c("type", "name", "idFunc", "label", "value", "display", "params", "env", - "validFunc", "htmlFunc", "htmlUpdateFunc", - "lastParams", "changedParams", "valueHasChanged"), - - methods = list( - init = function() { - valueHasChanged <<- FALSE - changedParams <<- list() - if (emptyField(label) || is.null(label)) label <<- name - assign(name, value, envir = env) - lastParams <<- evalParams(params, env) - }, - - getID = function() { - idFunc(get(".output", envir = env), name) - }, - - setValue = function(newValue) { - if (!emptyField(validFunc)) value <<- validFunc(newValue, getParams()) - assign(name, value, envir = env) - value - }, - - updateValue = function() { - oldValue <- value - if (!emptyField(validFunc)) value <<- validFunc(value, getParams()) - if (oldValue != value) { - valueHasChanged <<- TRUE - assign(name, value, envir = env) - } - value - }, - - getParams = function() { - oldParams <- lastParams - lastParams <<- evalParams(params, env) - - if(emptyField(changedParams)) changedParams <<- list() - for (n in names(lastParams)) { - if (lastParams[[n]] != oldParams[[n]]) changedParams[[n]] <<- lastParams[[n]] - } - - lastParams - }, - - getHTML = function() { - if (emptyField(htmlFunc)) return(NULL) - else htmlFunc(getID(), label, value, lastParams) - }, - - updateHTML = function(session) { - if (emptyField(htmlFunc)) return() - if (valueHasChanged || length(changedParams) > 0) { - htmlFunc(session, getID(), label, value, lastParams) - valueHasChanged <<- FALSE - changedParams <<- list() - } - } - ) -) - -mwNumeric2 <- function(min, max, value, label = NULL, ..., .display = TRUE) { - params <- prepareParams(min = min, max = max, value = value, label = label, ...) - Input( - type = "numeric", - idFunc = function(oid, name) paste(oid, name, sep = "_"), - value = value, - params = params - ) -} - -env <- new.env() -assign(".output", "output1", env) - -a = Input( - type = "numeric", - name = "x", - idFunc = function(oid, name) paste(oid, name, sep = "_"), - label = "x", - value = 5, - params = list(max = expression(10), min = expression(0)), - validFunc = function(x, params) { - min(max(params$min, x), params$max) - }, - env = env -) -a$init() - -b = Input( - type = "numeric", - name = "y", - idFunc = function(oid, name) paste(oid, name, sep = "_"), - value = 1, - params = list(max = expression(x), min = expression(0)), - validFunc = function(x, params) { - min(max(params$min, x), params$max) - }, - env = env -) -b$init() - -InputList <- setRefClass( - "InputList", - fields = c("inputs", "ids", "shiny"), - methods = list( - initialize = function(..., shinyMode = TRUE) { - inputs <<- list(...) - names(inputs) <<- sapply(inputs, function(x) {x$getID()}) - shiny <<- shinyMode - }, - - setValue = function(inputId, newVal) { - inputs[[inputId]]$setValue(newVal) - update() - }, - - update = function(session = NULL) { - n <- 0 - while(TRUE) { - n <- n + 1 - valueHasChanged <- sapply(inputs, function(x) { - x$value != x$updateValue() - }) - if (all(!valueHasChanged) | n > 10) break - } - - if (!is.null(session)) { - for (input in inputs) input$updateHTML(session) - } - } - ) -) - -myInputs <- InputList(a, b) - -emptyField <- function(x) inherits(x, "uninitializedField") diff --git a/R/input_class.R b/R/input_class.R new file mode 100644 index 0000000..d6bb974 --- /dev/null +++ b/R/input_class.R @@ -0,0 +1,98 @@ +emptyField <- function(x) inherits(x, "uninitializedField") + +# 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"), + + methods = list( + init = function(name, env) { + "Set environment and default values" + name <<- name + env <<- env + valueHasChanged <<- FALSE + changedParams <<- list() + if (emptyField(label) || is.null(label)) label <<- name + if (emptyField(idFunc)) { + idFunc <<- function(oid, name) paste(oid, name, sep = "_") + } + assign(name, value, envir = env) + 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) { + "Modify value of the input. If newValue is invalid, it sets a valid value" + if (!emptyField(validFunc)) value <<- validFunc(newValue, getParams()) + assign(name, value, envir = env) + value + }, + + updateValue = function() { + "Update value after a change in environment" + oldValue <- value + if (!emptyField(validFunc)) value <<- validFunc(value, getParams()) + if (!isTRUE(all.equal(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]]) && lastParams[[n]] != oldParams[[n]]) { + changedParams[[n]] <<- lastParams[[n]] + } + } + + lastParams + }, + + getHTML = function() { + "Get the input HTML" + if (emptyField(htmlFunc)) return(NULL) + + id <- getID() + shiny::conditionalPanel( + condition = sprintf("input.%s_visible", id), + tags$div( + style="display:none;", + shiny::checkboxInput(paste0(id, "_visible"), "", value = TRUE) + ), + htmlFunc(getID(), label, value, lastParams) + ) + }, + + updateHTML = function(session) { + "Update the input HTML." + if (emptyField(htmlFunc)) return() + if (valueHasChanged || length(changedParams) > 0) { + htmlFunc(session, getID(), label, value, lastParams) + 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..a0fd964 --- /dev/null +++ b/R/input_list_class.R @@ -0,0 +1,42 @@ +# 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", "shiny"), + methods = list( + initialize = function(inputs, session = NULL) { + "args: + - inputs: list of initialized inputs + - session: shiny session" + inputs <<- inputs + names(inputs) <<- sapply(inputs, function(x) {x$getID()}) + session <<- session + }, + + setValue = function(inputId, newVal) { + "Change the value of an input and update the other inputs + args: + - inputId: id of the input to update + - newVal: new value for the input" + inputs[[inputId]]$setValue(newVal) + update() + }, + + update = function() { + "Update all inputs" + n <- 0 + while(TRUE) { + n <- n + 1 + valueHasChanged <- sapply(inputs, function(x) { + #if (x$type == "group") return(FALSE) + !isTRUE(all.equal(x$value, x$updateValue())) + }) + if (all(!valueHasChanged) | n > 10) break + } + + if (!is.null(session)) { + for (input in inputs) input$updateHTML(session) + } + } + ) +) diff --git a/tests/testthat/helper-input_class.R b/tests/testthat/helper-input_class.R new file mode 100644 index 0000000..03c3865 --- /dev/null +++ b/tests/testthat/helper-input_class.R @@ -0,0 +1,25 @@ +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_equal(input$env, env) + expect_equal(input$label, name) + expect_equal(input$value, get(name, envir = env)) + expect_is(input$params, "list") + for (p in input$params) { + expect_is(p, "expression") + } + expect_is(input$display, "expression") + }) + + 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]]) + } + }) + }) +} 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") + }) + +}) From 777ec6148017f9af01a6d98ea217bbb52ccb9546 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 14:18:25 +0200 Subject: [PATCH 003/101] Reimplemtation of shiny inputs --- R/{controls.R => inputs.R} | 1010 ++++++++++++++------------- tests/testthat/helper-input_class.R | 4 - tests/testthat/test-inputs.R | 74 ++ 3 files changed, 615 insertions(+), 473 deletions(-) rename R/{controls.R => inputs.R} (64%) create mode 100644 tests/testthat/test-inputs.R diff --git a/R/controls.R b/R/inputs.R similarity index 64% rename from R/controls.R rename to R/inputs.R index 411947c..18757b1 100644 --- a/R/controls.R +++ b/R/inputs.R @@ -1,469 +1,541 @@ -#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 -} +htmlFuncFactory <- function(func, valueArgName = "value") { + function(id, label, value, params) { + params$inputId <- id + params$label <- label + params[[valueArgName]] <- value + do.call(func, 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 <- lapply(lazyeval::lazy_dots(...,.follow_symbols = FALSE), function(x) x$expr) + params$min <- lazyeval::expr_find(min) + params$max <- lazyeval::expr_find(max) + + Input( + type = "slider", value = value, label = label, params = params, + display = lazyeval::expr_find(.display), + validFunc = function(x, params) { + pmin(pmax(params$min, x), params$max) + }, + htmlFunc = htmlFuncFactory(function(...) { + tags$div(style = "padding:0 5px;", shiny::sliderInput(...)) + }) + ) +} + +#' 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 <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + Input( + type = "text", value = value, label = label, params = params, + display = lazyeval::expr_find(.display), + validFunc = function(x, params) { + if(length(x) == 0) return("") + as.character(x)[1] + }, + htmlFunc = htmlFuncFactory(shiny::textInput) + ) +} + +#' 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 <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + Input( + type = "numeric", value = value, label = label, params = params, + display = lazyeval::expr_find(.display), + validFunc = function(x, params) { + min(max(params$min, x), params$max) + }, + htmlFunc = htmlFuncFactory(shiny::numericInput) + ) +} + +#' 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 <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + Input( + type = "password", value = value, label = label, params = params, + display = lazyeval::expr_find(.display), + validFunc = function(x, params) { + if(length(x) == 0) return("") + as.character(x)[1] + }, + htmlFunc = htmlFuncFactory(shiny::passwordInput) + ) +} + +#' 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 <- lapply(lazyeval::lazy_dots(...), + function(x) x$expr) + params$choices <- lazyeval::expr_find(choices) + params$multiple <- lazyeval::expr_find(multiple) + + Input( + type = "select", value = value, label = label, params = params, + display = lazyeval::expr_find(.display), + validFunc = function(x, params) { + if (params$multiple) return(intersect(x, params$choices)) + if (length(x) > 1 && x %in% choices) return(x[1]) + else return(choices[1]) + }, + htmlFunc = htmlFuncFactory(shiny::selectInput, "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 <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + Input( + type = "checkbox", value = value, label = label, params = params, + display = lazyeval::expr_find(.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) + ) +} + +#' 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 <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + params$choices <- lazyeval::expr_find(choices) + Input( + type = "radio", value = value, label = label, params = params, + display = lazyeval::expr_find(.display), + validFunc = function(x, params) { + if (length(params$choices) == 0) return(NULL) + if (is.null(x) || !x %in% params$choices) return(params$choices[[1]]) + x + }, + htmlFunc = htmlFuncFactory(shiny::radioButtons, valueArgName = "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 <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + Input( + type = "date", value = value, label = label, params = params, + display = lazyeval::expr_find(.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) + ) +} + +#' 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) { + params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + Input( + type = "dateRange", value = value, label = label, params = params, + display = lazyeval::expr_find(.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) + if (!is.null(params$min)) params$min <- as.Date(params$min) + if (!is.null(params$max)) params$max <- as.Date(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) { + params$inputId <- id + params$label <- label + params$start <- value[[1]] + params$end <- value[[2]] + do.call(func, 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 <- lapply(lazyeval::lazy_dots(...), + function(x) x$expr) + params$choices <- lazyeval::expr_find(choices) + + Input( + type = "checkboxGroup", value = value, label = label, params = params, + display = lazyeval::expr_find(.display), + validFunc = function(x, params) { + intersect(x, params$choices) + }, + htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected") + ) + + 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) { + inputs <- list(...) + Input( + type = "group", + value = list(...), + idFunc = idFunc, + display = lazyeval::expr_find(.display), + htmlFunc = function(id, label, value, params) { + htmlElements <- lapply(value, function(x) x$getHTML()) + + 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), + tagList(htmlElements) + ) + ) + } + ) +} diff --git a/tests/testthat/helper-input_class.R b/tests/testthat/helper-input_class.R index 03c3865..90a1619 100644 --- a/tests/testthat/helper-input_class.R +++ b/tests/testthat/helper-input_class.R @@ -8,10 +8,6 @@ test_input <- function(input, values = NULL, expectedValues = NULL, name = "myIn expect_equal(input$label, name) expect_equal(input$value, get(name, envir = env)) expect_is(input$params, "list") - for (p in input$params) { - expect_is(p, "expression") - } - expect_is(input$display, "expression") }) it ("sets valid values", { diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R new file mode 100644 index 0000000..8f84868 --- /dev/null +++ b/tests/testthat/test-inputs.R @@ -0,0 +1,74 @@ +context("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), c(5, -20, 20), c(5, -20, 20)) +test_input(mwNumeric(0, min = 0, max = 10), c(5, -20, 20), c(5, 0, 10)) + +# Password +test_input(mwText(), list("1", 1, NULL), list("1", "1", "")) + +# Select +test_input(mwSelect(1:4), list(1, 5, NULL), list(1, 1, 1)) +test_input( + mwSelect(1:4, multiple = TRUE), + list(1, 5, NULL, 3:5), + list(1, integer(0), integer(0), 3:4) +) + +# 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, 5, NULL), list(1, 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) +) + From f4fc23779cbae3c5c5a65a8980ab3b859e98c4e1 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 15:05:04 +0200 Subject: [PATCH 004/101] Add input utils functions --- R/input_utils.R | 51 +++++++++++++++++ R/inputs.R | 11 +--- tests/testthat/helper-input_class.R | 6 ++ tests/testthat/test-input_utils.R | 86 +++++++++++++++++++++++++++++ tests/testthat/test-inputs.R | 3 + 5 files changed, 147 insertions(+), 10 deletions(-) create mode 100644 R/input_utils.R create mode 100644 tests/testthat/test-input_utils.R diff --git a/R/input_utils.R b/R/input_utils.R new file mode 100644 index 0000000..addb059 --- /dev/null +++ b/R/input_utils.R @@ -0,0 +1,51 @@ +#' 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()) { + res <- list() + for (n in names(inputs)) { + i <- inputs[[n]]$copy() + if (inputs[[n]]$type == "group") { + 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/inputs.R b/R/inputs.R index 18757b1..275ed5e 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -467,13 +467,6 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = }, htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected") ) - - mwControlFactory( - "checkboxGroup", shiny::checkboxGroupInput, - prepareParams(choices = choices, value = value, label = label, ...), - valueVar = "selected", - .display = .display - ) } #' Group inputs in a collapsible box @@ -507,9 +500,7 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = mwGroup <- function(..., .display = TRUE) { inputs <- list(...) Input( - type = "group", - value = list(...), - idFunc = idFunc, + type = "group", value = list(...), params = list(), display = lazyeval::expr_find(.display), htmlFunc = function(id, label, value, params) { htmlElements <- lapply(value, function(x) x$getHTML()) diff --git a/tests/testthat/helper-input_class.R b/tests/testthat/helper-input_class.R index 90a1619..b9a12c2 100644 --- a/tests/testthat/helper-input_class.R +++ b/tests/testthat/helper-input_class.R @@ -4,6 +4,7 @@ test_input <- function(input, values = NULL, expectedValues = NULL, name = "myIn env <- initEnv(parent.frame(), 1) input$init(name, env) + expect_initialized(input) expect_equal(input$env, env) expect_equal(input$label, name) expect_equal(input$value, get(name, envir = env)) @@ -19,3 +20,8 @@ test_input <- function(input, values = NULL, expectedValues = NULL, name = "myIn }) }) } + +expect_initialized <- function(input) { + expect_is(input, "Input") + expect(!emptyField(input$name) & !emptyField(input$env), "Input unitialized") +} diff --git a/tests/testthat/test-input_utils.R b/tests/testthat/test-input_utils.R new file mode 100644 index 0000000..781349a --- /dev/null +++ b/tests/testthat/test-input_utils.R @@ -0,0 +1,86 @@ +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 ("can filter 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")) + }) +}) + +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 index 8f84868..c933967 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -72,3 +72,6 @@ test_input( list(1, integer(0), integer(0), 3:4) ) +# Groups of input +test_input(mwGroup(a = mwText(), b = mwText())) + From 44ccf23700ba633011ecd8b53a87ca80c1fe18ca Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 15:16:10 +0200 Subject: [PATCH 005/101] mwGroup sends a comprehensive error message if invalid parameters --- R/inputs.R | 3 +++ tests/testthat/test-inputs.R | 6 ++++++ 2 files changed, 9 insertions(+) diff --git a/R/inputs.R b/R/inputs.R index 275ed5e..ff0bad7 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -499,6 +499,9 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = #' @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 = lazyeval::expr_find(.display), diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R index c933967..f4faeec 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -74,4 +74,10 @@ test_input( # 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.") +}) From c4982a4e4ad62bb71204d5270cc4852ce154cdde Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 15:29:30 +0200 Subject: [PATCH 006/101] Basic tests for InputList class --- R/input_list_class.R | 3 ++- R/inputs.R | 11 +++++++++++ tests/testthat/test-input_list_class.R | 14 ++++++++++++++ 3 files changed, 27 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/test-input_list_class.R diff --git a/R/input_list_class.R b/R/input_list_class.R index a0fd964..b6d28eb 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -2,7 +2,7 @@ # when the value of an input changes. InputList <- setRefClass( "InputList", - fields = c("inputs", "shiny"), + fields = c("inputs", "session"), methods = list( initialize = function(inputs, session = NULL) { "args: @@ -11,6 +11,7 @@ InputList <- setRefClass( inputs <<- inputs names(inputs) <<- sapply(inputs, function(x) {x$getID()}) session <<- session + update() }, setValue = function(inputId, newVal) { diff --git a/R/inputs.R b/R/inputs.R index ff0bad7..ff3e818 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -1,3 +1,14 @@ +#' 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) { params$inputId <- id diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R new file mode 100644 index 0000000..f5c4cb2 --- /dev/null +++ b/tests/testthat/test-input_list_class.R @@ -0,0 +1,14 @@ +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) + + expect_equal(inputList$inputs$output_1_y$value, 5) + + inputList$setValue("output_1_x", 7) + expect_equal(inputList$inputs$output_1_y$value, 7) + }) +}) From b07dc552e5870525dc0cfd8af39f9ea932f254f6 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 16:28:47 +0200 Subject: [PATCH 007/101] New private function initInputs --- R/init_inputs.R | 60 +++++++++++++++++++++++++++++ R/input_list_class.R | 5 ++- tests/testthat/test-init_inputs.R | 63 +++++++++++++++++++++++++++++++ 3 files changed, 126 insertions(+), 2 deletions(-) create mode 100644 R/init_inputs.R create mode 100644 tests/testthat/test-init_inputs.R diff --git a/R/init_inputs.R b/R/init_inputs.R new file mode 100644 index 0000000..586b6bc --- /dev/null +++ b/R/init_inputs.R @@ -0,0 +1,60 @@ +#' 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 + 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. +#' @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, 1) + indEnvs <- lapply(seq_len(ncharts), function(i) initEnv(sharedEnv, i)) + + sharedInputs <- filterAndInitInputs(inputs, compare, drop = TRUE, sharedEnv) + indInputs <- lapply(seq_len(ncharts), function(i) { + filterAndInitInputs(inputs, compare, env = indEnvs[[i]]) + }) + + inputList <- InputList(list(sharedInputs, indInputs)) + + list( + envs = list( + shared = sharedEnv, + ind = indEnvs + ), + inputs = list( + shared = sharedInputs, + ind = indInputs + ), + inputList = inputList + ) +} diff --git a/R/input_list_class.R b/R/input_list_class.R index b6d28eb..8ec4ab0 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -8,8 +8,9 @@ InputList <- setRefClass( "args: - inputs: list of initialized inputs - session: shiny session" - inputs <<- inputs - names(inputs) <<- sapply(inputs, function(x) {x$getID()}) + inputList <- flattenInputs(inputs) + inputs <<- inputList + names(inputs) <<- sapply(inputList, function(x) {x$getID()}) session <<- session update() }, diff --git a/tests/testthat/test-init_inputs.R b/tests/testthat/test-init_inputs.R new file mode 100644 index 0000000..ee79da5 --- /dev/null +++ b/tests/testthat/test-init_inputs.R @@ -0,0 +1,63 @@ +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")) + 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) + expect_length(res$inputList$inputs, expectedLength) + + expected_names <- paste0("output_1_", names(inputList)) + if (length(compare) > 0) { + for (i in seq_len(ncharts - 1)) { + expected_names <- append( + expected_names, + paste0("output_", i+1, "_", 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 = "a") + }) + + 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.") + }) +}) From 7650dce525b6319a9db602765df6f14de619c180 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 16:54:27 +0200 Subject: [PATCH 008/101] filterAndInitInputs can now filter/select a whole group of inputs --- R/input_utils.R | 17 +++++++++++++++-- tests/testthat/test-input_utils.R | 18 ++++++++++++++++++ 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/R/input_utils.R b/R/input_utils.R index addb059..4206272 100644 --- a/R/input_utils.R +++ b/R/input_utils.R @@ -12,8 +12,21 @@ filterAndInitInputs <- function(inputs, names, drop = FALSE, env = parent.frame( for (n in names(inputs)) { i <- inputs[[n]]$copy() if (inputs[[n]]$type == "group") { - i$value <- filterAndInitInputs(inputs[[n]]$value, names, drop, env) - if (length(i$value) == 0) next + 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 diff --git a/tests/testthat/test-input_utils.R b/tests/testthat/test-input_utils.R index 781349a..29d8d36 100644 --- a/tests/testthat/test-input_utils.R +++ b/tests/testthat/test-input_utils.R @@ -64,6 +64,24 @@ describe("filterAndInitInputs", { expect_length(filteredInputs, 1) expect_equal(names(filteredInputs), c("c")) }) + + it ("can select/remove 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")) + }) }) describe("flattenInputs", { From 83ab64b5c92a4ac53c38477ee379f21b58ce9401 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 16:59:48 +0200 Subject: [PATCH 009/101] ID of shared inputs is prefixed by "shared_" (before it was "output_1_") --- R/init_inputs.R | 5 +++-- tests/testthat/test-init_inputs.R | 8 +++++--- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/R/init_inputs.R b/R/init_inputs.R index 586b6bc..fc111e3 100644 --- a/R/init_inputs.R +++ b/R/init_inputs.R @@ -11,7 +11,8 @@ initEnv <- function(parentEnv, id) { res$.initial <- TRUE res$.session <- NULL res$.id <- id - res$.output <- paste0("output_", id) + if (id == 0) res$.output <- "shared" + else res$.output <- paste0("output_", id) res } @@ -36,7 +37,7 @@ 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, 1) + sharedEnv <- initEnv(env, 0) indEnvs <- lapply(seq_len(ncharts), function(i) initEnv(sharedEnv, i)) sharedInputs <- filterAndInitInputs(inputs, compare, drop = TRUE, sharedEnv) diff --git a/tests/testthat/test-init_inputs.R b/tests/testthat/test-init_inputs.R index ee79da5..cbd6d30 100644 --- a/tests/testthat/test-init_inputs.R +++ b/tests/testthat/test-init_inputs.R @@ -22,14 +22,16 @@ test_structure <- function(inputs, compare = NULL, ncharts = 1) { 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) - expected_names <- paste0("output_1_", names(inputList)) + sharedInputs <- setdiff(names(inputList), compare) + expected_names <- paste0("shared_", sharedInputs) if (length(compare) > 0) { - for (i in seq_len(ncharts - 1)) { + for (i in seq_len(ncharts)) { expected_names <- append( expected_names, - paste0("output_", i+1, "_", compare) + paste0("output_", i, "_", compare) ) } } From e3d05841c9e430550e7b0ef68cf8a1fddbe51274 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 17:10:41 +0200 Subject: [PATCH 010/101] initInputs() now also returns the number of charts --- R/init_inputs.R | 4 +++- tests/testthat/test-init_inputs.R | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/R/init_inputs.R b/R/init_inputs.R index fc111e3..992cbeb 100644 --- a/R/init_inputs.R +++ b/R/init_inputs.R @@ -32,6 +32,7 @@ initEnv <- function(parentEnv, id) { #' -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.") @@ -56,6 +57,7 @@ initInputs <- function(inputs, env = parent.frame(), compare = NULL, ncharts = 1 shared = sharedInputs, ind = indInputs ), - inputList = inputList + inputList = inputList, + ncharts = ncharts ) } diff --git a/tests/testthat/test-init_inputs.R b/tests/testthat/test-init_inputs.R index cbd6d30..f7c5687 100644 --- a/tests/testthat/test-init_inputs.R +++ b/tests/testthat/test-init_inputs.R @@ -9,7 +9,7 @@ test_structure <- function(inputs, compare = NULL, ncharts = 1) { inputList <- flattenInputs(inputList) expect_is(res, "list") - expect_named(res, c("envs", "inputs", "inputList")) + 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") From 0bee1842d9759c074fcdb1f275a298d77c927996 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 17:23:58 +0200 Subject: [PATCH 011/101] Modify mwUI() to work with the object returned by initInputs() --- R/mwUI.R | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/R/mwUI.R b/R/mwUI.R index 0145b95..dffded9 100644 --- a/R/mwUI.R +++ b/R/mwUI.R @@ -1,6 +1,6 @@ #' Private function that generates the general layout of the application #' -#' @param controls Object returned by preprocessControls +#' @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 @@ -11,8 +11,8 @@ #' @return shiny tags #' #' @noRd -mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, - okBtn = TRUE, updateBtn = FALSE, areaBtns = TRUE, border = FALSE) { +mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, + okBtn = TRUE, updateBtn = FALSE, areaBtns = TRUE, border = FALSE) { htmldep <- htmltools::htmlDependency( "manipulateWidget", @@ -22,7 +22,7 @@ mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, style = "manipulate_widget.css" ) - showSettings <- controls$nmod == 1 || length(controls$controls$shared) > 0 + showSettings <- inputs$ncharts == 1 || length(inputs$inputs$shared) > 0 if (border) class <- "mw-container with-border" else class <- "mw-container" @@ -31,9 +31,9 @@ mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, 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) + .uiMenu(inputs$ncharts, nrow, ncol, showSettings, okBtn, updateBtn, areaBtns), + .uiInputs(inputs), + .uiChartarea(inputs$ncharts, nrow, ncol, outputFun) ) ) ) @@ -41,15 +41,16 @@ mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, htmltools::attachDependencies(container, htmldep, TRUE) } -.uiControls <- function(controls) { - controls <- c(list(controls$controls$shared), controls$controls$ind) - controls <- unname(lapply(controls, function(x) { +.uiInputs <- function(inputs) { + inputs <- c(list(inputs$inputs$shared), inputs$inputs$ind) + inputs <- unname(lapply(inputs, function(x) { if (length(x) == 0) return(NULL) - tags$div(class = "mw-inputs", mwControlsUI(x)) + content <- lapply(x, function(i) i$getHTML()) + tags$div(class = "mw-inputs", shiny::tagList(content)) })) - controls$class <- "mw-input-container" - do.call(tags$div, controls) + inputs$class <- "mw-input-container" + do.call(tags$div, inputs) } .uiChartarea <- function(ncharts, nrow, ncol, outputFun) { From f192a77897b1f0ecb20dfcbff7c0676b91f4b36d Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 26 Jul 2017 17:29:34 +0200 Subject: [PATCH 012/101] Remove the now useless files --- R/controlsUtils.R | 119 ----------- R/input_class.R | 6 + R/mwUI_controls.R | 86 -------- R/preprocessControls.R | 250 ----------------------- tests/testthat/test-preprocessControls.R | 194 ------------------ 5 files changed, 6 insertions(+), 649 deletions(-) delete mode 100644 R/controlsUtils.R delete mode 100644 R/mwUI_controls.R delete mode 100644 R/preprocessControls.R delete mode 100644 tests/testthat/test-preprocessControls.R 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/input_class.R b/R/input_class.R index d6bb974..24ecad1 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -1,5 +1,11 @@ emptyField <- function(x) inherits(x, "uninitializedField") +evalParams <- function(params, env) { + lapply(params, function(x) { + tryCatch(eval(x, envir = env), silent = TRUE, error = function(e) {NULL}) + }) +} + # Private reference class representing an input. Input <- setRefClass( "Input", 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/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/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) - }) - }) -}) From 7c9e48d0698ac10af4744be66779096e9a5e57a9 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Thu, 27 Jul 2017 09:10:28 +0200 Subject: [PATCH 013/101] InputList class has now methods to get/set inputs by name and chartId --- R/input_list_class.R | 29 ++++++++++++++---- tests/testthat/test-input_list_class.R | 41 +++++++++++++++++++++++++- 2 files changed, 64 insertions(+), 6 deletions(-) diff --git a/R/input_list_class.R b/R/input_list_class.R index 8ec4ab0..93e734a 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -2,26 +2,45 @@ # when the value of an input changes. InputList <- setRefClass( "InputList", - fields = c("inputs", "session"), + fields = c("inputs", "session", "names", "chartIds"), methods = list( initialize = function(inputs, session = NULL) { "args: - inputs: list of initialized inputs - session: shiny session" - inputList <- flattenInputs(inputs) + 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 update() }, - setValue = function(inputId, newVal) { + getInput = function(name, chartId = 1) { + idx <- which(names == name & chartIds %in% c(0, chartId)) + if (length(idx) == 0) stop("cannot find input ", name) + inputs[[idx]] + }, + + getValue = function(name, chartId = 1) { + getInput(name, chartId)$value + }, + + setValue = function(name, value, chartId = 1) { + res <- getInput(name, chartId)$setValue(value) + update() + res + }, + + setValueById = function(inputId, value) { "Change the value of an input and update the other inputs args: - inputId: id of the input to update - - newVal: new value for the input" - inputs[[inputId]]$setValue(newVal) + - value: new value for the input" + res <- inputs[[inputId]]$setValue(value) update() + res }, update = function() { diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R index f5c4cb2..341667d 100644 --- a/tests/testthat/test-input_list_class.R +++ b/tests/testthat/test-input_list_class.R @@ -8,7 +8,46 @@ describe("InputList", { expect_equal(inputList$inputs$output_1_y$value, 5) - inputList$setValue("output_1_x", 7) + inputList$setValueById("output_1_x", 7) expect_equal(inputList$inputs$output_1_y$value, 7) }) + + it ("gets and updates an input by name and chartId", { + 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) + # 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") + }) }) From 71e89446aebdc8b4c82d4459c3935be2761a445f Mon Sep 17 00:00:00 2001 From: cuche27 Date: Thu, 27 Jul 2017 10:37:25 +0200 Subject: [PATCH 014/101] Add more helper methods in InputList class --- R/input_list_class.R | 18 +++++++++++++ tests/testthat/test-input_list_class.R | 36 +++++++++++++++++++------- 2 files changed, 45 insertions(+), 9 deletions(-) diff --git a/R/input_list_class.R b/R/input_list_class.R index 93e734a..fe480f3 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -17,6 +17,17 @@ InputList <- setRefClass( update() }, + 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) { + i <- getInput(name, chartId) + eval(i$display, envir = i$env) + }, + getInput = function(name, chartId = 1) { idx <- which(names == name & chartIds %in% c(0, chartId)) if (length(idx) == 0) stop("cannot find input ", name) @@ -27,6 +38,13 @@ InputList <- setRefClass( getInput(name, chartId)$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) { res <- getInput(name, chartId)$setValue(value) update() diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R index 341667d..ff85bff 100644 --- a/tests/testthat/test-input_list_class.R +++ b/tests/testthat/test-input_list_class.R @@ -12,16 +12,17 @@ describe("InputList", { expect_equal(inputList$inputs$output_1_y$value, 7) }) + 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) + it ("gets and updates an input by name and chartId", { - 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) # Get Input # Individual inputs expect_equal(inputList$getInput("x", 1)$value, 5) @@ -49,5 +50,22 @@ describe("InputList", { 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")) + }) }) }) From 0f192dbb1a2c16143bf85bf5f33e4ed87e6482b3 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Thu, 27 Jul 2017 15:02:42 +0200 Subject: [PATCH 015/101] New class Controller --- R/controller.R | 78 +++++++++++++++++++++ R/input_list_class.R | 4 ++ R/manipulateWidget.R | 52 ++++++++------ R/mwUI.R | 2 +- inst/manipulate_widget/manipulate_widget.js | 4 +- tests/testthat/test-controller.R | 32 +++++++++ tests/testthat/test-inputs.R | 2 +- 7 files changed, 150 insertions(+), 24 deletions(-) create mode 100644 R/controller.R create mode 100644 tests/testthat/test-controller.R diff --git a/R/controller.R b/R/controller.R new file mode 100644 index 0000000..4531155 --- /dev/null +++ b/R/controller.R @@ -0,0 +1,78 @@ +Controller <- setRefClass( + "Controller", + fields = c("inputList", "envs", "session", "output", "expr", "ncharts", "charts", + "autoUpdate", "renderFunc"), + methods = list( + + initialize = function(expr, inputs, autoUpdate = TRUE) { + expr <<- expr + inputList <<- inputs$inputList + ncharts <<- inputs$ncharts + envs <<- inputs$envs$ind + autoUpdate <<- autoUpdate + renderFunc <<- NULL + output <<- NULL + charts <<- list() + updateCharts() + }, + + setShinySession = function(session) { + session <<- session + inputList$session <<- session + }, + + getValue = function(name, chartId = 1) { + inputList$getValue(name, chartId) + }, + + getValueById = function(id) { + inputList$getValueById(id) + }, + + setValue = function(name, value, chartId = 1) { + oldValue <- getValue(name, chartId) + newValue <- inputList$setValue(name, value, chartId) + if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { + if (inputList$isShared(name)) updateCharts() + else updateChart(chartId) + } + }, + + setValueById = function(id, value) { + oldValue <- getValueById(id) + newValue <- inputList$setValueById(id, value) + if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { + if (grepl("^shared_", id)) updateCharts() + else { + chartId <- get(".id", envir = inputList$inputs[[id]]$env) + updateChart(chartId) + } + } + }, + + getValues = function(chartId = 1) { + inputList$getValues(chartId) + }, + + updateChart = function(chartId = 1) { + charts[[chartId]] <<- eval(expr, envir = envs[[chartId]]) + renderShinyOutput(chartId) + }, + + updateCharts = function() { + for (i in seq_len(ncharts)) updateChart(i) + }, + + renderShinyOutput = function(chartId) { + if (!is.null(renderFunc) & !is.null(output)) { + outputId <- get(".output", envir = envs[[chartId]]) + output[[outputId]] <<- renderFunc(charts[[chartId]]) + } + }, + + renderShinyOutputs = function() { + for (i in seq_len(ncharts)) renderShinyOutput(i) + } + + ) +) diff --git a/R/input_list_class.R b/R/input_list_class.R index fe480f3..7f57ec8 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -38,6 +38,10 @@ InputList <- setRefClass( getInput(name, chartId)$value }, + getValueById = function(inputId) { + inputs[[inputId]]$value + }, + getValues = function(chartId = 1) { idx <- which(chartIds %in% c(0, chartId)) res <- lapply(names[idx], function(n) getValue(n, chartId)) diff --git a/R/manipulateWidget.R b/R/manipulateWidget.R index be67e9e..961d835 100644 --- a/R/manipulateWidget.R +++ b/R/manipulateWidget.R @@ -240,24 +240,22 @@ 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) - }) + # Initialize inputs + inputs <- initInputs(list(...), env = .env, compare = names(.compare), + ncharts = .compareOpts$ncharts) + # Initialize controller + controller <- Controller(.expr, inputs) # Get shiny output and render functions - if (is(initWidgets[[1]], "htmlwidget")) { - cl <- class(initWidgets[[1]])[1] - pkg <- attr(initWidgets[[1]], "package") + if (is(controller$charts[[1]], "htmlwidget")) { + cl <- class(controller$charts[[1]])[1] + pkg <- attr(controller$charts[[1]], "package") renderFunName <- ls(getNamespace(pkg), pattern = "^render") renderFunction <- getFromNamespace(renderFunName, pkg) - OutputFunName <- ls(getNamespace(pkg), pattern = "Output$") - outputFunction <- getFromNamespace(OutputFunName, pkg) + outputFunName <- ls(getNamespace(pkg), pattern = "Output$") + outputFunction <- getFromNamespace(outputFunName, pkg) useCombineWidgets <- FALSE } else { renderFunction <- renderCombineWidgets @@ -265,16 +263,30 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, useCombineWidgets <- TRUE } + controller$renderFunc <- renderFunction + dims <- .getRowAndCols(.compareOpts$ncharts, .compareOpts$nrow, .compareOpts$ncol) - ui <- mwUI(controls, dims$nrow, dims$ncol, outputFunction, okBtn = !isRuntimeShiny, + ui <- mwUI(inputs, 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) + # server <- mwServer(.expr, controls, initWidgets, + # renderFunction, + # .updateBtn, + # .return, + # dims$nrow, dims$ncol, + # useCombineWidgets) + server <- function(input, output, session) { + controller$output <- output + controller$session <- session + controller$renderShinyOutputs() + + observe({ + for (id in names(controller$inputList$inputs)) { + controller$setValueById(id, input[[id]]) + } + }) + + } if (interactive()) { # We are in an interactive session so we start a shiny gadget @@ -291,6 +303,6 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, } 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) + mwReturn(controller$widgets, .return, controls$env$ind, dims$nrow, dims$ncol) } } diff --git a/R/mwUI.R b/R/mwUI.R index dffded9..23f53b4 100644 --- a/R/mwUI.R +++ b/R/mwUI.R @@ -56,7 +56,7 @@ mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, .uiChartarea <- function(ncharts, nrow, ncol, outputFun) { outputEls <- lapply(seq_len(nrow * ncol), function(i) { if (i > ncharts) return(tags$div()) - outputId <- paste0("output", i) + outputId <- paste0("output_", i) if (is.null(outputFun)) { el <- combineWidgetsOutput(outputId, width = "100%", height = "100%") } else { diff --git a/inst/manipulate_widget/manipulate_widget.js b/inst/manipulate_widget/manipulate_widget.js index 4b9629e..9622855 100644 --- a/inst/manipulate_widget/manipulate_widget.js +++ b/inst/manipulate_widget/manipulate_widget.js @@ -16,13 +16,13 @@ function select(e) { var i = el.data("index"); $(".mw-inputs").eq(i).css("display", "block"); } - + // Resize all widgets var widgets = HTMLWidgets.findAll(document, ".mw-chart>.html-widget"); var container; if (widgets) { for (var i = 0; i < widgets.length; i++) { - container = document.getElementById("output" + (i + 1)); + container = document.getElementById("output_" + (i + 1)); HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]); } } diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R new file mode 100644 index 0000000..9eef82d --- /dev/null +++ b/tests/testthat/test-controller.R @@ -0,0 +1,32 @@ +context("Controller class") + +describe("Controller", { + it("can be created with the result of initInputs()", { + inputs <- initInputs(list(a = mwText("a"), b = mwText("b"))) + expr <- expression(paste(a, b)) + controller <- Controller(expr, inputs) + expect_is(controller$charts, "list") + expect_length(controller$charts, 1) + expect_equal(controller$charts[[1]], "a b") + }) + + it("can create multiple charts in comparison mode", { + inputs <- initInputs(list(a = mwText("a"), b = mwText("b")), compare = "b", + ncharts = 3) + expr <- expression(paste(a, b)) + controller <- Controller(expr, inputs) + expect_is(controller$charts, "list") + expect_length(controller$charts, 3) + for (o in controller$charts) expect_equal(o, "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 <- Controller(expr, inputs), "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")) + }) +}) diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R index f4faeec..382dabe 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -1,4 +1,4 @@ -context("inputs") +context("Shiny inputs") # Slider test_input(mwSlider(0, 10, 0), c(5, -20, 20), c(5, 0, 10)) From e9fa92ba90f8305141af43fb2cee80b9a53bd819 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Thu, 27 Jul 2017 16:11:46 +0200 Subject: [PATCH 016/101] Fix a view issue in the Rstudio viewer page in comparison mode --- R/mwUI.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/R/mwUI.R b/R/mwUI.R index 23f53b4..78a4450 100644 --- a/R/mwUI.R +++ b/R/mwUI.R @@ -62,15 +62,15 @@ mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, } else { el <- outputFun(outputId, width = "100%", height = "100%") } - tags$div(class="mw-chart", el) + style <- sprintf("float:left;width:%s%%;height:%s%%", + floor(100 / ncol), floor(100 / nrow)) + tags$div(class="mw-chart", el, style = style) }) - outputEls <- split(outputEls, (1:(ncol*nrow) - 1) %/% ncol) - rows <- lapply(outputEls, function(x) { - do.call(shiny::fillRow, x) - }) - - do.call(shiny::fillCol, unname(rows)) + tags$div( + style = "height:100%;width:100%", + shiny::tagList(outputEls) + ) } .uiMenu <- function(ncharts, nrow, ncol, settingsBtn, okBtn, updateBtn, areaBtns) { From 28bb34bfb53b4bd876e05d0d4bd484c0ab943707 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Fri, 28 Jul 2017 10:40:43 +0200 Subject: [PATCH 017/101] new method to clone a controller --- R/controller.R | 37 +++++++++++++++++++++++++++++++- R/manipulateWidget.R | 1 + tests/testthat/test-controller.R | 11 ++++++++++ 3 files changed, 48 insertions(+), 1 deletion(-) diff --git a/R/controller.R b/R/controller.R index 4531155..b86b9e1 100644 --- a/R/controller.R +++ b/R/controller.R @@ -72,7 +72,42 @@ Controller <- setRefClass( renderShinyOutputs = function() { for (i in seq_len(ncharts)) renderShinyOutput(i) - } + }, + + clone = function(env = parent.frame()) { + # Clone environments + newSharedEnv <- cloneEnv(parent.env(envs[[1]])) + newEnvs <- lapply(envs, cloneEnv, parentEnv = newSharedEnv) + newInputs <- lapply(seq_along(inputList$inputs), function(i) { + x <- inputList$inputs[[i]]$copy() + chartId <- inputList$chartIds[i] + if (chartId == 0) x$env <- newSharedEnv + else x$env <- newEnvs[[chartId]] + x + }) + + res <- Controller( + expr, + list( + inputList = InputList(newInputs, session), + envs = list( + shared = newSharedEnv, + ind = newEnvs + ), + ncharts = ncharts + ), + autoUpdate + ) + res$renderFunc <- renderFunc + res$charts <- charts + res + } ) ) + +cloneEnv <- function(env, parentEnv = parent.env(env)) { + res <- as.environment(as.list(env, all.names = TRUE)) + parent.env(res) <- parentEnv + res +} diff --git a/R/manipulateWidget.R b/R/manipulateWidget.R index 961d835..548033e 100644 --- a/R/manipulateWidget.R +++ b/R/manipulateWidget.R @@ -276,6 +276,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, # dims$nrow, dims$ncol, # useCombineWidgets) server <- function(input, output, session) { + controller <- controller$clone() controller$output <- output controller$session <- session controller$renderShinyOutputs() diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index 9eef82d..67678e1 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -29,4 +29,15 @@ describe("Controller", { # 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 <- Controller(expr, inputs) + controller2 <- controller1$clone() + + controller1$setValue("a", "test") + expect_equal(controller1$getValue("a"), "test") + expect_equal(controller2$getValue("a"), "a") + }) }) From a3f680c90e985414a90b3a560b7c96f599d26673 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Fri, 28 Jul 2017 11:37:37 +0200 Subject: [PATCH 018/101] Reimplement conditionnal inputs --- R/controller.R | 8 +++++++- R/input_class.R | 2 +- R/input_list_class.R | 9 ++++++++- R/manipulateWidget.R | 3 +-- 4 files changed, 17 insertions(+), 5 deletions(-) diff --git a/R/controller.R b/R/controller.R index b86b9e1..167a01e 100644 --- a/R/controller.R +++ b/R/controller.R @@ -1,3 +1,5 @@ +mwDebug <- TRUE + Controller <- setRefClass( "Controller", fields = c("inputList", "envs", "session", "output", "expr", "ncharts", "charts", @@ -11,13 +13,15 @@ Controller <- setRefClass( envs <<- inputs$envs$ind autoUpdate <<- autoUpdate renderFunc <<- NULL + session <<- NULL output <<- NULL charts <<- list() updateCharts() }, - setShinySession = function(session) { + setShinySession = function(output, session) { session <<- session + output <<- output inputList$session <<- session }, @@ -39,6 +43,7 @@ Controller <- setRefClass( }, setValueById = function(id, value) { + if (mwDebug) cat("update input", id, "- new value = ", value, "\n") oldValue <- getValueById(id) newValue <- inputList$setValueById(id, value) if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { @@ -55,6 +60,7 @@ Controller <- setRefClass( }, updateChart = function(chartId = 1) { + if (mwDebug) cat("Update chart", chartId, "\n") charts[[chartId]] <<- eval(expr, envir = envs[[chartId]]) renderShinyOutput(chartId) }, diff --git a/R/input_class.R b/R/input_class.R index 24ecad1..392e6c2 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -82,7 +82,7 @@ Input <- setRefClass( updateHTML = function(session) { "Update the input HTML." - if (emptyField(htmlFunc)) return() + if (emptyField(htmlUpdateFunc)) return() if (valueHasChanged || length(changedParams) > 0) { htmlFunc(session, getID(), label, value, lastParams) valueHasChanged <<- FALSE diff --git a/R/input_list_class.R b/R/input_list_class.R index 7f57ec8..abd3bca 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -78,7 +78,14 @@ InputList <- setRefClass( } if (!is.null(session)) { - for (input in inputs) input$updateHTML(session) + for (input in inputs) { + shiny::updateCheckboxInput( + session, + paste0(input$getID(), "_visible"), + value = eval(input$display, envir = input$env) + ) + input$updateHTML(session) + } } } ) diff --git a/R/manipulateWidget.R b/R/manipulateWidget.R index 548033e..6d9bdbc 100644 --- a/R/manipulateWidget.R +++ b/R/manipulateWidget.R @@ -277,8 +277,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, # useCombineWidgets) server <- function(input, output, session) { controller <- controller$clone() - controller$output <- output - controller$session <- session + controller$setShinySession(output, session) controller$renderShinyOutputs() observe({ From 73812a0e3fadb5105c2caf7b5e8b70ec384a0538 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Fri, 28 Jul 2017 11:38:19 +0200 Subject: [PATCH 019/101] BUGFIX: mwSelect was always setting default value if multiple = FALSE --- R/inputs.R | 5 +++-- tests/testthat/test-inputs.R | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/R/inputs.R b/R/inputs.R index ff3e818..fc9e2eb 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -251,8 +251,9 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., type = "select", value = value, label = label, params = params, display = lazyeval::expr_find(.display), validFunc = function(x, params) { - if (params$multiple) return(intersect(x, params$choices)) - if (length(x) > 1 && x %in% choices) return(x[1]) + x <- intersect(x, params$choices) + if (params$multiple) return(x) + else if (length(x) > 0) return(x[1]) else return(choices[1]) }, htmlFunc = htmlFuncFactory(shiny::selectInput, "selected") diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R index 382dabe..2fdfe4f 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -20,7 +20,7 @@ test_input(mwNumeric(0, min = 0, max = 10), c(5, -20, 20), c(5, 0, 10)) test_input(mwText(), list("1", 1, NULL), list("1", "1", "")) # Select -test_input(mwSelect(1:4), list(1, 5, NULL), list(1, 1, 1)) +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), @@ -35,7 +35,7 @@ test_input( ) # Radio buttons -test_input(mwRadio(1:4), list(1, 5, NULL), list(1, 1, 1)) +test_input(mwRadio(1:4), list(1, 2, 5, NULL), list(1, 2, 1, 1)) # Date picker test_input( From 8b8a9f2d7ab114fd7706edeb7640e4c53d8b957f Mon Sep 17 00:00:00 2001 From: cuche27 Date: Fri, 28 Jul 2017 15:48:31 +0200 Subject: [PATCH 020/101] Reimplement dynamic inputs --- R/controller.R | 5 +- R/input_class.R | 10 +- R/inputs.R | 51 ++++++-- R/manipulateWidget.R | 1 + tests/testthat/test-controller.R | 5 +- tests/testthat/test-mwServer.R | 202 +++++++++++++++---------------- 6 files changed, 154 insertions(+), 120 deletions(-) diff --git a/R/controller.R b/R/controller.R index 167a01e..390e431 100644 --- a/R/controller.R +++ b/R/controller.R @@ -1,4 +1,4 @@ -mwDebug <- TRUE +mwDebug <- FALSE Controller <- setRefClass( "Controller", @@ -16,7 +16,6 @@ Controller <- setRefClass( session <<- NULL output <<- NULL charts <<- list() - updateCharts() }, setShinySession = function(output, session) { @@ -43,7 +42,7 @@ Controller <- setRefClass( }, setValueById = function(id, value) { - if (mwDebug) cat("update input", id, "- new value = ", value, "\n") + if (mwDebug) cat("Update value of input", id, "\n") oldValue <- getValueById(id) newValue <- inputList$setValueById(id, value) if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { diff --git a/R/input_class.R b/R/input_class.R index 392e6c2..43f723e 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -57,7 +57,8 @@ Input <- setRefClass( lastParams <<- evalParams(params, env) for (n in names(lastParams)) { - if (!is.null(oldParams[[n]]) && lastParams[[n]] != oldParams[[n]]) { + if (!is.null(oldParams[[n]]) && + !isTRUE(all.equal(lastParams[[n]], oldParams[[n]]))) { changedParams[[n]] <<- lastParams[[n]] } } @@ -84,9 +85,14 @@ Input <- setRefClass( "Update the input HTML." if (emptyField(htmlUpdateFunc)) return() if (valueHasChanged || length(changedParams) > 0) { - htmlFunc(session, getID(), label, value, lastParams) + htmlParams <- changedParams + if (valueHasChanged) htmlParams$value <- value + htmlParams$session <- session + htmlParams$inputId <- getID() + do.call(htmlUpdateFunc, htmlParams) valueHasChanged <<- FALSE changedParams <<- list() + if (mwDebug) cat("Update HTML of ", getID(), "\n") } }, diff --git a/R/inputs.R b/R/inputs.R index fc9e2eb..df8b4ee 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -18,6 +18,17 @@ htmlFuncFactory <- function(func, valueArgName = "value") { } } +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 @@ -75,7 +86,8 @@ mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) { }, htmlFunc = htmlFuncFactory(function(...) { tags$div(style = "padding:0 5px;", shiny::sliderInput(...)) - }) + }), + htmlUpdateFunc = shiny::updateSliderInput ) } @@ -112,7 +124,8 @@ mwText <- function(value = "", label = NULL, ..., .display = TRUE) { if(length(x) == 0) return("") as.character(x)[1] }, - htmlFunc = htmlFuncFactory(shiny::textInput) + htmlFunc = htmlFuncFactory(shiny::textInput), + htmlUpdateFunc = shiny::updateTextInput ) } @@ -149,7 +162,8 @@ mwNumeric <- function(value, label = NULL, ..., .display = TRUE) { validFunc = function(x, params) { min(max(params$min, x), params$max) }, - htmlFunc = htmlFuncFactory(shiny::numericInput) + htmlFunc = htmlFuncFactory(shiny::numericInput), + htmlUpdateFunc = shiny::updateNumericInput ) } @@ -191,7 +205,8 @@ mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) { if(length(x) == 0) return("") as.character(x)[1] }, - htmlFunc = htmlFuncFactory(shiny::passwordInput) + htmlFunc = htmlFuncFactory(shiny::passwordInput), + htmlUpdateFunc = shiny::updateTextInput ) } @@ -254,9 +269,10 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., x <- intersect(x, params$choices) if (params$multiple) return(x) else if (length(x) > 0) return(x[1]) - else return(choices[1]) + else return(params$choices[1]) }, - htmlFunc = htmlFuncFactory(shiny::selectInput, "selected") + htmlFunc = htmlFuncFactory(shiny::selectInput, "selected"), + htmlUpdateFunc = changeValueParam(shiny::updateSelectInput, "selected") ) } @@ -297,7 +313,8 @@ mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) { if (is.na(x)) x <- FALSE x }, - htmlFunc = htmlFuncFactory(shiny::checkboxInput) + htmlFunc = htmlFuncFactory(shiny::checkboxInput), + htmlUpdateFunc = shiny::updateCheckboxInput ) } @@ -341,7 +358,8 @@ mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) { if (is.null(x) || !x %in% params$choices) return(params$choices[[1]]) x }, - htmlFunc = htmlFuncFactory(shiny::radioButtons, valueArgName = "selected") + htmlFunc = htmlFuncFactory(shiny::radioButtons, valueArgName = "selected"), + htmlUpdateFunc = changeValueParam(shiny::updateRadioButtons, "selected") ) } @@ -381,7 +399,8 @@ mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) { if (!is.null(params$max)) params$max <- as.Date(params$max) x <- min(max(x, params$min), params$max) }, - htmlFunc = htmlFuncFactory(shiny::dateInput) + htmlFunc = htmlFuncFactory(shiny::dateInput), + htmlUpdateFunc = shiny::updateDateInput ) } @@ -431,7 +450,16 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ... params$label <- label params$start <- value[[1]] params$end <- value[[2]] - do.call(func, params) + 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) } ) } @@ -477,7 +505,8 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = validFunc = function(x, params) { intersect(x, params$choices) }, - htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected") + htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected"), + htmlUpdateFunc = changeValueParam(shiny::updateCheckboxGroupInput, "selected") ) } diff --git a/R/manipulateWidget.R b/R/manipulateWidget.R index 6d9bdbc..acf40c6 100644 --- a/R/manipulateWidget.R +++ b/R/manipulateWidget.R @@ -245,6 +245,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, ncharts = .compareOpts$ncharts) # Initialize controller controller <- Controller(.expr, inputs) + controller$updateCharts() # Get shiny output and render functions if (is(controller$charts[[1]], "htmlwidget")) { diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index 67678e1..8afd817 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -5,6 +5,7 @@ describe("Controller", { inputs <- initInputs(list(a = mwText("a"), b = mwText("b"))) expr <- expression(paste(a, b)) controller <- Controller(expr, inputs) + controller$updateCharts() expect_is(controller$charts, "list") expect_length(controller$charts, 1) expect_equal(controller$charts[[1]], "a b") @@ -15,6 +16,7 @@ describe("Controller", { ncharts = 3) expr <- expression(paste(a, b)) controller <- Controller(expr, inputs) + controller$updateCharts() expect_is(controller$charts, "list") expect_length(controller$charts, 3) for (o in controller$charts) expect_equal(o, "a b") @@ -23,7 +25,8 @@ describe("Controller", { 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 <- Controller(expr, inputs), "chart updated") + controller <- Controller(expr, inputs) + expect_output(controller$updateCharts(), "chart updated") # Update a with different value expect_output(controller$setValue("a", "b"), "chart updated") # Update a with same value diff --git a/tests/testthat/test-mwServer.R b/tests/testthat/test-mwServer.R index e9caf93..eea4f99 100644 --- a/tests/testthat/test-mwServer.R +++ b/tests/testthat/test-mwServer.R @@ -1,103 +1,99 @@ -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]])) - } - } - ) - }) - -}) +# context("mwServer") +# +# # 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]])) +# } +# } +# ) +# }) +# +# }) From 7d1ed3b37811219f54d138b5ef9f14e8a9ed6182 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Fri, 28 Jul 2017 16:05:29 +0200 Subject: [PATCH 021/101] Add private helper functions for debugging --- R/controller.R | 6 ++---- R/debug.R | 17 +++++++++++++++++ R/input_class.R | 2 +- 3 files changed, 20 insertions(+), 5 deletions(-) create mode 100644 R/debug.R diff --git a/R/controller.R b/R/controller.R index 390e431..a7ed5bc 100644 --- a/R/controller.R +++ b/R/controller.R @@ -1,5 +1,3 @@ -mwDebug <- FALSE - Controller <- setRefClass( "Controller", fields = c("inputList", "envs", "session", "output", "expr", "ncharts", "charts", @@ -42,7 +40,7 @@ Controller <- setRefClass( }, setValueById = function(id, value) { - if (mwDebug) cat("Update value of input", id, "\n") + catIfDebug("Update value of input", id) oldValue <- getValueById(id) newValue <- inputList$setValueById(id, value) if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { @@ -59,7 +57,7 @@ Controller <- setRefClass( }, updateChart = function(chartId = 1) { - if (mwDebug) cat("Update chart", chartId, "\n") + catIfDebug("Update chart", chartId) charts[[chartId]] <<- eval(expr, envir = envs[[chartId]]) renderShinyOutput(chartId) }, 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/input_class.R b/R/input_class.R index 43f723e..628e540 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -92,7 +92,7 @@ Input <- setRefClass( do.call(htmlUpdateFunc, htmlParams) valueHasChanged <<- FALSE changedParams <<- list() - if (mwDebug) cat("Update HTML of ", getID(), "\n") + catIfDebug("Update HTML of ", getID(), "\n") } }, From f9dc0f7640c866f3abb9de21867ef20d4e19362c Mon Sep 17 00:00:00 2001 From: cuche27 Date: Fri, 28 Jul 2017 17:07:34 +0200 Subject: [PATCH 022/101] Reimplement onDone behavior --- R/controller.R | 14 +++- R/inputs.R | 2 +- R/manipulateWidget.R | 10 ++- R/mwServer_helpers.R | 14 ++-- R/zzz.R | 174 +++++++++++++++++++++---------------------- 5 files changed, 116 insertions(+), 98 deletions(-) diff --git a/R/controller.R b/R/controller.R index a7ed5bc..06271f5 100644 --- a/R/controller.R +++ b/R/controller.R @@ -1,7 +1,7 @@ Controller <- setRefClass( "Controller", fields = c("inputList", "envs", "session", "output", "expr", "ncharts", "charts", - "autoUpdate", "renderFunc"), + "autoUpdate", "renderFunc", "useCombineWidgets"), methods = list( initialize = function(expr, inputs, autoUpdate = TRUE) { @@ -13,6 +13,7 @@ Controller <- setRefClass( renderFunc <<- NULL session <<- NULL output <<- NULL + useCombineWidgets <<- FALSE charts <<- list() }, @@ -20,6 +21,10 @@ Controller <- setRefClass( session <<- session output <<- output inputList$session <<- session + for (env in envs) { + assign(".initial", FALSE, envir = env) + assign(".session", session, envir = env) + } }, getValue = function(name, chartId = 1) { @@ -59,6 +64,9 @@ Controller <- setRefClass( updateChart = function(chartId = 1) { catIfDebug("Update chart", chartId) charts[[chartId]] <<- eval(expr, envir = envs[[chartId]]) + if (useCombineWidgets) { + charts[[chartId]] <<- combineWidgets(charts[[chartId]]) + } renderShinyOutput(chartId) }, @@ -67,7 +75,8 @@ Controller <- setRefClass( }, renderShinyOutput = function(chartId) { - if (!is.null(renderFunc) & !is.null(output)) { + if (!is.null(renderFunc) & !is.null(output) & + is(charts[[chartId]], "htmlwidget")) { outputId <- get(".output", envir = envs[[chartId]]) output[[outputId]] <<- renderFunc(charts[[chartId]]) } @@ -104,6 +113,7 @@ Controller <- setRefClass( ) res$renderFunc <- renderFunc res$charts <- charts + res$useCombineWidgets <- useCombineWidgets res } ) diff --git a/R/inputs.R b/R/inputs.R index df8b4ee..d761799 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -568,7 +568,7 @@ mwGroup <- function(..., .display = TRUE) { tags$div( class="panel-body collapse", id=paste0("panel-body-", id), - tagList(htmlElements) + shiny::tagList(htmlElements) ) ) } diff --git a/R/manipulateWidget.R b/R/manipulateWidget.R index acf40c6..3642ec8 100644 --- a/R/manipulateWidget.R +++ b/R/manipulateWidget.R @@ -265,6 +265,11 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, } controller$renderFunc <- renderFunction + if (useCombineWidgets) { + controller$useCombineWidgets <- TRUE + controller$charts <- lapply(controller$charts, combineWidgets) + } + dims <- .getRowAndCols(.compareOpts$ncharts, .compareOpts$nrow, .compareOpts$ncol) @@ -281,12 +286,15 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, controller$setShinySession(output, session) controller$renderShinyOutputs() + message("Click on the 'OK' button to return to the R session.") + observe({ for (id in names(controller$inputList$inputs)) { controller$setValueById(id, input[[id]]) } }) + observeEvent(input$done, onDone(controller, .return, dims$nrow, dims$ncol)) } if (interactive()) { @@ -304,6 +312,6 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, } else { # Other cases (Rmarkdown or non interactive execution). We return the initial # widget to not block the R execution. - mwReturn(controller$widgets, .return, controls$env$ind, dims$nrow, dims$ncol) + mwReturn(controller$charts, .return, controller$envs, dims$nrow, dims$ncol) } } diff --git a/R/mwServer_helpers.R b/R/mwServer_helpers.R index 2eac373..e3f7c52 100644 --- a/R/mwServer_helpers.R +++ b/R/mwServer_helpers.R @@ -93,14 +93,14 @@ getUpdateInputFun <- function(type) { #' #' @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) - }) +onDone <- function(controller, .return = function(w, e) {w}, nrow = NULL, ncol = NULL) { + for (env in controller$envs) { + assign(".initial", TRUE, envir = env) + assign(".session", NULL, envir = env) + } + controller$updateCharts() - shiny::stopApp(mwReturn(widgets, .return, controls$env$ind, nrow, ncol)) + shiny::stopApp(mwReturn(controller$charts, .return, controls$env$ind, nrow, ncol)) } #' Function that takes a list of widgets and returns the first one if there is 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")) From 0e40215bd29b92206894a8d72710b7261aeba78f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 28 Jul 2017 17:18:56 +0200 Subject: [PATCH 023/101] Remove useless functions and update documentation --- NAMESPACE | 2 + R/mwServer.R | 79 -------------------------------------- R/mwServer_helpers.R | 87 ------------------------------------------ README.Rmd | 7 ++-- man/mwCheckbox.Rd | 2 +- man/mwCheckboxGroup.Rd | 2 +- man/mwDate.Rd | 2 +- man/mwDateRange.Rd | 2 +- man/mwGroup.Rd | 2 +- man/mwNumeric.Rd | 2 +- man/mwPassword.Rd | 2 +- man/mwRadio.Rd | 2 +- man/mwSelect.Rd | 2 +- man/mwSlider.Rd | 2 +- man/mwText.Rd | 2 +- 15 files changed, 17 insertions(+), 180 deletions(-) delete mode 100644 R/mwServer.R diff --git a/NAMESPACE b/NAMESPACE index 4211a69..12c60d6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,6 +22,8 @@ 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/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 index e3f7c52..1347cbd 100644 --- a/R/mwServer_helpers.R +++ b/R/mwServer_helpers.R @@ -1,90 +1,3 @@ -#' 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 #' 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/man/mwCheckbox.Rd b/man/mwCheckbox.Rd index 9da8537..846cd75 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} diff --git a/man/mwCheckboxGroup.Rd b/man/mwCheckboxGroup.Rd index 4a32251..ae7fc93 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} diff --git a/man/mwDate.Rd b/man/mwDate.Rd index 84c2c4e..58125b0 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} diff --git a/man/mwDateRange.Rd b/man/mwDateRange.Rd index 93c0673..f99f315 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} diff --git a/man/mwGroup.Rd b/man/mwGroup.Rd index 3c6ee1c..0e3cde3 100644 --- a/man/mwGroup.Rd +++ b/man/mwGroup.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{mwGroup} \alias{mwGroup} \title{Group inputs in a collapsible box} diff --git a/man/mwNumeric.Rd b/man/mwNumeric.Rd index 7a7fee5..0db2de9 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} diff --git a/man/mwPassword.Rd b/man/mwPassword.Rd index 4d19461..567938f 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} diff --git a/man/mwRadio.Rd b/man/mwRadio.Rd index 2f9972e..de9e7f6 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} diff --git a/man/mwSelect.Rd b/man/mwSelect.Rd index 7d3a197..9287a25 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} diff --git a/man/mwSlider.Rd b/man/mwSlider.Rd index fe74512..ace6622 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} diff --git a/man/mwText.Rd b/man/mwText.Rd index c739398..a405fd7 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} From da0a7284670fb94682a157e014373a73d1f48fde Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 28 Jul 2017 17:37:49 +0200 Subject: [PATCH 024/101] rewrite test for onDone() (draft) --- tests/testthat/test-mwServer.R | 109 ++++++++------------------------- 1 file changed, 27 insertions(+), 82 deletions(-) diff --git a/tests/testthat/test-mwServer.R b/tests/testthat/test-mwServer.R index eea4f99..3c9ebc1 100644 --- a/tests/testthat/test-mwServer.R +++ b/tests/testthat/test-mwServer.R @@ -1,82 +1,24 @@ -# context("mwServer") -# -# # 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") -# ) -# }) +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 <- Controller(expr, inputs) + + 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", { # with_mock( @@ -85,8 +27,11 @@ # x # }, # { +# inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)), +# compare = list(x2 = list(1, 2, 3))) # expr <- expression(paste(x1, x2)) -# expect_output(res <- onDone(expr, controlsCompare), "Stop gadget") +# controller <- Controller(expr, inputs) +# expect_output(res <- onDone(controller), "Stop gadget") # expect_is(res, "combineWidgets") # expect_equal(length(res$widgets), 3) # for (i in 1:3) { @@ -95,5 +40,5 @@ # } # ) # }) -# -# }) + +}) From ca4ceb4b885c642ff22de4607732927979b4ffc2 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Sat, 29 Jul 2017 12:05:06 +0200 Subject: [PATCH 025/101] Set different initial values in comparison mode --- R/init_inputs.R | 8 ++++-- R/input_utils.R | 4 ++- R/manipulateWidget.R | 2 +- tests/testthat/test-init_inputs.R | 13 +++++++--- tests/testthat/test-input_utils.R | 11 ++++++-- tests/testthat/test-mwServer.R | 43 ++++++++++++++++--------------- 6 files changed, 51 insertions(+), 30 deletions(-) diff --git a/R/init_inputs.R b/R/init_inputs.R index 992cbeb..3a2e6eb 100644 --- a/R/init_inputs.R +++ b/R/init_inputs.R @@ -41,9 +41,13 @@ initInputs <- function(inputs, env = parent.frame(), compare = NULL, ncharts = 1 sharedEnv <- initEnv(env, 0) indEnvs <- lapply(seq_len(ncharts), function(i) initEnv(sharedEnv, i)) - sharedInputs <- filterAndInitInputs(inputs, compare, drop = TRUE, sharedEnv) + sharedInputs <- filterAndInitInputs(inputs, names(compare), drop = TRUE, sharedEnv) indInputs <- lapply(seq_len(ncharts), function(i) { - filterAndInitInputs(inputs, compare, env = indEnvs[[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)) diff --git a/R/input_utils.R b/R/input_utils.R index 4206272..12f77c3 100644 --- a/R/input_utils.R +++ b/R/input_utils.R @@ -7,10 +7,12 @@ #' #' @return a list of inputs #' @noRd -filterAndInitInputs <- function(inputs, names, drop = FALSE, env = parent.frame()) { +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 diff --git a/R/manipulateWidget.R b/R/manipulateWidget.R index 3642ec8..fb87854 100644 --- a/R/manipulateWidget.R +++ b/R/manipulateWidget.R @@ -241,7 +241,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, } # Initialize inputs - inputs <- initInputs(list(...), env = .env, compare = names(.compare), + inputs <- initInputs(list(...), env = .env, compare = .compare, ncharts = .compareOpts$ncharts) # Initialize controller controller <- Controller(.expr, inputs) diff --git a/tests/testthat/test-init_inputs.R b/tests/testthat/test-init_inputs.R index f7c5687..71bc0e4 100644 --- a/tests/testthat/test-init_inputs.R +++ b/tests/testthat/test-init_inputs.R @@ -25,13 +25,13 @@ test_structure <- function(inputs, compare = NULL, ncharts = 1) { # inexact when one tries to compare grouped inputs expect_length(res$inputList$inputs, expectedLength) - sharedInputs <- setdiff(names(inputList), compare) + 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, "_", compare) + paste0("output_", i, "_", names(compare)) ) } } @@ -55,7 +55,14 @@ describe("initInputs", { }) it("prepares inputs for comparison", { - test_structure(list(a = mwText(), b = mwText()), ncharts = 2, compare = "a") + 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", { diff --git a/tests/testthat/test-input_utils.R b/tests/testthat/test-input_utils.R index 29d8d36..570834e 100644 --- a/tests/testthat/test-input_utils.R +++ b/tests/testthat/test-input_utils.R @@ -26,7 +26,7 @@ describe("filterAndInitInputs", { } }) - it ("can filter grouped inputs", { + it ("filters grouped inputs", { inputs <- list(grp = mwGroup(a = mwText(), b = mwText()), c = mwText()) # Keep inputs @@ -65,7 +65,7 @@ describe("filterAndInitInputs", { expect_equal(names(filteredInputs), c("c")) }) - it ("can select/remove a whole group", { + 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") @@ -82,6 +82,13 @@ describe("filterAndInitInputs", { 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", { diff --git a/tests/testthat/test-mwServer.R b/tests/testthat/test-mwServer.R index 3c9ebc1..91deb7d 100644 --- a/tests/testthat/test-mwServer.R +++ b/tests/testthat/test-mwServer.R @@ -19,26 +19,27 @@ describe("onDone", { } ) }) -# -# it ("returns a combined widget if comparison", { -# with_mock( -# `shiny::stopApp` = function(x) { -# print("Stop gadget") -# x -# }, -# { -# inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)), -# compare = list(x2 = list(1, 2, 3))) -# expr <- expression(paste(x1, x2)) -# controller <- Controller(expr, inputs) -# 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]], paste("value1", compare$x2[[i]])) -# } -# } -# ) -# }) + + it ("returns a combined widget if comparison", { + 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 <- Controller(expr, inputs) + 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]], paste("value1", compare$x2[[i]])) + } + } + ) + }) }) From 16ee4894e2fe435b411b61b6619db3ac9f325e5c Mon Sep 17 00:00:00 2001 From: cuche27 Date: Sat, 29 Jul 2017 12:17:36 +0200 Subject: [PATCH 026/101] Correct problems detected with R CMD CHECK and rename files --- R/{combineWidgets.R => combine_widgets.R} | 0 R/{compareOptions.R => compare_options.R} | 0 R/{getRowAndCols.R => get_row_and_cols.R} | 0 R/{manipulateWidget.R => manipulate_widget.R} | 2 +- R/{mwUI.R => mw_ui.R} | 0 R/{mwServer_helpers.R => on_done.R} | 2 +- R/{staticImage.R => static_image.R} | 0 tests/testthat/{test-mwServer.R => test-on_done.R} | 0 8 files changed, 2 insertions(+), 2 deletions(-) rename R/{combineWidgets.R => combine_widgets.R} (100%) rename R/{compareOptions.R => compare_options.R} (100%) rename R/{getRowAndCols.R => get_row_and_cols.R} (100%) rename R/{manipulateWidget.R => manipulate_widget.R} (99%) rename R/{mwUI.R => mw_ui.R} (100%) rename R/{mwServer_helpers.R => on_done.R} (92%) rename R/{staticImage.R => static_image.R} (100%) rename tests/testthat/{test-mwServer.R => test-on_done.R} (100%) diff --git a/R/combineWidgets.R b/R/combine_widgets.R similarity index 100% rename from R/combineWidgets.R rename to R/combine_widgets.R 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/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/manipulateWidget.R b/R/manipulate_widget.R similarity index 99% rename from R/manipulateWidget.R rename to R/manipulate_widget.R index fb87854..fb4aa42 100644 --- a/R/manipulateWidget.R +++ b/R/manipulate_widget.R @@ -142,7 +142,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") diff --git a/R/mwUI.R b/R/mw_ui.R similarity index 100% rename from R/mwUI.R rename to R/mw_ui.R diff --git a/R/mwServer_helpers.R b/R/on_done.R similarity index 92% rename from R/mwServer_helpers.R rename to R/on_done.R index 1347cbd..22b70e8 100644 --- a/R/mwServer_helpers.R +++ b/R/on_done.R @@ -13,7 +13,7 @@ onDone <- function(controller, .return = function(w, e) {w}, nrow = NULL, ncol = } controller$updateCharts() - shiny::stopApp(mwReturn(controller$charts, .return, controls$env$ind, nrow, ncol)) + shiny::stopApp(mwReturn(controller$charts, .return, controller$envs, nrow, ncol)) } #' Function that takes a list of widgets and returns the first one if there is 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/tests/testthat/test-mwServer.R b/tests/testthat/test-on_done.R similarity index 100% rename from tests/testthat/test-mwServer.R rename to tests/testthat/test-on_done.R From a55cb218260d566a69bd738826b735e3d979f6de Mon Sep 17 00:00:00 2001 From: cuche27 Date: Mon, 31 Jul 2017 02:20:01 +0200 Subject: [PATCH 027/101] New method returnCharts() for Controller class --- R/controller.R | 18 ++++++++++++++++-- R/manipulate_widget.R | 12 ++++++------ R/on_done.R | 20 ++------------------ 3 files changed, 24 insertions(+), 26 deletions(-) diff --git a/R/controller.R b/R/controller.R index 06271f5..d39d119 100644 --- a/R/controller.R +++ b/R/controller.R @@ -1,10 +1,12 @@ Controller <- setRefClass( "Controller", fields = c("inputList", "envs", "session", "output", "expr", "ncharts", "charts", - "autoUpdate", "renderFunc", "useCombineWidgets"), + "autoUpdate", "renderFunc", "useCombineWidgets", "nrow", "ncol", + "returnFunc"), methods = list( - initialize = function(expr, inputs, autoUpdate = TRUE) { + initialize = function(expr, inputs, autoUpdate = TRUE, nrow = NULL, + ncol = NULL, returnFunc = function(widget, envs) {widget}) { expr <<- expr inputList <<- inputs$inputList ncharts <<- inputs$ncharts @@ -14,6 +16,9 @@ Controller <- setRefClass( session <<- NULL output <<- NULL useCombineWidgets <<- FALSE + nrow <<- nrow + ncol <<- ncol + returnFunc <<- returnFunc charts <<- list() }, @@ -70,6 +75,15 @@ Controller <- setRefClass( renderShinyOutput(chartId) }, + returnCharts = function() { + if (length(charts) == 1) { + finalWidget <- charts[[1]] + } else { + finalWidget <- combineWidgets(list = charts, nrow = nrow, ncol = ncol) + } + returnFunc(finalWidget, envs) + }, + updateCharts = function() { for (i in seq_len(ncharts)) updateChart(i) }, diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index fb4aa42..851c332 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -240,11 +240,14 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, } } + dims <- .getRowAndCols(.compareOpts$ncharts, .compareOpts$nrow, .compareOpts$ncol) + # Initialize inputs inputs <- initInputs(list(...), env = .env, compare = .compare, ncharts = .compareOpts$ncharts) # Initialize controller - controller <- Controller(.expr, inputs) + controller <- Controller(.expr, inputs, nrow = dims$nrow, ncol = dims$ncol, + returnFunc = .return) controller$updateCharts() # Get shiny output and render functions @@ -270,9 +273,6 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, controller$charts <- lapply(controller$charts, combineWidgets) } - - dims <- .getRowAndCols(.compareOpts$ncharts, .compareOpts$nrow, .compareOpts$ncol) - ui <- mwUI(inputs, dims$nrow, dims$ncol, outputFunction, okBtn = !isRuntimeShiny, updateBtn = .updateBtn, areaBtns = length(.compare) > 0, border = isRuntimeShiny) # server <- mwServer(.expr, controls, initWidgets, @@ -294,7 +294,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, } }) - observeEvent(input$done, onDone(controller, .return, dims$nrow, dims$ncol)) + observeEvent(input$done, onDone(controller, .return)) } if (interactive()) { @@ -312,6 +312,6 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, } else { # Other cases (Rmarkdown or non interactive execution). We return the initial # widget to not block the R execution. - mwReturn(controller$charts, .return, controller$envs, dims$nrow, dims$ncol) + controller$returnCharts() } } diff --git a/R/on_done.R b/R/on_done.R index 22b70e8..ca14f30 100644 --- a/R/on_done.R +++ b/R/on_done.R @@ -6,28 +6,12 @@ #' #' @return a htmlwidget #' @noRd -onDone <- function(controller, .return = function(w, e) {w}, nrow = NULL, ncol = NULL) { +onDone <- function(controller, .return = function(w, e) {w}) { for (env in controller$envs) { assign(".initial", TRUE, envir = env) assign(".session", NULL, envir = env) } controller$updateCharts() - shiny::stopApp(mwReturn(controller$charts, .return, controller$envs, 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) + shiny::stopApp(controller$returnCharts()) } From 35617f92a3f122a4870bb2dc057d3ad2456cacf2 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Mon, 31 Jul 2017 02:24:51 +0200 Subject: [PATCH 028/101] Reimplement updateBtn --- R/manipulate_widget.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 851c332..1da2db9 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -246,7 +246,8 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, inputs <- initInputs(list(...), env = .env, compare = .compare, ncharts = .compareOpts$ncharts) # Initialize controller - controller <- Controller(.expr, inputs, nrow = dims$nrow, ncol = dims$ncol, + controller <- Controller(.expr, inputs, autoUpdate = !.updateBtn, + nrow = dims$nrow, ncol = dims$ncol, returnFunc = .return) controller$updateCharts() @@ -293,7 +294,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, controller$setValueById(id, input[[id]]) } }) - + observeEvent(input$.update, controller$updateCharts()) observeEvent(input$done, onDone(controller, .return)) } From 925ee7feb0da33f6d83f738057543eb4c9578ba0 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Mon, 31 Jul 2017 02:28:04 +0200 Subject: [PATCH 029/101] Update example in manipulateWidget help page --- man/manipulateWidget.Rd | 466 ++++++++++++++++++++-------------------- 1 file changed, 233 insertions(+), 233 deletions(-) diff --git a/man/manipulateWidget.Rd b/man/manipulateWidget.Rd index e65918f..27d24bf 100644 --- a/man/manipulateWidget.Rd +++ b/man/manipulateWidget.Rd @@ -1,233 +1,233 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/manipulateWidget.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(), - .return = function(widget, envs) { widget }, .width = NULL, - .height = NULL) -} -\arguments{ -\item{.expr}{expression to evaluate that returns an interactive plot of class -\code{htmlwidget}. This expression is re-evaluated each time a control is -modified.} - -\item{...}{One or more named control arguments created with functions -\code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control -is the name of the variable the controls modifies in the expression. One -can also create a group of inputs by passing a list of such control -arguments. for instance \code{mygroup = list(txt = mwText(""), nb = -mwNumeric(0))} creates a group of inputs named mygroup with two inputs -named "txt" and "nb".} - -\item{.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.} - -\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.} - -\item{.compare}{Sometimes one wants to compare the same chart but with two -different sets of parameters. This is the purpose of this argument. It can -be a character vector of input names or a named list whose names are the -names of the inputs that should vary between the two charts. Each element -of the list must be a vector or a list of length equal to the number of -charts with the initial values of the corresponding parameter for each -chart. It can also be \code{NULL}. In this case, the parameter is -initialized with the default value for the two charts.} - -\item{.compareOpts}{List of options created \code{\link{compareOptions}}. -These options indicate the number of charts to create and their disposition.} - -\item{.return}{A function that can be used to modify the output of -\code{manipulateWidget}. It must take two parameters: the first one is the -final widget, the second one is a list of environments containing the input -values of each individual widget. The length of this list is one if .compare -is null, two or more if it has been defined.} - -\item{.width}{Width of the UI. Used only on Rmarkdown documents with option -\code{runtime: shiny}.} - -\item{.height}{Height of the UI. Used only on Rmarkdown documents with option -\code{runtime: shiny}.} -} -\value{ -The result of the expression evaluated with the last values of the controls. -It should be an object of class \code{htmlWidget}. -} -\description{ -This function permits to add controls to an interactive plot created with -packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order -to change the input data or the parameters of the plot. - -Technically, the function starts a shiny gadget. The R session is bloqued -until the user clicks on "cancel" or "done". If he clicks on "done", then the -the function returns the last displayed plot so the user can modify it and/or -save it. -} -\section{Advanced Usage}{ - -The "normal" use of the function is to provide an expression that always -return an \code{htmlwidget}. In such case, every time the user changes the -value of an input, the current widget is destroyed and a new one is created -and rendered. - -Some packages provide functions to update a widget that has already been -rendered. This is the case for instance for package \code{leaflet} with the -function \code{\link[leaflet]{leafletProxy}}. To use such functions, -\code{manipulateWidget} evaluates the parameter \code{.expr} with four extra -variables: - -\itemize{ - \item{\code{.initial}:}{ - \code{TRUE} if the expression is evaluated for the first time and then - the widget has not been rendered yet, \code{FALSE} if the widget has - already been rendered. - } - \item{\code{.session}:}{ - A shiny session object. - } - \item{\code{.output}:}{ - ID of the output in the shiny interface. - } - \item{\code{.id}:}{ - Id of the chart. It can be used in comparison mode to make further - customization without the need to create additional input controls. - } -} - -You can take a look at the last example to see how to use these two -variables to update a leaflet widget. -} - -\section{Modify the returned widget}{ - - In some specific situations, a developer may want to use - \code{manipulateWidget} in a function that waits the user to click on the - "Done" button and modifies the widget returned by \code{manipulateWidget}. - In such situation, parameter \code{.return} should be used so that - \code{manipulateWidget} is the last function called. Indeed, if other code - is present after, the custom function will act very weird in a Rmarkdown - document with "runtime: shiny". -} - -\examples{ -if (require(dygraphs)) { - - mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) - manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - title = mwText("Fictive time series")) - -} - -# Comparison mode -if (require(dygraphs)) { - - mydata <- data.frame( - year = 2000+1:100, - series1 = rnorm(100), - series2 = rnorm(100), - series3 = rnorm(100) - ) - - manipulateWidget( - dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSelect(c("series1", "series2", "series3")), - title = mwText("Fictive time series"), - .compare = c("title", "series") - ) - - # Setting different initial values for each chart - manipulateWidget( - dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSelect(c("series1", "series2", "series3")), - title = mwText(), - .compare = list( - title = list("First chart", "Second chart"), - series = NULL - ) - ) -} - -# Grouping inputs -if (require(dygraphs)) { - - mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) - manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], - main = title, xlab = xlab, ylab = ylab), - range = mwSlider(2001, 2100, c(2001, 2100)), - "Graphical parameters" = list( - title = mwText("Fictive time series"), - xlab = mwText("X axis label"), - ylab = mwText("Y axis label") - ) - ) - -} - -# Example of conditional input controls -# -# In this example, we plot a x series against a y series. User can choose to -# use points or lines. If he chooses lines, then an additional input is displayed -# to let him control the width of the lines. -if (require("plotly")) { - - dt <- data.frame ( - x = sort(runif(100)), - y = rnorm(100) - ) - - myPlot <- function(type, lwd) { - if (type == "points") { - plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers") - } else { - plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd)) - } - } - - manipulateWidget( - myPlot(type, lwd), - type = mwSelect(c("points", "lines"), "points"), - lwd = mwSlider(1, 10, 1, .display = type == "lines") - ) - -} - -# Advanced Usage -# -# .expr is evaluated with extra variables .initial, .outputId and .session -# that can be used to update an already rendered widget instead of replacing -# it each time an input value is modified. -# -# Here we generate a UI that permits to change color and size of arbitrary -# points on a map generated with leaflet. - -if (require(leaflet)) { - lon <- rnorm(10, sd = 20) - lat <- rnorm(10, sd = 20) - - myMapFun <- function(radius, color, initial, session, output) { - if (initial) { - # Widget has not been rendered - map <- leaflet() \%>\% addTiles() - } else { - # widget has already been rendered - map <- leafletProxy(output, session) \%>\% clearMarkers() - } - - map \%>\% addCircleMarkers(lon, lat, radius = radius, color = color) - } - - manipulateWidget(myMapFun(radius, color, .initial, .session, .output), - radius = mwSlider(5, 30, 10), - color = mwSelect(c("red", "blue", "green"))) - -} - -} +% Generated by roxygen2: do not edit by hand +% 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(), + .return = function(widget, envs) { widget }, .width = NULL, + .height = NULL) +} +\arguments{ +\item{.expr}{expression to evaluate that returns an interactive plot of class +\code{htmlwidget}. This expression is re-evaluated each time a control is +modified.} + +\item{...}{One or more named control arguments created with functions +\code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control +is the name of the variable the controls modifies in the expression. One +can also create a group of inputs by passing a list of such control +arguments. for instance \code{mygroup = list(txt = mwText(""), nb = +mwNumeric(0))} creates a group of inputs named mygroup with two inputs +named "txt" and "nb".} + +\item{.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.} + +\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.} + +\item{.compare}{Sometimes one wants to compare the same chart but with two +different sets of parameters. This is the purpose of this argument. It can +be a character vector of input names or a named list whose names are the +names of the inputs that should vary between the two charts. Each element +of the list must be a vector or a list of length equal to the number of +charts with the initial values of the corresponding parameter for each +chart. It can also be \code{NULL}. In this case, the parameter is +initialized with the default value for the two charts.} + +\item{.compareOpts}{List of options created \code{\link{compareOptions}}. +These options indicate the number of charts to create and their disposition.} + +\item{.return}{A function that can be used to modify the output of +\code{manipulateWidget}. It must take two parameters: the first one is the +final widget, the second one is a list of environments containing the input +values of each individual widget. The length of this list is one if .compare +is null, two or more if it has been defined.} + +\item{.width}{Width of the UI. Used only on Rmarkdown documents with option +\code{runtime: shiny}.} + +\item{.height}{Height of the UI. Used only on Rmarkdown documents with option +\code{runtime: shiny}.} +} +\value{ +The result of the expression evaluated with the last values of the controls. +It should be an object of class \code{htmlWidget}. +} +\description{ +This function permits to add controls to an interactive plot created with +packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order +to change the input data or the parameters of the plot. + +Technically, the function starts a shiny gadget. The R session is bloqued +until the user clicks on "cancel" or "done". If he clicks on "done", then the +the function returns the last displayed plot so the user can modify it and/or +save it. +} +\section{Advanced Usage}{ + +The "normal" use of the function is to provide an expression that always +return an \code{htmlwidget}. In such case, every time the user changes the +value of an input, the current widget is destroyed and a new one is created +and rendered. + +Some packages provide functions to update a widget that has already been +rendered. This is the case for instance for package \code{leaflet} with the +function \code{\link[leaflet]{leafletProxy}}. To use such functions, +\code{manipulateWidget} evaluates the parameter \code{.expr} with four extra +variables: + +\itemize{ + \item{\code{.initial}:}{ + \code{TRUE} if the expression is evaluated for the first time and then + the widget has not been rendered yet, \code{FALSE} if the widget has + already been rendered. + } + \item{\code{.session}:}{ + A shiny session object. + } + \item{\code{.output}:}{ + ID of the output in the shiny interface. + } + \item{\code{.id}:}{ + Id of the chart. It can be used in comparison mode to make further + customization without the need to create additional input controls. + } +} + +You can take a look at the last example to see how to use these two +variables to update a leaflet widget. +} + +\section{Modify the returned widget}{ + + In some specific situations, a developer may want to use + \code{manipulateWidget} in a function that waits the user to click on the + "Done" button and modifies the widget returned by \code{manipulateWidget}. + In such situation, parameter \code{.return} should be used so that + \code{manipulateWidget} is the last function called. Indeed, if other code + is present after, the custom function will act very weird in a Rmarkdown + document with "runtime: shiny". +} + +\examples{ +if (require(dygraphs)) { + + mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) + manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + title = mwText("Fictive time series")) + +} + +# Comparison mode +if (require(dygraphs)) { + + mydata <- data.frame( + year = 2000+1:100, + series1 = rnorm(100), + series2 = rnorm(100), + series3 = rnorm(100) + ) + + manipulateWidget( + dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + series = mwSelect(c("series1", "series2", "series3")), + title = mwText("Fictive time series"), + .compare = c("title", "series") + ) + + # Setting different initial values for each chart + manipulateWidget( + dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + series = mwSelect(c("series1", "series2", "series3")), + title = mwText(), + .compare = list( + title = list("First chart", "Second chart"), + series = NULL + ) + ) +} + +# Grouping inputs +if (require(dygraphs)) { + + mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) + manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], + main = title, xlab = xlab, ylab = ylab), + range = mwSlider(2001, 2100, c(2001, 2100)), + "Graphical parameters" = mwGroup( + title = mwText("Fictive time series"), + xlab = mwText("X axis label"), + ylab = mwText("Y axis label") + ) + ) + +} + +# Example of conditional input controls +# +# In this example, we plot a x series against a y series. User can choose to +# use points or lines. If he chooses lines, then an additional input is displayed +# to let him control the width of the lines. +if (require("plotly")) { + + dt <- data.frame ( + x = sort(runif(100)), + y = rnorm(100) + ) + + myPlot <- function(type, lwd) { + if (type == "points") { + plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers") + } else { + plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd)) + } + } + + manipulateWidget( + myPlot(type, lwd), + type = mwSelect(c("points", "lines"), "points"), + lwd = mwSlider(1, 10, 1, .display = type == "lines") + ) + +} + +# Advanced Usage +# +# .expr is evaluated with extra variables .initial, .outputId and .session +# that can be used to update an already rendered widget instead of replacing +# it each time an input value is modified. +# +# Here we generate a UI that permits to change color and size of arbitrary +# points on a map generated with leaflet. + +if (require(leaflet)) { + lon <- rnorm(10, sd = 20) + lat <- rnorm(10, sd = 20) + + myMapFun <- function(radius, color, initial, session, output) { + if (initial) { + # Widget has not been rendered + map <- leaflet() \%>\% addTiles() + } else { + # widget has already been rendered + map <- leafletProxy(output, session) \%>\% clearMarkers() + } + + map \%>\% addCircleMarkers(lon, lat, radius = radius, color = color) + } + + manipulateWidget(myMapFun(radius, color, .initial, .session, .output), + radius = mwSlider(5, 30, 10), + color = mwSelect(c("red", "blue", "green"))) + +} + +} From cd34ff75b030792a5fd919a673289a5b56bdae4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Mon, 31 Jul 2017 13:38:25 +0200 Subject: [PATCH 030/101] new parameter runApp and new method knit_print --- R/controller.R | 9 +++++++++ R/manipulate_widget.R | 15 +++++++-------- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/R/controller.R b/R/controller.R index d39d119..bb2f570 100644 --- a/R/controller.R +++ b/R/controller.R @@ -84,6 +84,10 @@ Controller <- setRefClass( returnFunc(finalWidget, envs) }, + show = function() { + print(returnCharts()) + }, + updateCharts = function() { for (i in seq_len(ncharts)) updateChart(i) }, @@ -138,3 +142,8 @@ cloneEnv <- function(env, parentEnv = parent.env(env)) { parent.env(res) <- parentEnv res } + +#' @export +knit_print.Controller <- function(x, ...) { + knitr::knit_print(x$returnCharts(), ...) +} diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 1da2db9..551992f 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -217,7 +217,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .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") @@ -289,16 +289,15 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, message("Click on the 'OK' button to return to the R session.") - observe({ - for (id in names(controller$inputList$inputs)) { - controller$setValueById(id, input[[id]]) - } + lapply(names(controller$inputList$inputs), function(id) { + observe({controller$setValueById(id, input[[id]])) }) + observeEvent(input$.update, controller$updateCharts()) observeEvent(input$done, onDone(controller, .return)) } - if (interactive()) { + if (runApp & interactive()) { # We are in an interactive session so we start a shiny gadget .viewer <- switch( .viewer, @@ -307,12 +306,12 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, browser = shiny::browserViewer() ) 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 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. - controller$returnCharts() + controller } } From 24285ba2652d6ca3e39cce37096bb59eb0c132bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Mon, 31 Jul 2017 15:02:11 +0200 Subject: [PATCH 031/101] It is now possible to to create some basic tests for manipulateWidget applications. --- NAMESPACE | 2 + R/controller.R | 74 ++++++++++++++++++++-- R/manipulate_widget.R | 17 ++++-- man/MWController-class.Rd | 77 +++++++++++++++++++++++ man/combineWidgets-shiny.Rd | 2 +- man/combineWidgets.Rd | 2 +- man/compareOptions.Rd | 2 +- man/knit_print.MWController.Rd | 16 +++++ man/manipulateWidget.Rd | 9 ++- man/staticPlot.Rd | 2 +- tests/testthat/test-controller.R | 21 ++++--- tests/testthat/test-manipulate_widget.R | 81 +++++++++++++++++++++++++ tests/testthat/test-on_done.R | 4 +- 13 files changed, 286 insertions(+), 23 deletions(-) create mode 100644 man/MWController-class.Rd create mode 100644 man/knit_print.MWController.Rd create mode 100644 tests/testthat/test-manipulate_widget.R diff --git a/NAMESPACE b/NAMESPACE index 12c60d6..8c757d3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ export(combineWidgets) export(combineWidgetsOutput) export(compareOptions) +export(knit_print.MWController) export(manipulateWidget) export(mwCheckbox) export(mwCheckboxGroup) @@ -18,6 +19,7 @@ export(mwText) export(renderCombineWidgets) export(staticImage) export(staticPlot) +exportClasses(MWController) importFrom(grDevices,dev.off) importFrom(grDevices,png) importFrom(htmlwidgets,getDependency) diff --git a/R/controller.R b/R/controller.R index bb2f570..16355a0 100644 --- a/R/controller.R +++ b/R/controller.R @@ -1,5 +1,51 @@ -Controller <- setRefClass( - "Controller", +#' 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 +#' +#' @export +MWController <- setRefClass( + "MWController", fields = c("inputList", "envs", "session", "output", "expr", "ncharts", "charts", "autoUpdate", "renderFunc", "useCombineWidgets", "nrow", "ncol", "returnFunc"), @@ -33,6 +79,7 @@ Controller <- setRefClass( }, getValue = function(name, chartId = 1) { + "Get the value of a variable for a given chart." inputList$getValue(name, chartId) }, @@ -41,6 +88,7 @@ Controller <- setRefClass( }, setValue = function(name, value, chartId = 1) { + "Update the value of a variable for a given chart." oldValue <- getValue(name, chartId) newValue <- inputList$setValue(name, value, chartId) if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { @@ -63,9 +111,20 @@ Controller <- setRefClass( }, 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) charts[[chartId]] <<- eval(expr, envir = envs[[chartId]]) @@ -76,6 +135,7 @@ Controller <- setRefClass( }, returnCharts = function() { + "Return all charts." if (length(charts) == 1) { finalWidget <- charts[[1]] } else { @@ -89,6 +149,7 @@ Controller <- setRefClass( }, updateCharts = function() { + "Update all charts." for (i in seq_len(ncharts)) updateChart(i) }, @@ -117,7 +178,7 @@ Controller <- setRefClass( x }) - res <- Controller( + res <- MWController( expr, list( inputList = InputList(newInputs, session), @@ -143,7 +204,12 @@ cloneEnv <- function(env, parentEnv = parent.env(env)) { res } +#' knit_print method for MWController object +#' +#' @param x MWController object +#' @param ... arguments passed to function knit_print +#' #' @export -knit_print.Controller <- function(x, ...) { +knit_print.MWController <- function(x, ...) { knitr::knit_print(x$returnCharts(), ...) } diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 551992f..4ace231 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -47,6 +47,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. @@ -217,7 +224,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .compare = NULL, .compareOpts = compareOptions(), .return = function(widget, envs) {widget}, - .width = NULL, .height = NULL, runApp = TRUE) { + .width = NULL, .height = NULL, .runApp = TRUE) { # check if we are in runtime shiny isRuntimeShiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") @@ -246,7 +253,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, inputs <- initInputs(list(...), env = .env, compare = .compare, ncharts = .compareOpts$ncharts) # Initialize controller - controller <- Controller(.expr, inputs, autoUpdate = !.updateBtn, + controller <- MWController(.expr, inputs, autoUpdate = !.updateBtn, nrow = dims$nrow, ncol = dims$ncol, returnFunc = .return) controller$updateCharts() @@ -290,14 +297,14 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, message("Click on the 'OK' button to return to the R session.") lapply(names(controller$inputList$inputs), function(id) { - observe({controller$setValueById(id, input[[id]])) + observe(controller$setValueById(id, input[[id]])) }) observeEvent(input$.update, controller$updateCharts()) observeEvent(input$done, onDone(controller, .return)) } - if (runApp & interactive()) { + if (.runApp & interactive()) { # We are in an interactive session so we start a shiny gadget .viewer <- switch( .viewer, @@ -306,7 +313,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, browser = shiny::browserViewer() ) shiny::runGadget(ui, server, viewer = .viewer) - } else if (runApp & isRuntimeShiny) { + } else if (.runApp & isRuntimeShiny) { # We are in Rmarkdown document with shiny runtime. So we start a shiny app shiny::shinyApp(ui = ui, server = server, options = list(width = .width, height = .height)) } else { diff --git a/man/MWController-class.Rd b/man/MWController-class.Rd new file mode 100644 index 0000000..05065f2 --- /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} +}} + +\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)}}{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..17567a6 100644 --- a/man/combineWidgets-shiny.Rd +++ b/man/combineWidgets-shiny.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-shiny} \alias{combineWidgets-shiny} \alias{combineWidgetsOutput} 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..513ecf0 100644 --- a/man/compareOptions.Rd +++ b/man/compareOptions.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/compareOptions.R +% Please edit documentation in R/compare_options.R \name{compareOptions} \alias{compareOptions} \title{Options for comparison mode} diff --git a/man/knit_print.MWController.Rd b/man/knit_print.MWController.Rd new file mode 100644 index 0000000..b8d3b9e --- /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.Rd b/man/manipulateWidget.Rd index 27d24bf..24e4fc2 100644 --- a/man/manipulateWidget.Rd +++ b/man/manipulateWidget.Rd @@ -7,7 +7,7 @@ manipulateWidget(.expr, ..., .updateBtn = 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 @@ -53,6 +53,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. diff --git a/man/staticPlot.Rd b/man/staticPlot.Rd index 5b44070..338fa58 100644 --- a/man/staticPlot.Rd +++ b/man/staticPlot.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/staticImage.R +% Please edit documentation in R/static_image.R \name{staticPlot} \alias{staticPlot} \alias{staticImage} diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index 8afd817..7e604f4 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -1,21 +1,21 @@ -context("Controller class") +context("MWController class") -describe("Controller", { +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 <- Controller(expr, inputs) + controller <- MWController(expr, inputs) controller$updateCharts() expect_is(controller$charts, "list") expect_length(controller$charts, 1) expect_equal(controller$charts[[1]], "a b") }) - it("can create multiple charts in comparison mode", { + 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 <- Controller(expr, inputs) + controller <- MWController(expr, inputs) controller$updateCharts() expect_is(controller$charts, "list") expect_length(controller$charts, 3) @@ -25,7 +25,7 @@ describe("Controller", { it ("does not update charts if values do not change", { inputs <- initInputs(list(a = mwText("a"), b = mwText("b"))) expr <- expression(print("chart updated")) - controller <- Controller(expr, inputs) + controller <- MWController(expr, inputs) expect_output(controller$updateCharts(), "chart updated") # Update a with different value expect_output(controller$setValue("a", "b"), "chart updated") @@ -36,11 +36,18 @@ describe("Controller", { it("creates a copy that is completely autonomous", { inputs <- initInputs(list(a = mwText("a"), b = mwText("b"))) expr <- expression(paste(a, b)) - controller1 <- Controller(expr, inputs) + controller1 <- MWController(expr, inputs) controller2 <- controller1$clone() controller1$setValue("a", "test") expect_equal(controller1$getValue("a"), "test") expect_equal(controller2$getValue("a"), "a") }) + + 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) + expect_equal(controller$getParams("a")$choices, c("a", "b", "c")) + }) }) diff --git a/tests/testthat/test-manipulate_widget.R b/tests/testthat/test-manipulate_widget.R new file mode 100644 index 0000000..3195fa1 --- /dev/null +++ b/tests/testthat/test-manipulate_widget.R @@ -0,0 +1,81 @@ +context("manipulateWidget") + +describe("manipulateWidget", { + 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" + ) + 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) + ) + 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")) + ) + 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) + ) + 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) + ) + 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) + ) + expect_true(c$isVisible("y")) + c$setValue("x", 6) + expect_true(!c$isVisible("y")) + }) +}) diff --git a/tests/testthat/test-on_done.R b/tests/testthat/test-on_done.R index 91deb7d..0bac663 100644 --- a/tests/testthat/test-on_done.R +++ b/tests/testthat/test-on_done.R @@ -10,7 +10,7 @@ describe("onDone", { { inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3))) expr <- expression(combineWidgets(paste(x1, x2))) - controller <- Controller(expr, inputs) + controller <- MWController(expr, inputs) expect_output(res <- onDone(controller), "Stop gadget") expect_is(res, "htmlwidget") @@ -31,7 +31,7 @@ describe("onDone", { inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)), compare = compare, ncharts = 3) expr <- expression(paste(x1, x2)) - controller <- Controller(expr, inputs) + controller <- MWController(expr, inputs) expect_output(res <- onDone(controller), "Stop gadget") expect_is(res, "combineWidgets") expect_equal(length(res$widgets), 3) From 863e634af77e0e35324059f50e6165bc4b509ed5 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Mon, 31 Jul 2017 21:34:53 +0200 Subject: [PATCH 032/101] Reduce number of input updates by identifying dependencies between inputs --- R/controller.R | 5 +-- R/input_class.R | 7 ++- R/input_list_class.R | 62 ++++++++++++++++++-------- R/manipulate_widget.R | 2 +- tests/testthat/test-input_list_class.R | 12 ++++- 5 files changed, 62 insertions(+), 26 deletions(-) diff --git a/R/controller.R b/R/controller.R index 16355a0..e54dc6b 100644 --- a/R/controller.R +++ b/R/controller.R @@ -84,7 +84,7 @@ MWController <- setRefClass( }, getValueById = function(id) { - inputList$getValueById(id) + inputList$getValue(inputId = id) }, setValue = function(name, value, chartId = 1) { @@ -98,9 +98,8 @@ MWController <- setRefClass( }, setValueById = function(id, value) { - catIfDebug("Update value of input", id) oldValue <- getValueById(id) - newValue <- inputList$setValueById(id, value) + newValue <- inputList$setValue(inputId = id, value = value) if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { if (grepl("^shared_", id)) updateCharts() else { diff --git a/R/input_class.R b/R/input_class.R index 628e540..266e168 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -11,7 +11,7 @@ Input <- setRefClass( "Input", fields = c("type", "name", "idFunc", "label", "value", "display", "params", "env", "validFunc", "htmlFunc", "htmlUpdateFunc", - "lastParams", "changedParams", "valueHasChanged"), + "lastParams", "changedParams", "valueHasChanged", "deps"), methods = list( init = function(name, env) { @@ -20,6 +20,7 @@ Input <- setRefClass( env <<- env valueHasChanged <<- FALSE changedParams <<- list() + deps <<- character() if (emptyField(label) || is.null(label)) label <<- name if (emptyField(idFunc)) { idFunc <<- function(oid, name) paste(oid, name, sep = "_") @@ -35,6 +36,7 @@ Input <- setRefClass( setValue = function(newValue) { "Modify value of the input. If newValue is invalid, it sets a valid value" + catIfDebug("Set value of ", getID()) if (!emptyField(validFunc)) value <<- validFunc(newValue, getParams()) assign(name, value, envir = env) value @@ -42,6 +44,7 @@ Input <- setRefClass( updateValue = function() { "Update value after a change in environment" + catIfDebug("Update value of ", getID()) oldValue <- value if (!emptyField(validFunc)) value <<- validFunc(value, getParams()) if (!isTRUE(all.equal(value, oldValue))) { @@ -85,6 +88,7 @@ Input <- setRefClass( "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 htmlParams$session <- session @@ -92,7 +96,6 @@ Input <- setRefClass( do.call(htmlUpdateFunc, htmlParams) valueHasChanged <<- FALSE changedParams <<- list() - catIfDebug("Update HTML of ", getID(), "\n") } }, diff --git a/R/input_list_class.R b/R/input_list_class.R index abd3bca..b9f82dc 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -14,6 +14,16 @@ InputList <- setRefClass( names <<- sapply(inputList, function(x) x$name) chartIds <<- sapply(inputList, function(x) get(".id", envir = x$env)) session <<- session + + # Set dependencies + for (input in inputList) { + inputId <- input$getID() + revdeps <- getRevDeps(input) + for (d in revdeps) { + inputs[[d]]$deps <<- c(inputList[[d]]$deps, inputId) + } + } + update() }, @@ -28,18 +38,28 @@ InputList <- setRefClass( eval(i$display, envir = i$env) }, - getInput = function(name, chartId = 1) { - idx <- which(names == name & chartIds %in% c(0, chartId)) - if (length(idx) == 0) stop("cannot find input ", name) - inputs[[idx]] + getRevDeps = function(input) { + deps <- c() + for (p in input$params) { + f <- function() {} + body(f) <- p + deps <- union(deps, codetools::findGlobals(f, merge = FALSE)$variables) + } + names(inputs)[names %in% deps] }, - getValue = function(name, chartId = 1) { - getInput(name, chartId)$value + 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]] }, - getValueById = function(inputId) { - inputs[[inputId]]$value + getValue = function(name, chartId = 1, inputId = NULL) { + getInput(name, chartId, inputId)$value }, getValues = function(chartId = 1) { @@ -49,20 +69,21 @@ InputList <- setRefClass( res }, - setValue = function(name, value, chartId = 1) { - res <- getInput(name, chartId)$setValue(value) - update() + setValue = function(name, value, chartId = 1, inputId = NULL) { + input <- getInput(name, chartId, inputId) + res <- input$setValue(value) + updateDeps(input) res }, - setValueById = function(inputId, value) { - "Change the value of an input and update the other inputs - args: - - inputId: id of the input to update - - value: new value for the input" - res <- inputs[[inputId]]$setValue(value) - update() - res + updateDeps = function(input) { + for (inputId in input$deps) { + depInput <- getInput(inputId = inputId) + if(!isTRUE(all.equal(depInput$value, depInput$updateValue()))) { + updateDeps(depInput) + } + } + updateHTML() }, update = function() { @@ -76,7 +97,10 @@ InputList <- setRefClass( }) if (all(!valueHasChanged) | n > 10) break } + updateHTML() + }, + updateHTML = function() { if (!is.null(session)) { for (input in inputs) { shiny::updateCheckboxInput( diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 4ace231..35b77d4 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -297,7 +297,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, message("Click on the 'OK' button to return to the R session.") lapply(names(controller$inputList$inputs), function(id) { - observe(controller$setValueById(id, input[[id]])) + observe(controller$setValueById(id, value = input[[id]])) }) observeEvent(input$.update, controller$updateCharts()) diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R index ff85bff..db8887e 100644 --- a/tests/testthat/test-input_list_class.R +++ b/tests/testthat/test-input_list_class.R @@ -8,10 +8,20 @@ describe("InputList", { expect_equal(inputList$inputs$output_1_y$value, 5) - inputList$setValueById("output_1_x", 7) + 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)) + inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1)) + inputList <- InputList(inputs) + expect_length(inputList$getRevDeps(inputList$inputs$output_1_x), 0) + expect_length(inputList$inputs$output_1_y$deps, 0) + expect_equal(inputList$getRevDeps(inputList$inputs$output_1_y), c("output_1_x")) + expect_equal(inputList$inputs$output_1_x$deps, "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( From c4317ab30a96ad51a3fde20385337538e83ab193 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 1 Aug 2017 10:00:28 +0200 Subject: [PATCH 033/101] Add new input mwSharedValue --- NAMESPACE | 1 + R/inputs.R | 56 +++++++++++++++++++++++- man/mwCheckbox.Rd | 4 +- man/mwCheckboxGroup.Rd | 4 +- man/mwDate.Rd | 4 +- man/mwDateRange.Rd | 6 +-- man/mwGroup.Rd | 6 +-- man/mwNumeric.Rd | 4 +- man/mwPassword.Rd | 4 +- man/mwRadio.Rd | 4 +- man/mwSelect.Rd | 4 +- man/mwSharedValue.Rd | 57 +++++++++++++++++++++++++ man/mwSlider.Rd | 2 +- man/mwText.Rd | 2 +- tests/testthat/test-manipulate_widget.R | 16 +++++++ 15 files changed, 150 insertions(+), 24 deletions(-) create mode 100644 man/mwSharedValue.Rd diff --git a/NAMESPACE b/NAMESPACE index 8c757d3..b417a0f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ export(mwNumeric) export(mwPassword) export(mwRadio) export(mwSelect) +export(mwSharedValue) export(mwSlider) export(mwText) export(renderCombineWidgets) diff --git a/R/inputs.R b/R/inputs.R index d761799..bb6fa3a 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -414,7 +414,7 @@ mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) { #' @inheritParams mwSlider #' #' @return -#' A function that will generate the input control. +#' An Input object #' #' @examples #' if (require(dygraphs) && require(xts)) { @@ -510,6 +510,58 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = ) } +#' 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. +#' 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) { + params <- list(expr = lazyeval::expr_find(expr)) + Input( + type = "sharedValue", value = NULL, label = NULL, params = params, + display = FALSE, + validFunc = function(x, params) { + params$expr + } + ) +} + #' Group inputs in a collapsible box #' #' This function generates a collapsible box containing inputs. It can be useful @@ -519,7 +571,7 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = #' @param .display expression that evaluates to TRUE or FALSE, indicating when #' the group should be shown/hidden. #' -#' @return List of inputs +#' @return Input of type "group". #' #' @examples #' if(require(dygraphs)) { diff --git a/man/mwCheckbox.Rd b/man/mwCheckbox.Rd index 846cd75..21437ed 100644 --- a/man/mwCheckbox.Rd +++ b/man/mwCheckbox.Rd @@ -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 ae7fc93..a9bdfa1 100644 --- a/man/mwCheckboxGroup.Rd +++ b/man/mwCheckboxGroup.Rd @@ -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 58125b0..424e6ac 100644 --- a/man/mwDate.Rd +++ b/man/mwDate.Rd @@ -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 f99f315..8c2bc12 100644 --- a/man/mwDateRange.Rd +++ b/man/mwDateRange.Rd @@ -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 0e3cde3..de27d13 100644 --- a/man/mwGroup.Rd +++ b/man/mwGroup.Rd @@ -13,7 +13,7 @@ mwGroup(..., .display = TRUE) the group should be shown/hidden.} } \value{ -List of inputs +Input of type "group". } \description{ This function generates a collapsible box containing inputs. It can be useful @@ -40,6 +40,6 @@ 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}} + \code{\link{mwSelect}}, \code{\link{mwSharedValue}}, + \code{\link{mwSlider}}, \code{\link{mwText}} } diff --git a/man/mwNumeric.Rd b/man/mwNumeric.Rd index 0db2de9..e8721da 100644 --- a/man/mwNumeric.Rd +++ b/man/mwNumeric.Rd @@ -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 567938f..b8b41d2 100644 --- a/man/mwPassword.Rd +++ b/man/mwPassword.Rd @@ -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 de9e7f6..91fa8ca 100644 --- a/man/mwRadio.Rd +++ b/man/mwRadio.Rd @@ -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 9287a25..b8125c3 100644 --- a/man/mwSelect.Rd +++ b/man/mwSelect.Rd @@ -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..2001fe7 --- /dev/null +++ b/man/mwSharedValue.Rd @@ -0,0 +1,57 @@ +% 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) +} +\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. + 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 ace6622..7d2adbe 100644 --- a/man/mwSlider.Rd +++ b/man/mwSlider.Rd @@ -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 a405fd7..0da8287 100644 --- a/man/mwText.Rd +++ b/man/mwText.Rd @@ -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/tests/testthat/test-manipulate_widget.R b/tests/testthat/test-manipulate_widget.R index 3195fa1..334d88d 100644 --- a/tests/testthat/test-manipulate_widget.R +++ b/tests/testthat/test-manipulate_widget.R @@ -78,4 +78,20 @@ describe("manipulateWidget", { 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) + ) + 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) + + }) }) From 0f95d3813cee249d78f58e8f0b19b4e39ced93a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 1 Aug 2017 10:42:41 +0200 Subject: [PATCH 034/101] Fix example of mwSharedValue --- R/inputs.R | 2 ++ man/mwSharedValue.Rd | 2 ++ 2 files changed, 4 insertions(+) diff --git a/R/inputs.R b/R/inputs.R index bb6fa3a..865f9d7 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -526,6 +526,8 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = #' # 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 diff --git a/man/mwSharedValue.Rd b/man/mwSharedValue.Rd index 2001fe7..c276993 100644 --- a/man/mwSharedValue.Rd +++ b/man/mwSharedValue.Rd @@ -23,6 +23,8 @@ if (require(plotly)) { # 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 From c2c47525e2b7f734a37f361c0bc857a69796fc53 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 1 Aug 2017 11:43:35 +0200 Subject: [PATCH 035/101] Add saveButon --- R/manipulateWidget.R | 6 ++++-- R/mwServer.R | 11 +++++++++++ R/mwServer_helpers.R | 18 ++++++++++++++++++ R/mwUI.R | 19 ++++++++++++++----- man/manipulateWidget.Rd | 10 ++++++---- 5 files changed, 53 insertions(+), 11 deletions(-) diff --git a/R/manipulateWidget.R b/R/manipulateWidget.R index be67e9e..04929ca 100644 --- a/R/manipulateWidget.R +++ b/R/manipulateWidget.R @@ -25,6 +25,7 @@ #' @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 .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. @@ -212,7 +213,7 @@ #' #' @export #' -manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, +manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, .viewer = c("pane", "window", "browser"), .compare = NULL, .compareOpts = compareOptions(), @@ -268,7 +269,8 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, 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) + updateBtn = .updateBtn, saveBtn = .saveBtn, + areaBtns = length(.compare) > 0, border = isRuntimeShiny) server <- mwServer(.expr, controls, initWidgets, renderFunction, .updateBtn, diff --git a/R/mwServer.R b/R/mwServer.R index 60a3217..d12bc5a 100644 --- a/R/mwServer.R +++ b/R/mwServer.R @@ -75,5 +75,16 @@ mwServer <- function(.expr, controls, widgets, } observeEvent(input$done, onDone(.expr, controls, .return, nrow, ncol)) + + # save + output$save <- downloadHandler( + filename = function() { + paste('mpWidget-', Sys.Date(), '.html', sep='') + }, + content = function(con) { + htmlwidgets::saveWidget(widget = onSave(.expr, controls, .return, nrow, ncol), + file = con, selfcontained = TRUE) + } + ) } } diff --git a/R/mwServer_helpers.R b/R/mwServer_helpers.R index 2eac373..ec4a5d5 100644 --- a/R/mwServer_helpers.R +++ b/R/mwServer_helpers.R @@ -118,3 +118,21 @@ mwReturn <- function(widgets, .return, envs, nrow = NULL, ncol = NULL) { } .return(finalWidget, envs) } + +#' Function called when user clicks on the "Save" button. It saves the final htmlwidget +#' +#' @param .expr Expression that generates a htmlwidget +#' @param controls Object created with function preprocessControls +#' +#' @return a htmlwidget +#' @noRd +onSave <- 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) + }) + + mwReturn(widgets, .return, controls$env$ind, nrow, ncol) +} + diff --git a/R/mwUI.R b/R/mwUI.R index 0145b95..ec99a3c 100644 --- a/R/mwUI.R +++ b/R/mwUI.R @@ -6,13 +6,14 @@ #' @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. #' #' @return shiny tags #' #' @noRd mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, - okBtn = TRUE, updateBtn = FALSE, areaBtns = TRUE, border = FALSE) { + okBtn = TRUE, saveBtn = TRUE, updateBtn = FALSE, areaBtns = TRUE, border = FALSE) { htmldep <- htmltools::htmlDependency( "manipulateWidget", @@ -31,7 +32,7 @@ mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, class = class, fillRow( flex = c(NA, NA, 1), - .uiMenu(controls$nmod, nrow, ncol, showSettings, okBtn, updateBtn, areaBtns), + .uiMenu(controls$nmod, nrow, ncol, showSettings, okBtn, saveBtn, updateBtn, areaBtns), .uiControls(controls), .uiChartarea(controls$nmod, nrow, ncol, outputFun) ) @@ -72,7 +73,7 @@ mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, do.call(shiny::fillCol, unname(rows)) } -.uiMenu <- function(ncharts, nrow, ncol, settingsBtn, okBtn, updateBtn, areaBtns) { +.uiMenu <- function(ncharts, nrow, ncol, settingsBtn, okBtn, saveBtn, updateBtn, areaBtns) { container <- tags$div( class="mw-menu" ) @@ -102,9 +103,17 @@ mwUI <- function(controls, nrow = 1, ncol = 1, outputFun = NULL, } if (okBtn) { - okBtn <- shiny::actionButton("done", "OK", class = "mw-btn mw-btn-ok") - container <- tagAppendChild(container, okBtn) + okBtnInput <- shiny::actionButton("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("save", label = "", class = "mw-btn mw-btn-ok", + style = bottom_px) + container <- tagAppendChild(container, saveBtnInput) + } + container } diff --git a/man/manipulateWidget.Rd b/man/manipulateWidget.Rd index e65918f..0e565f1 100644 --- a/man/manipulateWidget.Rd +++ b/man/manipulateWidget.Rd @@ -4,10 +4,10 @@ \alias{manipulateWidget} \title{Add Controls to Interactive Plots} \usage{ -manipulateWidget(.expr, ..., .updateBtn = FALSE, .viewer = c("pane", - "window", "browser"), .compare = NULL, .compareOpts = compareOptions(), - .return = function(widget, envs) { widget }, .width = NULL, - .height = NULL) +manipulateWidget(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, + .viewer = c("pane", "window", "browser"), .compare = NULL, + .compareOpts = compareOptions(), .return = function(widget, envs) { + widget }, .width = NULL, .height = NULL) } \arguments{ \item{.expr}{expression to evaluate that returns an interactive plot of class @@ -26,6 +26,8 @@ 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{.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.} From 38936f879c0313e5f0651eafd8675891c96d518e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 1 Aug 2017 14:14:20 +0200 Subject: [PATCH 036/101] Correct a few problems detected by R CMD CHECK --- R/manipulate_widget.R | 2 +- R/mwServer.R | 90 --------------------------- R/mwServer_helpers.R | 138 ------------------------------------------ 3 files changed, 1 insertion(+), 229 deletions(-) delete mode 100644 R/mwServer.R delete mode 100644 R/mwServer_helpers.R diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 2e5e18d..0ee96e7 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -300,7 +300,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, observeEvent(input$.update, controller$updateCharts()) observeEvent(input$done, onDone(controller)) - output$save <- downloadHandler( + output$save <- shiny::downloadHandler( filename = function() { paste('mpWidget-', Sys.Date(), '.html', sep='') }, diff --git a/R/mwServer.R b/R/mwServer.R deleted file mode 100644 index d12bc5a..0000000 --- a/R/mwServer.R +++ /dev/null @@ -1,90 +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)) - - # save - output$save <- downloadHandler( - filename = function() { - paste('mpWidget-', Sys.Date(), '.html', sep='') - }, - content = function(con) { - htmlwidgets::saveWidget(widget = onSave(.expr, controls, .return, nrow, ncol), - file = con, selfcontained = TRUE) - } - ) - } -} diff --git a/R/mwServer_helpers.R b/R/mwServer_helpers.R deleted file mode 100644 index ec4a5d5..0000000 --- a/R/mwServer_helpers.R +++ /dev/null @@ -1,138 +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) -} - -#' Function called when user clicks on the "Save" button. It saves the final htmlwidget -#' -#' @param .expr Expression that generates a htmlwidget -#' @param controls Object created with function preprocessControls -#' -#' @return a htmlwidget -#' @noRd -onSave <- 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) - }) - - mwReturn(widgets, .return, controls$env$ind, nrow, ncol) -} - From 0c2747528476db7738fb596d7a01350980cfa54e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 1 Aug 2017 15:07:21 +0200 Subject: [PATCH 037/101] Controller class has new methods to get shiny server and ui functions --- R/controller.R | 49 ++++++++++++++++++++++++++++---- R/input_class.R | 2 +- R/manipulate_widget.R | 35 ++++------------------- tests/testthat/test-controller.R | 11 +++++++ 4 files changed, 60 insertions(+), 37 deletions(-) diff --git a/R/controller.R b/R/controller.R index e54dc6b..99a6c4e 100644 --- a/R/controller.R +++ b/R/controller.R @@ -46,8 +46,8 @@ #' @export MWController <- setRefClass( "MWController", - fields = c("inputList", "envs", "session", "output", "expr", "ncharts", "charts", - "autoUpdate", "renderFunc", "useCombineWidgets", "nrow", "ncol", + fields = c("inputList", "uiSpec", "envs", "session", "shinyOutput", "expr", "ncharts", "charts", + "autoUpdate", "renderFunc", "outputFunc", "useCombineWidgets", "nrow", "ncol", "returnFunc"), methods = list( @@ -55,12 +55,13 @@ MWController <- setRefClass( ncol = NULL, returnFunc = function(widget, envs) {widget}) { expr <<- expr inputList <<- inputs$inputList + uiSpec <<- inputs ncharts <<- inputs$ncharts envs <<- inputs$envs$ind autoUpdate <<- autoUpdate renderFunc <<- NULL session <<- NULL - output <<- NULL + shinyOutput <<- NULL useCombineWidgets <<- FALSE nrow <<- nrow ncol <<- ncol @@ -70,7 +71,7 @@ MWController <- setRefClass( setShinySession = function(output, session) { session <<- session - output <<- output + shinyOutput <<- output inputList$session <<- session for (env in envs) { assign(".initial", FALSE, envir = env) @@ -153,10 +154,10 @@ MWController <- setRefClass( }, renderShinyOutput = function(chartId) { - if (!is.null(renderFunc) & !is.null(output) & + if (!is.null(renderFunc) & !is.null(shinyOutput) & is(charts[[chartId]], "htmlwidget")) { outputId <- get(".output", envir = envs[[chartId]]) - output[[outputId]] <<- renderFunc(charts[[chartId]]) + shinyOutput[[outputId]] <<- renderFunc(charts[[chartId]]) } }, @@ -193,6 +194,42 @@ MWController <- setRefClass( res$charts <- charts res$useCombineWidgets <- useCombineWidgets res + }, + + getModuleUI = function(gadget = TRUE, saveBtn = TRUE, addBorder = !gadget) { + function(id) { + ns <- shiny::NS(id) + mwUI(uiSpec, nrow, ncol, outputFunc, + okBtn = gadget, updateBtn = !autoUpdate, saveBtn = saveBtn, + areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder) + } + }, + + getModuleServer = function() { + function(input, output, session, ...) { + controller <- .self$clone() + controller$setShinySession(output, session) + controller$renderShinyOutputs() + + message("Click on the 'OK' button to return to the R session.") + + lapply(names(controller$inputList$inputs), function(id) { + observe(controller$setValueById(id, value = input[[id]])) + }) + + observeEvent(input$.update, controller$updateCharts()) + 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) + } + ) + } } ) ) diff --git a/R/input_class.R b/R/input_class.R index 266e168..9c78902 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -75,7 +75,7 @@ Input <- setRefClass( id <- getID() shiny::conditionalPanel( - condition = sprintf("input.%s_visible", id), + condition = sprintf("input['%s_visible']", id), tags$div( style="display:none;", shiny::checkboxInput(paste0(id, "_visible"), "", value = TRUE) diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 0ee96e7..5362cc1 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -277,39 +277,14 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, } controller$renderFunc <- renderFunction + controller$outputFunc <- outputFunction if (useCombineWidgets) { controller$useCombineWidgets <- TRUE controller$charts <- lapply(controller$charts, combineWidgets) } - ui <- mwUI(inputs, dims$nrow, dims$ncol, outputFunction, - okBtn = !isRuntimeShiny, updateBtn = .updateBtn, saveBtn = .saveBtn, - areaBtns = length(.compare) > 0, border = isRuntimeShiny) - - server <- function(input, output, session) { - controller <- controller$clone() - controller$setShinySession(output, session) - controller$renderShinyOutputs() - - message("Click on the 'OK' button to return to the R session.") - - lapply(names(controller$inputList$inputs), function(id) { - observe(controller$setValueById(id, value = input[[id]])) - }) - - observeEvent(input$.update, controller$updateCharts()) - 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) - } - ) - } + ui <- controller$getModuleUI(gadget = !isRuntimeShiny, saveBtn = .saveBtn) + server <- controller$getModuleServer() if (.runApp & interactive()) { # We are in an interactive session so we start a shiny gadget @@ -319,10 +294,10 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, window = shiny::dialogViewer("manipulateWidget"), browser = shiny::browserViewer() ) - shiny::runGadget(ui, server, viewer = .viewer) + shiny::runGadget(ui("ui"), server, viewer = .viewer) } else if (.runApp & isRuntimeShiny) { # We are in Rmarkdown document with shiny runtime. So we start a shiny app - shiny::shinyApp(ui = ui, server = server, options = list(width = .width, height = .height)) + shiny::shinyApp(ui = 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. diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index 7e604f4..ec8eec5 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -50,4 +50,15 @@ describe("MWController", { controller <- MWController(expr, inputs) 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) + ui <- controller$getModuleUI() + server <- controller$getModuleServer() + expect_is(ui, "function") + expect_is(server, "function") + expect_equal(names(formals(server)), c("input", "output", "session", "...")) + }) }) From 7dfee49517a35699677e590971292429837c0b49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 1 Aug 2017 17:27:06 +0200 Subject: [PATCH 038/101] It is now possible to create shiny modules with manipulateWidget --- R/controller.R | 2 +- R/input_class.R | 5 ++-- R/inputs.R | 9 +++---- R/manipulate_widget.R | 18 ++++++++++---- R/mw_ui.R | 26 +++++++++++---------- inst/manipulate_widget/manipulate_widget.js | 3 ++- 6 files changed, 39 insertions(+), 24 deletions(-) diff --git a/R/controller.R b/R/controller.R index 99a6c4e..52f2c95 100644 --- a/R/controller.R +++ b/R/controller.R @@ -199,7 +199,7 @@ MWController <- setRefClass( getModuleUI = function(gadget = TRUE, saveBtn = TRUE, addBorder = !gadget) { function(id) { ns <- shiny::NS(id) - mwUI(uiSpec, nrow, ncol, outputFunc, + mwUI(ns, uiSpec, nrow, ncol, outputFunc, okBtn = gadget, updateBtn = !autoUpdate, saveBtn = saveBtn, areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder) } diff --git a/R/input_class.R b/R/input_class.R index 9c78902..14a5bb5 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -69,18 +69,19 @@ Input <- setRefClass( lastParams }, - getHTML = function() { + 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 = TRUE) ), - htmlFunc(getID(), label, value, lastParams) + htmlFunc(id, label, value, lastParams, ns) ) }, diff --git a/R/inputs.R b/R/inputs.R index 865f9d7..79733ba 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -10,7 +10,7 @@ #' shiny tag. #' @noRd htmlFuncFactory <- function(func, valueArgName = "value") { - function(id, label, value, params) { + function(id, label, value, params, ns = NULL) { params$inputId <- id params$label <- label params[[valueArgName]] <- value @@ -445,7 +445,7 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ... 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) { + htmlFunc = function(id, label, value, params, ns) { params$inputId <- id params$label <- label params$start <- value[[1]] @@ -600,8 +600,9 @@ mwGroup <- function(..., .display = TRUE) { Input( type = "group", value = list(...), params = list(), display = lazyeval::expr_find(.display), - htmlFunc = function(id, label, value, params) { - htmlElements <- lapply(value, function(x) x$getHTML()) + htmlFunc = function(id, label, value, params, ns) { + browser() + htmlElements <- lapply(value, function(x) x$getHTML(ns)) tags$div( class="panel panel-default", diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 5362cc1..b78e4c0 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -283,8 +283,8 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, controller$charts <- lapply(controller$charts, combineWidgets) } - ui <- controller$getModuleUI(gadget = !isRuntimeShiny, saveBtn = .saveBtn) - server <- controller$getModuleServer() + mwModuleInput <- controller$getModuleUI(gadget = !isRuntimeShiny, saveBtn = .saveBtn) + mwModule <- controller$getModuleServer() if (.runApp & interactive()) { # We are in an interactive session so we start a shiny gadget @@ -294,10 +294,20 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, window = shiny::dialogViewer("manipulateWidget"), browser = shiny::browserViewer() ) - shiny::runGadget(ui("ui"), server, viewer = .viewer) + + ui <- mwModuleInput("ui") + server <- function(input, output, session, ...) { + controller <- shiny::callModule(mwModule, "ui") + } + + shiny::runGadget(ui, server, viewer = .viewer) } else if (.runApp & isRuntimeShiny) { # We are in Rmarkdown document with shiny runtime. So we start a shiny app - shiny::shinyApp(ui = ui("ui"), server = server, options = list(width = .width, height = .height)) + ui <- mwModuleInput("ui") + server <- function(input, output, session, ...) { + controller <- shiny::callModule(mwModule, "ui") + } + 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. diff --git a/R/mw_ui.R b/R/mw_ui.R index 255184c..bb5749b 100644 --- a/R/mw_ui.R +++ b/R/mw_ui.R @@ -1,5 +1,7 @@ #' 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. @@ -12,7 +14,7 @@ #' @return shiny tags #' #' @noRd -mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, +mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL, okBtn = TRUE, saveBtn = TRUE, updateBtn = FALSE, areaBtns = TRUE, border = FALSE) { htmldep <- htmltools::htmlDependency( @@ -32,9 +34,9 @@ mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, class = class, fillRow( flex = c(NA, NA, 1), - .uiMenu(inputs$ncharts, nrow, ncol, showSettings, okBtn, saveBtn, updateBtn, areaBtns), - .uiInputs(inputs), - .uiChartarea(inputs$ncharts, nrow, ncol, outputFun) + .uiMenu(ns, inputs$ncharts, nrow, ncol, showSettings, okBtn, saveBtn, updateBtn, areaBtns), + .uiInputs(ns, inputs), + .uiChartarea(ns, inputs$ncharts, nrow, ncol, outputFun) ) ) ) @@ -42,11 +44,11 @@ mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, htmltools::attachDependencies(container, htmldep, TRUE) } -.uiInputs <- function(inputs) { +.uiInputs <- function(ns, inputs) { inputs <- c(list(inputs$inputs$shared), inputs$inputs$ind) inputs <- unname(lapply(inputs, function(x) { if (length(x) == 0) return(NULL) - content <- lapply(x, function(i) i$getHTML()) + content <- lapply(x, function(i) i$getHTML(ns)) tags$div(class = "mw-inputs", shiny::tagList(content)) })) @@ -54,10 +56,10 @@ mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, do.call(tags$div, inputs) } -.uiChartarea <- function(ncharts, nrow, ncol, outputFun) { +.uiChartarea <- function(ns, ncharts, nrow, ncol, outputFun) { outputEls <- lapply(seq_len(nrow * ncol), function(i) { if (i > ncharts) return(tags$div()) - outputId <- paste0("output_", i) + outputId <- ns(paste0("output_", i)) if (is.null(outputFun)) { el <- combineWidgetsOutput(outputId, width = "100%", height = "100%") } else { @@ -74,7 +76,7 @@ mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, ) } -.uiMenu <- function(ncharts, nrow, ncol, settingsBtn, okBtn, saveBtn, updateBtn, areaBtns) { +.uiMenu <- function(ns, ncharts, nrow, ncol, settingsBtn, okBtn, saveBtn, updateBtn, areaBtns) { container <- tags$div( class="mw-menu" ) @@ -98,19 +100,19 @@ mwUI <- function(inputs, nrow = 1, ncol = 1, outputFun = NULL, if (updateBtn) { updateBtn <- tags$div( class = "mw-btn mw-btn-update", - shiny::actionButton(".update", "", icon = shiny::icon("refresh"), class = "bt1") + shiny::actionButton(ns(".update"), "", icon = shiny::icon("refresh"), class = "bt1") ) container <- tagAppendChild(container, updateBtn) } if (okBtn) { - okBtnInput <- shiny::actionButton("done", "OK", class = "mw-btn mw-btn-ok") + 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("save", label = "", class = "mw-btn mw-btn-ok", + saveBtnInput <- shiny::downloadButton(ns("save"), label = "", class = "mw-btn mw-btn-ok", style = bottom_px) container <- tagAppendChild(container, saveBtnInput) } diff --git a/inst/manipulate_widget/manipulate_widget.js b/inst/manipulate_widget/manipulate_widget.js index 9622855..cd14693 100644 --- a/inst/manipulate_widget/manipulate_widget.js +++ b/inst/manipulate_widget/manipulate_widget.js @@ -19,10 +19,11 @@ function select(e) { // 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]); HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]); } } From 84823fa144c3c0dc7084d2a935df55b6ae509673 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Wed, 2 Aug 2017 14:32:01 +0200 Subject: [PATCH 039/101] Remove dependency to lazyeval which causes more problems that the ones it solves ! --- DESCRIPTION | 1 - R/inputs.R | 65 ++++++++++++++++++++++++++++------------------------- 2 files changed, 35 insertions(+), 31 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index fcbd032..34a2c9c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,7 +21,6 @@ Imports: miniUI, htmltools, htmlwidgets, - lazyeval, knitr, methods, tools, diff --git a/R/inputs.R b/R/inputs.R index 79733ba..2788451 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -1,3 +1,10 @@ +#' 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. #' @@ -74,13 +81,13 @@ changeValueParam <- function(func, valueArgName) { #' @export #' @family controls mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...,.follow_symbols = FALSE), function(x) x$expr) - params$min <- lazyeval::expr_find(min) - params$max <- lazyeval::expr_find(max) + params <- dotsToExpr() + params$min <- substitute(min) + params$max <- substitute(max) Input( type = "slider", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { pmin(pmax(params$min, x), params$max) }, @@ -116,10 +123,10 @@ mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) { #' @export #' @family controls mwText <- function(value = "", label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + params <- dotsToExpr() Input( type = "text", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { if(length(x) == 0) return("") as.character(x)[1] @@ -155,10 +162,10 @@ mwText <- function(value = "", label = NULL, ..., .display = TRUE) { #' @export #' @family controls mwNumeric <- function(value, label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + params <- dotsToExpr() Input( type = "numeric", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { min(max(params$min, x), params$max) }, @@ -197,10 +204,10 @@ mwNumeric <- function(value, label = NULL, ..., .display = TRUE) { #' @export #' @family controls mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + params <- dotsToExpr() Input( type = "password", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { if(length(x) == 0) return("") as.character(x)[1] @@ -257,14 +264,13 @@ mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) { #' @family controls mwSelect <- function(choices = value, value = NULL, label = NULL, ..., multiple = FALSE, .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), - function(x) x$expr) - params$choices <- lazyeval::expr_find(choices) - params$multiple <- lazyeval::expr_find(multiple) + params <- dotsToExpr() + params$choices <- substitute(choices) + params$multiple <- substitute(multiple) Input( type = "select", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { x <- intersect(x, params$choices) if (params$multiple) return(x) @@ -303,10 +309,10 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., #' @export #' @family controls mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + params <- dotsToExpr() Input( type = "checkbox", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { if (is.null(x)) return(FALSE) x <- as.logical(x) @@ -348,11 +354,11 @@ mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) { #' @export #' @family controls mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) - params$choices <- lazyeval::expr_find(choices) + params <- dotsToExpr() + params$choices <- substitute(choices) Input( type = "radio", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { if (length(params$choices) == 0) return(NULL) if (is.null(x) || !x %in% params$choices) return(params$choices[[1]]) @@ -388,10 +394,10 @@ mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) { #' @export #' @family controls mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + params <- dotsToExpr() Input( type = "date", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { if (length(x) == 0) x <- Sys.Date() x <- as.Date(x) @@ -431,10 +437,10 @@ mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) { #' @family controls mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), function(x) x$expr) + params <- dotsToExpr() Input( type = "dateRange", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + 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()) @@ -495,13 +501,12 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ... #' @export #' @family controls mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = TRUE) { - params <- lapply(lazyeval::lazy_dots(...), - function(x) x$expr) - params$choices <- lazyeval::expr_find(choices) + params <- dotsToExpr() + params$choices <- substitute(choices) Input( type = "checkboxGroup", value = value, label = label, params = params, - display = lazyeval::expr_find(.display), + display = substitute(.display), validFunc = function(x, params) { intersect(x, params$choices) }, @@ -554,7 +559,7 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = #' @export #' @family controls mwSharedValue <- function(expr) { - params <- list(expr = lazyeval::expr_find(expr)) + params <- list(expr = substitute(expr)) Input( type = "sharedValue", value = NULL, label = NULL, params = params, display = FALSE, @@ -599,7 +604,7 @@ mwGroup <- function(..., .display = TRUE) { Input( type = "group", value = list(...), params = list(), - display = lazyeval::expr_find(.display), + display = substitute(.display), htmlFunc = function(id, label, value, params, ns) { browser() htmlElements <- lapply(value, function(x) x$getHTML(ns)) From da7df5933c706d384d18d98a6937f4b0143601a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Wed, 2 Aug 2017 17:24:06 +0200 Subject: [PATCH 040/101] BUGFIX: InputList class did not detect multiple dependencies to a single input --- R/input_list_class.R | 2 +- R/inputs.R | 1 - tests/testthat/test-input_list_class.R | 9 +++++++-- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/R/input_list_class.R b/R/input_list_class.R index b9f82dc..244b4a3 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -20,7 +20,7 @@ InputList <- setRefClass( inputId <- input$getID() revdeps <- getRevDeps(input) for (d in revdeps) { - inputs[[d]]$deps <<- c(inputList[[d]]$deps, inputId) + inputs[[d]]$deps <<- c(.self$inputs[[d]]$deps, inputId) } } diff --git a/R/inputs.R b/R/inputs.R index 2788451..f670fa3 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -606,7 +606,6 @@ mwGroup <- function(..., .display = TRUE) { type = "group", value = list(...), params = list(), display = substitute(.display), htmlFunc = function(id, label, value, params, ns) { - browser() htmlElements <- lapply(value, function(x) x$getHTML(ns)) tags$div( diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R index db8887e..7e88f14 100644 --- a/tests/testthat/test-input_list_class.R +++ b/tests/testthat/test-input_list_class.R @@ -13,13 +13,18 @@ describe("InputList", { }) it("detects dependencies between inputs", { - inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(x, 10, 0)) + inputs <- list( + x = mwSlider(0, 10, 5), + y = mwSlider(x, 10, 0), + z = mwSlider(0, x, 0) + ) inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1)) inputList <- InputList(inputs) expect_length(inputList$getRevDeps(inputList$inputs$output_1_x), 0) expect_length(inputList$inputs$output_1_y$deps, 0) expect_equal(inputList$getRevDeps(inputList$inputs$output_1_y), c("output_1_x")) - expect_equal(inputList$inputs$output_1_x$deps, "output_1_y") + expect_equal(inputList$inputs$output_1_x$deps, + c("output_1_y", "output_1_z")) }) inputs <- list(x = mwSlider(0, 10, 5), y = mwSlider(0, 10, 0)) From dff439452379b63b7fcde95f2f519915980ff080 Mon Sep 17 00:00:00 2001 From: cuche27 Date: Wed, 2 Aug 2017 23:04:58 +0200 Subject: [PATCH 041/101] Modify only visibility of dependants inputs --- R/input_class.R | 6 ++- R/input_list_class.R | 74 +++++++++++++++++--------- tests/testthat/test-input_list_class.R | 14 ++--- 3 files changed, 62 insertions(+), 32 deletions(-) diff --git a/R/input_class.R b/R/input_class.R index 14a5bb5..e1e489a 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -11,7 +11,8 @@ Input <- setRefClass( "Input", fields = c("type", "name", "idFunc", "label", "value", "display", "params", "env", "validFunc", "htmlFunc", "htmlUpdateFunc", - "lastParams", "changedParams", "valueHasChanged", "deps"), + "lastParams", "changedParams", "valueHasChanged", + "revDeps", "displayRevDeps"), methods = list( init = function(name, env) { @@ -20,7 +21,8 @@ Input <- setRefClass( env <<- env valueHasChanged <<- FALSE changedParams <<- list() - deps <<- character() + revDeps <<- character() + displayRevDeps <<- character() if (emptyField(label) || is.null(label)) label <<- name if (emptyField(idFunc)) { idFunc <<- function(oid, name) paste(oid, name, sep = "_") diff --git a/R/input_list_class.R b/R/input_list_class.R index 244b4a3..68fc9aa 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -1,8 +1,14 @@ +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"), + fields = c("inputs", "session", "names", "chartIds", "initialized"), methods = list( initialize = function(inputs, session = NULL) { "args: @@ -14,17 +20,26 @@ InputList <- setRefClass( 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() - revdeps <- getRevDeps(input) - for (d in revdeps) { - inputs[[d]]$deps <<- c(.self$inputs[[d]]$deps, inputId) + deps <- getDeps(input) + for (d in deps$params) { + inputs[[d]]$revDeps <<- c(.self$inputs[[d]]$revDeps, inputId) + } + for (d in deps$display) { + inputs[[d]]$displayRevDeps <<- c(.self$inputs[[d]]$displayRevDeps, inputId) } } + init() + }, + + init = function() { update() + initialized <<- TRUE }, isShared = function(name) { @@ -33,19 +48,32 @@ InputList <- setRefClass( any(chartIds[idx] == 0) }, - isVisible = function(name, chartId = 1) { - i <- getInput(name, chartId) + isVisible = function(name, chartId = 1, inputId = NULL) { + i <- getInput(name, chartId, inputId) eval(i$display, envir = i$env) }, - getRevDeps = function(input) { - deps <- c() - for (p in input$params) { - f <- function() {} - body(f) <- p - deps <- union(deps, codetools::findGlobals(f, merge = FALSE)$variables) + updateHTMLVisibility = function(name, chartId = 1, inputId = NULL) { + if (!is.null(session)) { + input <- getInput(name, chartId, inputId) + shiny::updateCheckboxInput( + session, + paste0(input$getID(), "_visible"), + value = eval(input$display, envir = input$env) + ) } - names(inputs)[names %in% deps] + }, + + 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) { @@ -72,17 +100,20 @@ InputList <- setRefClass( setValue = function(name, value, chartId = 1, inputId = NULL) { input <- getInput(name, chartId, inputId) res <- input$setValue(value) - updateDeps(input) + updateRevDeps(input) res }, - updateDeps = function(input) { - for (inputId in input$deps) { - depInput <- getInput(inputId = inputId) - if(!isTRUE(all.equal(depInput$value, depInput$updateValue()))) { - updateDeps(depInput) + updateRevDeps = function(input) { + 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() }, @@ -103,11 +134,6 @@ InputList <- setRefClass( updateHTML = function() { if (!is.null(session)) { for (input in inputs) { - shiny::updateCheckboxInput( - session, - paste0(input$getID(), "_visible"), - value = eval(input$display, envir = input$env) - ) input$updateHTML(session) } } diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R index 7e88f14..940be99 100644 --- a/tests/testthat/test-input_list_class.R +++ b/tests/testthat/test-input_list_class.R @@ -15,16 +15,18 @@ describe("InputList", { it("detects dependencies between inputs", { inputs <- list( x = mwSlider(0, 10, 5), - y = mwSlider(x, 10, 0), + 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) - expect_length(inputList$getRevDeps(inputList$inputs$output_1_x), 0) - expect_length(inputList$inputs$output_1_y$deps, 0) - expect_equal(inputList$getRevDeps(inputList$inputs$output_1_y), c("output_1_x")) - expect_equal(inputList$inputs$output_1_x$deps, - c("output_1_y", "output_1_z")) + 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)) From 3a828738fdee59fd389111d96fb2ecd0614dbf88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Wed, 2 Aug 2017 17:38:16 +0200 Subject: [PATCH 042/101] mwNumeric should also manage NULL value --- R/inputs.R | 3 ++- tests/testthat/test-inputs.R | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/R/inputs.R b/R/inputs.R index f670fa3..8f29dfe 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -20,7 +20,7 @@ htmlFuncFactory <- function(func, valueArgName = "value") { function(id, label, value, params, ns = NULL) { params$inputId <- id params$label <- label - params[[valueArgName]] <- value + params[valueArgName] <- list(value) do.call(func, params) } } @@ -167,6 +167,7 @@ mwNumeric <- function(value, label = NULL, ..., .display = TRUE) { 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), diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R index 2fdfe4f..5480740 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -13,7 +13,7 @@ test_input( test_input(mwText(), list("1", 1, NULL), list("1", "1", "")) # Numeric -test_input(mwNumeric(0), c(5, -20, 20), c(5, -20, 20)) +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 From ebc2f252fd7884c66ec6fbe573c93a4769f3beec Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Thu, 3 Aug 2017 11:05:10 +0200 Subject: [PATCH 043/101] add width and height to getModuleUI --- R/controller.R | 5 +++-- R/manipulate_widget.R | 4 ++-- R/mw_ui.R | 7 ++++++- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/R/controller.R b/R/controller.R index 52f2c95..01d5800 100644 --- a/R/controller.R +++ b/R/controller.R @@ -197,11 +197,12 @@ MWController <- setRefClass( }, getModuleUI = function(gadget = TRUE, saveBtn = TRUE, addBorder = !gadget) { - function(id) { + function(id, width = "100%", height = "400px") { ns <- shiny::NS(id) mwUI(ns, uiSpec, nrow, ncol, outputFunc, okBtn = gadget, updateBtn = !autoUpdate, saveBtn = saveBtn, - areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder) + areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder, + width = width, height = height) } }, diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index b78e4c0..b3281a9 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -295,7 +295,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, browser = shiny::browserViewer() ) - ui <- mwModuleInput("ui") + ui <- mwModuleInput("ui", height = "100%") server <- function(input, output, session, ...) { controller <- shiny::callModule(mwModule, "ui") } @@ -303,7 +303,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, shiny::runGadget(ui, server, viewer = .viewer) } else if (.runApp & isRuntimeShiny) { # We are in Rmarkdown document with shiny runtime. So we start a shiny app - ui <- mwModuleInput("ui") + ui <- mwModuleInput("ui", height = "100%") server <- function(input, output, session, ...) { controller <- shiny::callModule(mwModule, "ui") } diff --git a/R/mw_ui.R b/R/mw_ui.R index bb5749b..2d821c6 100644 --- a/R/mw_ui.R +++ b/R/mw_ui.R @@ -10,12 +10,16 @@ #' @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) { + okBtn = TRUE, saveBtn = TRUE, updateBtn = FALSE, + areaBtns = TRUE, border = FALSE, + width = "100%", height = "400px") { htmldep <- htmltools::htmlDependency( "manipulateWidget", @@ -32,6 +36,7 @@ mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL, 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), From a99c5435494f38f29d48ac77bd411df876fafe1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Thu, 3 Aug 2017 11:16:56 +0200 Subject: [PATCH 044/101] Now InputList is not initialized when created. This gives a chance to modify initial values before the mw module starts --- DESCRIPTION | 3 ++- R/controller.R | 2 ++ R/input_list_class.R | 11 +++++++---- tests/testthat/test-input_list_class.R | 21 ++++++++++++++++++--- 4 files changed, 29 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 34a2c9c..6143bc9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,7 +25,8 @@ Imports: methods, tools, base64enc, - grDevices + grDevices, + codetools Suggests: dygraphs, leaflet, diff --git a/R/controller.R b/R/controller.R index 52f2c95..9c74ef1 100644 --- a/R/controller.R +++ b/R/controller.R @@ -67,6 +67,8 @@ MWController <- setRefClass( ncol <<- ncol returnFunc <<- returnFunc charts <<- list() + + inputList$init() }, setShinySession = function(output, session) { diff --git a/R/input_list_class.R b/R/input_list_class.R index 68fc9aa..7068f67 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -33,13 +33,14 @@ InputList <- setRefClass( inputs[[d]]$displayRevDeps <<- c(.self$inputs[[d]]$displayRevDeps, inputId) } } - - init() }, init = function() { - update() - initialized <<- TRUE + if (!initialized) { + update() + initialized <<- TRUE + } + return(.self) }, isShared = function(name) { @@ -105,6 +106,8 @@ InputList <- setRefClass( }, updateRevDeps = function(input) { + if (!initialized) return() + for (inputId in input$revDeps) { revDepInput <- getInput(inputId = inputId) if(!identical(revDepInput$value, revDepInput$updateValue())) { diff --git a/tests/testthat/test-input_list_class.R b/tests/testthat/test-input_list_class.R index 940be99..2c10167 100644 --- a/tests/testthat/test-input_list_class.R +++ b/tests/testthat/test-input_list_class.R @@ -4,7 +4,7 @@ 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) + inputList <- InputList(inputs)$init() expect_equal(inputList$inputs$output_1_y$value, 5) @@ -19,7 +19,7 @@ describe("InputList", { z = mwSlider(0, x, 0) ) inputs <- filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1)) - inputList <- InputList(inputs) + 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) @@ -37,7 +37,7 @@ describe("InputList", { filterAndInitInputs(inputs, c(), TRUE, initEnv(parent.frame(), 1)), filterAndInitInputs(inputs2, c(), TRUE, initEnv(parent.frame(), 2)) ) - inputList <- InputList(inputs) + inputList <- InputList(inputs)$init() it ("gets and updates an input by name and chartId", { # Get Input @@ -84,5 +84,20 @@ describe("InputList", { 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) + }) }) }) From 50e5f734aff3ef10c910301788d985f4bd0b92d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Thu, 3 Aug 2017 11:17:29 +0200 Subject: [PATCH 045/101] It is now possible to update a mwSharedInput if it is not dynamic. --- R/inputs.R | 10 +++++++--- man/mwSharedValue.Rd | 2 +- tests/testthat/test-manipulate_widget.R | 19 +++++++++++++++++++ 3 files changed, 27 insertions(+), 4 deletions(-) diff --git a/R/inputs.R b/R/inputs.R index 8f29dfe..b7b4e79 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -559,13 +559,17 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = #' #' @export #' @family controls -mwSharedValue <- function(expr) { +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 = NULL, label = NULL, params = params, + type = "sharedValue", value = value, label = NULL, params = params, display = FALSE, validFunc = function(x, params) { - params$expr + if(params$dynamic) params$expr + else x } ) } diff --git a/man/mwSharedValue.Rd b/man/mwSharedValue.Rd index c276993..e41dfd9 100644 --- a/man/mwSharedValue.Rd +++ b/man/mwSharedValue.Rd @@ -4,7 +4,7 @@ \alias{mwSharedValue} \title{Shared Value} \usage{ -mwSharedValue(expr) +mwSharedValue(expr = NULL) } \arguments{ \item{expr}{Expression used to compute the value of the input.} diff --git a/tests/testthat/test-manipulate_widget.R b/tests/testthat/test-manipulate_widget.R index 334d88d..defc76d 100644 --- a/tests/testthat/test-manipulate_widget.R +++ b/tests/testthat/test-manipulate_widget.R @@ -94,4 +94,23 @@ describe("manipulateWidget", { 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) + ) + 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) + }) }) From 34b62685e87d0cce9e5505e601e1d421cea5bbbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Thu, 3 Aug 2017 15:35:36 +0200 Subject: [PATCH 046/101] Solve javascript errors when using manipulateWidget module in a shiny app. --- R/combine_widgets.R | 2 +- inst/manipulate_widget/manipulate_widget.js | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/R/combine_widgets.R b/R/combine_widgets.R index 6f525dc..f1c64e6 100644 --- a/R/combine_widgets.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/inst/manipulate_widget/manipulate_widget.js b/inst/manipulate_widget/manipulate_widget.js index cd14693..65663c2 100644 --- a/inst/manipulate_widget/manipulate_widget.js +++ b/inst/manipulate_widget/manipulate_widget.js @@ -24,7 +24,9 @@ function select(e) { if (widgets) { for (var i = 0; i < widgets.length; i++) { container = document.getElementById(ids[i]); + if (widgets[i] && wudgets[i].resize) { HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]); + } } } } From 15f0b35fc02d0f8872f86ff963217e894e00188b Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Thu, 3 Aug 2017 16:01:37 +0200 Subject: [PATCH 047/101] fix typo --- inst/manipulate_widget/manipulate_widget.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/manipulate_widget/manipulate_widget.js b/inst/manipulate_widget/manipulate_widget.js index 65663c2..1020661 100644 --- a/inst/manipulate_widget/manipulate_widget.js +++ b/inst/manipulate_widget/manipulate_widget.js @@ -24,7 +24,7 @@ function select(e) { if (widgets) { for (var i = 0; i < widgets.length; i++) { container = document.getElementById(ids[i]); - if (widgets[i] && wudgets[i].resize) { + if (widgets[i] && widgets[i].resize) { HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]); } } From 52546a414cbd234739f842c494a094c701b5dba3 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Thu, 3 Aug 2017 16:02:00 +0200 Subject: [PATCH 048/101] pass okBtn as argument of getModuleUI --- R/controller.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/controller.R b/R/controller.R index 99afc32..cad32f9 100644 --- a/R/controller.R +++ b/R/controller.R @@ -199,10 +199,10 @@ MWController <- setRefClass( }, getModuleUI = function(gadget = TRUE, saveBtn = TRUE, addBorder = !gadget) { - function(id, width = "100%", height = "400px") { + function(id, okBtn = gadget, width = "100%", height = "400px") { ns <- shiny::NS(id) mwUI(ns, uiSpec, nrow, ncol, outputFunc, - okBtn = gadget, updateBtn = !autoUpdate, saveBtn = saveBtn, + okBtn = okBtn, updateBtn = !autoUpdate, saveBtn = saveBtn, areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder, width = width, height = height) } @@ -214,7 +214,7 @@ MWController <- setRefClass( controller$setShinySession(output, session) controller$renderShinyOutputs() - message("Click on the 'OK' button to return to the R session.") + # message("Click on the 'OK' button to return to the R session.") lapply(names(controller$inputList$inputs), function(id) { observe(controller$setValueById(id, value = input[[id]])) From 0afcba30f3f52842f4f937f196c4fd54fcc1d17c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Thu, 3 Aug 2017 16:31:46 +0200 Subject: [PATCH 049/101] New function that gets output and render functions of an htmlwidget --- R/get_output_and_render_func.R | 33 +++++++++++++++++++ .../test-get_output_and_render_func.R | 22 +++++++++++++ 2 files changed, 55 insertions(+) create mode 100644 R/get_output_and_render_func.R create mode 100644 tests/testthat/test-get_output_and_render_func.R 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/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..4b585c4 --- /dev/null +++ b/tests/testthat/test-get_output_and_render_func.R @@ -0,0 +1,22 @@ +context("getOutputAndRenderFunc") + +describe("getOutputAndRenderFunc", { + library("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) + }) +}) From d003ab0aca3613b07a74a27098ede45835d1d165 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 4 Aug 2017 09:58:30 +0200 Subject: [PATCH 050/101] New method init') for MWController class --- R/controller.R | 22 ++++++++++++++++++++-- R/manipulate_widget.R | 26 +------------------------- tests/testthat/test-controller.R | 16 ++++++++-------- tests/testthat/test-on_done.R | 6 +++--- 4 files changed, 32 insertions(+), 38 deletions(-) diff --git a/R/controller.R b/R/controller.R index 99afc32..2ba44f4 100644 --- a/R/controller.R +++ b/R/controller.R @@ -48,7 +48,7 @@ MWController <- setRefClass( "MWController", fields = c("inputList", "uiSpec", "envs", "session", "shinyOutput", "expr", "ncharts", "charts", "autoUpdate", "renderFunc", "outputFunc", "useCombineWidgets", "nrow", "ncol", - "returnFunc"), + "returnFunc", "initialized"), methods = list( initialize = function(expr, inputs, autoUpdate = TRUE, nrow = NULL, @@ -59,6 +59,7 @@ MWController <- setRefClass( ncharts <<- inputs$ncharts envs <<- inputs$envs$ind autoUpdate <<- autoUpdate + outputFunc <<- NULL renderFunc <<- NULL session <<- NULL shinyOutput <<- NULL @@ -67,8 +68,25 @@ MWController <- setRefClass( ncol <<- ncol returnFunc <<- returnFunc charts <<- list() + initialized <<- FALSE + }, + + init = function() { + 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) + } + } + } - inputList$init() + return(.self) }, setShinySession = function(output, session) { diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index b3281a9..f3135aa 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -257,31 +257,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, controller <- MWController(.expr, inputs, autoUpdate = !.updateBtn, nrow = dims$nrow, ncol = dims$ncol, returnFunc = .return) - controller$updateCharts() - - # Get shiny output and render functions - if (is(controller$charts[[1]], "htmlwidget")) { - cl <- class(controller$charts[[1]])[1] - pkg <- attr(controller$charts[[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 - } - - controller$renderFunc <- renderFunction - controller$outputFunc <- outputFunction - if (useCombineWidgets) { - controller$useCombineWidgets <- TRUE - controller$charts <- lapply(controller$charts, combineWidgets) - } + controller$init() mwModuleInput <- controller$getModuleUI(gadget = !isRuntimeShiny, saveBtn = .saveBtn) mwModule <- controller$getModuleServer() diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index ec8eec5..896e2a8 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -4,28 +4,28 @@ 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) + controller <- MWController(expr, inputs)$init() controller$updateCharts() expect_is(controller$charts, "list") expect_length(controller$charts, 1) - expect_equal(controller$charts[[1]], "a b") + 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) + 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, "a b") + 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")) - controller <- MWController(expr, inputs) + 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") @@ -36,7 +36,7 @@ describe("MWController", { 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) + controller1 <- MWController(expr, inputs)$init() controller2 <- controller1$clone() controller1$setValue("a", "test") @@ -47,14 +47,14 @@ describe("MWController", { 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) + 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) + controller <- MWController(expr, inputs)$init() ui <- controller$getModuleUI() server <- controller$getModuleServer() expect_is(ui, "function") diff --git a/tests/testthat/test-on_done.R b/tests/testthat/test-on_done.R index 0bac663..cd8b725 100644 --- a/tests/testthat/test-on_done.R +++ b/tests/testthat/test-on_done.R @@ -10,7 +10,7 @@ describe("onDone", { { inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3))) expr <- expression(combineWidgets(paste(x1, x2))) - controller <- MWController(expr, inputs) + controller <- MWController(expr, inputs)$init() expect_output(res <- onDone(controller), "Stop gadget") expect_is(res, "htmlwidget") @@ -31,12 +31,12 @@ describe("onDone", { inputs <- initInputs(list(x1 = mwText("value1"), x2 = mwSelect(1:3)), compare = compare, ncharts = 3) expr <- expression(paste(x1, x2)) - controller <- MWController(expr, inputs) + 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]], paste("value1", compare$x2[[i]])) + expect_equal(res$widgets[[i]]$widgets[[1]], paste("value1", compare$x2[[i]])) } } ) From 9e1b7c5ccff88a5248b55e4f58f44a4a02bd8bf9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 4 Aug 2017 10:43:47 +0200 Subject: [PATCH 051/101] manipulateWidget now returns an uninitialized controller in non interactive situations --- R/controller.R | 4 ++++ R/manipulate_widget.R | 12 ++++++++---- tests/testthat/test-controller.R | 15 +++++++++++++++ tests/testthat/test-manipulate_widget.R | 18 ++++++++++++++++++ 4 files changed, 45 insertions(+), 4 deletions(-) diff --git a/R/controller.R b/R/controller.R index ed0df02..e2516a4 100644 --- a/R/controller.R +++ b/R/controller.R @@ -73,6 +73,7 @@ MWController <- setRefClass( init = function() { if (!initialized) { + initialized <<- TRUE inputList$init() updateCharts() if (is.null(renderFunc) || is.null(outputFunc) || is.null(useCombineWidgets)) { @@ -112,6 +113,7 @@ MWController <- setRefClass( "Update the value of a variable for a given chart." oldValue <- getValue(name, chartId) newValue <- inputList$setValue(name, value, chartId) + if (!initialized) return() if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { if (inputList$isShared(name)) updateCharts() else updateChart(chartId) @@ -121,6 +123,7 @@ MWController <- setRefClass( setValueById = function(id, value) { oldValue <- getValueById(id) newValue <- inputList$setValue(inputId = id, value = value) + if (!initialized) return() if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { if (grepl("^shared_", id)) updateCharts() else { @@ -268,5 +271,6 @@ cloneEnv <- function(env, parentEnv = parent.env(env)) { #' #' @export knit_print.MWController <- function(x, ...) { + x$init() knitr::knit_print(x$returnCharts(), ...) } diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index f3135aa..3a4a8cc 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -257,13 +257,13 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, controller <- MWController(.expr, inputs, autoUpdate = !.updateBtn, nrow = dims$nrow, ncol = dims$ncol, returnFunc = .return) - controller$init() - - mwModuleInput <- controller$getModuleUI(gadget = !isRuntimeShiny, saveBtn = .saveBtn) - mwModule <- controller$getModuleServer() if (.runApp & interactive()) { # We are in an interactive session so we start a shiny gadget + controller$init() + mwModuleInput <- controller$getModuleUI(gadget = TRUE, saveBtn = .saveBtn) + mwModule <- controller$getModuleServer() + .viewer <- switch( .viewer, pane = shiny::paneViewer(), @@ -279,6 +279,10 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, shiny::runGadget(ui, server, viewer = .viewer) } else if (.runApp & isRuntimeShiny) { # We are in Rmarkdown document with shiny runtime. So we start a shiny app + controller$init() + mwModuleInput <- controller$getModuleUI(gadget = FALSE, saveBtn = .saveBtn) + mwModule <- controller$getModuleServer() + ui <- mwModuleInput("ui", height = "100%") server <- function(input, output, session, ...) { controller <- shiny::callModule(mwModule, "ui") diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index 896e2a8..34b36a6 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -61,4 +61,19 @@ describe("MWController", { 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) + }) }) diff --git a/tests/testthat/test-manipulate_widget.R b/tests/testthat/test-manipulate_widget.R index defc76d..82b50e5 100644 --- a/tests/testthat/test-manipulate_widget.R +++ b/tests/testthat/test-manipulate_widget.R @@ -1,6 +1,16 @@ 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" + ) + expect_true(!c$initialized) + }) + it("creates two charts when .compare is a character vector", { c <- manipulateWidget( paste(a, b), @@ -8,6 +18,7 @@ describe("manipulateWidget", { b = mwText("test"), .compare = "a" ) + c$init() expect_equal(c$ncharts, 2) expect_equal(c$getValue("a", 1), "a") expect_equal(c$getValue("a", 2), "a") @@ -20,6 +31,7 @@ describe("manipulateWidget", { b = mwText("test"), .compare = list(a = NULL) ) + c$init() expect_equal(c$ncharts, 2) expect_equal(c$getValue("a", 1), "a") expect_equal(c$getValue("a", 2), "a") @@ -32,6 +44,7 @@ describe("manipulateWidget", { b = mwText("test"), .compare = list(a = list("a", "b")) ) + c$init() expect_equal(c$ncharts, 2) expect_equal(c$getValue("a", 1), "a") expect_equal(c$getValue("a", 2), "b") @@ -47,6 +60,7 @@ describe("manipulateWidget", { .compare = list(a = list("a", "b", "c")), .compareOpts = compareOptions(ncharts = 3) ) + c$init() expect_equal(c$ncharts, 3) expect_equal(c$getValue("a", 1), "a") expect_equal(c$getValue("a", 2), "b") @@ -62,6 +76,7 @@ describe("manipulateWidget", { x = mwSlider(0, 10, 5), y = mwSlider(0, x, 4) ) + c$init() expect_equal(c$getParams("y")$max, 5) c$setValue("x", 3) expect_equal(c$getParams("y")$max, 3) @@ -74,6 +89,7 @@ describe("manipulateWidget", { x = mwSlider(0, 10, 0), y = mwSlider(0, 10, 0, .display = x < 5) ) + c$init() expect_true(c$isVisible("y")) c$setValue("x", 6) expect_true(!c$isVisible("y")) @@ -86,6 +102,7 @@ describe("manipulateWidget", { x2 = mwSharedValue(x * 2), y = mwSlider(0, x2, 0) ) + c$init() expect_equal(c$getParams("y")$max, 10) expect_equal(c$charts[[1]]$widgets[[1]], 10) c$setValue("x", 8) @@ -103,6 +120,7 @@ describe("manipulateWidget", { x3 = mwSharedValue(x + x2), y = mwSlider(0, x2, 0) ) + c$init() expect_equal(c$getParams("y")$max, 1) expect_equal(c$charts[[1]]$widgets[[1]], 1) c$setValue("x2", 8) From ab71d7ca49952a9e86454f2311822af12d00e4b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 4 Aug 2017 11:15:09 +0200 Subject: [PATCH 052/101] fix Controller$clone() method. It was not behaving crrectly anymore when controller was initialized --- R/controller.R | 7 ++++++- R/input_list_class.R | 6 +++--- tests/testthat/test-controller.R | 2 ++ 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/R/controller.R b/R/controller.R index e2516a4..869479d 100644 --- a/R/controller.R +++ b/R/controller.R @@ -72,6 +72,7 @@ MWController <- setRefClass( }, init = function() { + catIfDebug("Controller initialization") if (!initialized) { initialized <<- TRUE inputList$init() @@ -213,9 +214,13 @@ MWController <- setRefClass( ), autoUpdate ) - res$renderFunc <- renderFunc res$charts <- charts + res$outputFunc <- outputFunc + res$renderFunc <- renderFunc res$useCombineWidgets <- useCombineWidgets + res$initialized <- initialized + res$inputList$initialized <- initialized + res }, diff --git a/R/input_list_class.R b/R/input_list_class.R index 7068f67..487866b 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -27,10 +27,10 @@ InputList <- setRefClass( inputId <- input$getID() deps <- getDeps(input) for (d in deps$params) { - inputs[[d]]$revDeps <<- c(.self$inputs[[d]]$revDeps, inputId) + inputs[[d]]$revDeps <<- union(.self$inputs[[d]]$revDeps, inputId) } for (d in deps$display) { - inputs[[d]]$displayRevDeps <<- c(.self$inputs[[d]]$displayRevDeps, inputId) + inputs[[d]]$displayRevDeps <<- union(.self$inputs[[d]]$displayRevDeps, inputId) } } }, @@ -57,6 +57,7 @@ InputList <- setRefClass( 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"), @@ -107,7 +108,6 @@ InputList <- setRefClass( updateRevDeps = function(input) { if (!initialized) return() - for (inputId in input$revDeps) { revDepInput <- getInput(inputId = inputId) if(!identical(revDepInput$value, revDepInput$updateValue())) { diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index 34b36a6..95142ed 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -42,6 +42,8 @@ describe("MWController", { 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", { From b86ec65b4030688f6ee76694ead8c0b67ec1add4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 4 Aug 2017 16:29:17 +0200 Subject: [PATCH 053/101] Module server function can now accept reactive values as arguments. --- .Rbuildignore | 1 + R/controller.R | 16 ++++++-- inst/examples/reactive_values.R | 51 ++++++++++++++++++++++++ inst/examples/two_modules_one_app.R | 62 +++++++++++++++++++++++++++++ 4 files changed, 127 insertions(+), 3 deletions(-) create mode 100644 inst/examples/reactive_values.R create mode 100644 inst/examples/two_modules_one_app.R 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/R/controller.R b/R/controller.R index 869479d..d325477 100644 --- a/R/controller.R +++ b/R/controller.R @@ -92,6 +92,7 @@ MWController <- setRefClass( }, setShinySession = function(output, session) { + catIfDebug("Set shiny session") session <<- session shinyOutput <<- output inputList$session <<- session @@ -151,7 +152,8 @@ MWController <- setRefClass( updateChart = function(chartId = 1) { catIfDebug("Update chart", chartId) - charts[[chartId]] <<- eval(expr, envir = envs[[chartId]]) + e <- new.env(parent = envs[[chartId]]) # User can set values in expr without messing environments + charts[[chartId]] <<- eval(expr, envir = e) if (useCombineWidgets) { charts[[chartId]] <<- combineWidgets(charts[[chartId]]) } @@ -240,10 +242,18 @@ MWController <- setRefClass( controller$setShinySession(output, session) controller$renderShinyOutputs() - # message("Click on the 'OK' button to return to the R session.") + reactiveValueList <- list(...) + print(names(reactiveValueList)) + observe({ + for (n in names(reactiveValueList)) { + controller$setValue(n, reactiveValueList[[n]]()) + } + }) lapply(names(controller$inputList$inputs), function(id) { - observe(controller$setValueById(id, value = input[[id]])) + if (controller$inputList$inputs[[id]]$type != "sharedValue") { + observe(controller$setValueById(id, value = input[[id]])) + } }) observeEvent(input$.update, controller$updateCharts()) diff --git a/inst/examples/reactive_values.R b/inst/examples/reactive_values.R new file mode 100644 index 0000000..8c6b981 --- /dev/null +++ b/inst/examples/reactive_values.R @@ -0,0 +1,51 @@ +mydata <- data.frame( + year = 2000+1:100, + series1 = rnorm(100), + series2 = rnorm(100), + series3 = rnorm(100) +) + +c <- manipulateWidget( + { + print(title) + if (is.null(series)) series <- "series1" + if (is.null(title)) title <- "" + dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title) + }, + range = mwSlider(2001, 2100, c(2001, 2100)), + series = mwSharedValue(), + title = mwSharedValue(), .runApp = FALSE +)$init() + +mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) +mwModule <- c$getModuleServer() + +ui <- fillPage( + fillRow( + flex = c(NA, 1), + div( + textInput("title", label = "Title", value = "glop"), + selectInput("series", "series", choices = c("series1", "series2", "series3")) + ), + mwModuleInput("ui") + #uiOutput("ui", container = function(...) tags$div(style="height:100%;", ...)) + ) +) + +server <- function(input, output, session) { + # + # c$init() + # mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) + # mwModule <- c$getModuleServer() + # id <- paste0("mwModule_", sample(1e9, 1)) + # output$ui <- renderUI(mwModuleInput(id, height = "100%")) + callModule(mwModule, "ui", series = reactive(input$series), title = reactive(input$title)) +} + +shinyApp(ui, server) + + + + + + diff --git a/inst/examples/two_modules_one_app.R b/inst/examples/two_modules_one_app.R new file mode 100644 index 0000000..3dd89f8 --- /dev/null +++ b/inst/examples/two_modules_one_app.R @@ -0,0 +1,62 @@ +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 +)$init() + +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 +)$init() + +mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) +mwModule <- c$getModuleServer() + +mwModuleInput2 <- c2$getModuleUI(gadget = FALSE, saveBtn = TRUE) +mwModule2 <- c2$getModuleServer() + +ui <- fillPage( + fillRow( + tags$div(mwModuleInput("pane1"), style = 'height:100%;'), + tags$div(mwModuleInput2("pane2"), style = 'height:100%;') + ) +) + +ui <- navbarPage("antaresViz", + tabPanel("prodStack", + tags$div(mwModuleInput("pane1"), style = 'height:800px;') + ), + tabPanel("exchangesStack", + tags$div(mwModuleInput2("pane2"), style = 'height:800px;') + ), + tabPanel("Table") +) +server <- function(input, output, session) { + callModule(mwModule, "pane1") + callModule(mwModule2, "pane2") +} + +shinyApp(ui, server) From b72409226217f1d569d8a432bcfdc079b30d9550 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 4 Aug 2017 17:29:40 +0200 Subject: [PATCH 054/101] Update example scripts --- inst/examples/reactive_values.R | 20 +------- inst/examples/reactive_values_late_eval.R | 57 +++++++++++++++++++++++ 2 files changed, 59 insertions(+), 18 deletions(-) create mode 100644 inst/examples/reactive_values_late_eval.R diff --git a/inst/examples/reactive_values.R b/inst/examples/reactive_values.R index 8c6b981..33b88e7 100644 --- a/inst/examples/reactive_values.R +++ b/inst/examples/reactive_values.R @@ -7,14 +7,11 @@ mydata <- data.frame( c <- manipulateWidget( { - print(title) - if (is.null(series)) series <- "series1" - if (is.null(title)) title <- "" dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title) }, range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSharedValue(), - title = mwSharedValue(), .runApp = FALSE + series = mwSharedValue("series1"), + title = mwSharedValue("Fictive time series"), .runApp = FALSE )$init() mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) @@ -28,24 +25,11 @@ ui <- fillPage( selectInput("series", "series", choices = c("series1", "series2", "series3")) ), mwModuleInput("ui") - #uiOutput("ui", container = function(...) tags$div(style="height:100%;", ...)) ) ) server <- function(input, output, session) { - # - # c$init() - # mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) - # mwModule <- c$getModuleServer() - # id <- paste0("mwModule_", sample(1e9, 1)) - # output$ui <- renderUI(mwModuleInput(id, height = "100%")) callModule(mwModule, "ui", series = reactive(input$series), title = reactive(input$title)) } shinyApp(ui, server) - - - - - - diff --git a/inst/examples/reactive_values_late_eval.R b/inst/examples/reactive_values_late_eval.R new file mode 100644 index 0000000..0ce7c56 --- /dev/null +++ b/inst/examples/reactive_values_late_eval.R @@ -0,0 +1,57 @@ +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, 2100)), + series = mwSharedValue("series1"), + title = mwSharedValue("Fictive time series"), .runApp = FALSE +) + +mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) +mwModule <- c$getModuleServer() + +ui <- fillPage( + fillRow( + flex = c(NA, 1), + div( + textInput("title", label = "Title", value = "glop"), + selectInput("series", "series", choices = c("series1", "series2", "series3")) + ), + uiOutput("ui", container = function(...) tags$div(style="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, 2100)), + series = mwSharedValue("series1"), + title = mwSharedValue("Fictive time series"), .runApp = FALSE + ) + # + # c$init() + mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) + mwModule <- c$getModuleServer() + id <- paste0("mwModule_", sample(1e9, 1)) + callModule(mwModule, id, series = reactive(input$series), title = reactive(input$title)) + #output$ui <- renderUI(mwModuleInput(id, height = "100%")) + # This should be executed after reactive values have been initialized and mwModule is initialized. +} + +shinyApp(ui, server) From 7f12e0d210bdc6ab90339bc78425d57736eefeb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Mon, 7 Aug 2017 17:26:13 +0200 Subject: [PATCH 055/101] New functions mwModule() and mwModuleUI() to insert a mw module in a shiny app --- NAMESPACE | 2 + R/controller.R | 114 +++++++++++++------ R/inputs.R | 3 +- R/manipulate_widget.R | 25 ++-- R/module_ui.R | 106 +++++++++++++++++ R/mw_ui.R | 16 ++- inst/examples/reactive_values_late_eval.R | 36 +----- inst/manipulate_widget/manipulate_widget.css | 16 ++- inst/manipulate_widget/manipulate_widget.js | 13 +-- man/mwModule.Rd | 85 ++++++++++++++ 10 files changed, 319 insertions(+), 97 deletions(-) create mode 100644 R/module_ui.R create mode 100644 man/mwModule.Rd diff --git a/NAMESPACE b/NAMESPACE index b417a0f..bc08fa6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,8 @@ export(mwCheckboxGroup) export(mwDate) export(mwDateRange) export(mwGroup) +export(mwModule) +export(mwModuleUI) export(mwNumeric) export(mwPassword) export(mwRadio) diff --git a/R/controller.R b/R/controller.R index d325477..6b124c8 100644 --- a/R/controller.R +++ b/R/controller.R @@ -74,7 +74,6 @@ MWController <- setRefClass( init = function() { catIfDebug("Controller initialization") if (!initialized) { - initialized <<- TRUE inputList$init() updateCharts() if (is.null(renderFunc) || is.null(outputFunc) || is.null(useCombineWidgets)) { @@ -86,6 +85,7 @@ MWController <- setRefClass( charts <<- lapply(charts, combineWidgets) } } + initialized <<- TRUE } return(.self) @@ -152,12 +152,14 @@ MWController <- setRefClass( updateChart = function(chartId = 1) { catIfDebug("Update chart", chartId) - e <- new.env(parent = envs[[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) + try({ + e <- new.env(parent = envs[[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() { @@ -182,6 +184,7 @@ MWController <- setRefClass( renderShinyOutput = function(chartId) { if (!is.null(renderFunc) & !is.null(shinyOutput) & is(charts[[chartId]], "htmlwidget")) { + catIfDebug("Render shiny output") outputId <- get(".output", envir = envs[[chartId]]) shinyOutput[[outputId]] <<- renderFunc(charts[[chartId]]) } @@ -192,31 +195,14 @@ MWController <- setRefClass( }, clone = function(env = parent.frame()) { - # Clone environments - newSharedEnv <- cloneEnv(parent.env(envs[[1]])) - newEnvs <- lapply(envs, cloneEnv, parentEnv = newSharedEnv) - - newInputs <- lapply(seq_along(inputList$inputs), function(i) { - x <- inputList$inputs[[i]]$copy() - chartId <- inputList$chartIds[i] - if (chartId == 0) x$env <- newSharedEnv - else x$env <- newEnvs[[chartId]] - x - }) - res <- MWController( expr, - list( - inputList = InputList(newInputs, session), - envs = list( - shared = newSharedEnv, - ind = newEnvs - ), - ncharts = ncharts - ), + cloneUISpec(uiSpec, session), autoUpdate ) res$charts <- charts + res$nrow <- nrow + res$ncol <- ncol res$outputFunc <- outputFunc res$renderFunc <- renderFunc res$useCombineWidgets <- useCombineWidgets @@ -227,8 +213,8 @@ MWController <- setRefClass( }, getModuleUI = function(gadget = TRUE, saveBtn = TRUE, addBorder = !gadget) { - function(id, okBtn = gadget, width = "100%", height = "400px") { - ns <- shiny::NS(id) + function(ns, okBtn = gadget, width = "100%", height = "400px") { + #ns <- shiny::NS(id) mwUI(ns, uiSpec, nrow, ncol, outputFunc, okBtn = okBtn, updateBtn = !autoUpdate, saveBtn = saveBtn, areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder, @@ -236,23 +222,45 @@ MWController <- setRefClass( } }, + render = function(output, session) { + if (initialized) return() + ns <- session$ns + tryCatch({ + init() + setShinySession(output, session) + output$ui <- renderUI(getModuleUI()(ns, height = "100%")) + if (autoUpdate) renderShinyOutputs() + }, error = function(e) {catIfDebug("Initialization error"); print(e)}) + }, + getModuleServer = function() { function(input, output, session, ...) { controller <- .self$clone() - controller$setShinySession(output, session) - controller$renderShinyOutputs() reactiveValueList <- list(...) - print(names(reactiveValueList)) + observe({ for (n in names(reactiveValueList)) { controller$setValue(n, reactiveValueList[[n]]()) } + controller$render(output, session) }) lapply(names(controller$inputList$inputs), function(id) { if (controller$inputList$inputs[[id]]$type != "sharedValue") { - observe(controller$setValueById(id, value = input[[id]])) + # 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) + } + }) } }) @@ -279,6 +287,46 @@ cloneEnv <- function(env, parentEnv = parent.env(env)) { 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 diff --git a/R/inputs.R b/R/inputs.R index b7b4e79..5e96509 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -89,7 +89,8 @@ mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) { type = "slider", value = value, label = label, params = params, display = substitute(.display), validFunc = function(x, params) { - pmin(pmax(params$min, x), params$max) + 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(...)) diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 3a4a8cc..0ff8dde 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -260,10 +260,6 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, if (.runApp & interactive()) { # We are in an interactive session so we start a shiny gadget - controller$init() - mwModuleInput <- controller$getModuleUI(gadget = TRUE, saveBtn = .saveBtn) - mwModule <- controller$getModuleServer() - .viewer <- switch( .viewer, pane = shiny::paneViewer(), @@ -271,26 +267,23 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, browser = shiny::browserViewer() ) - ui <- mwModuleInput("ui", height = "100%") - server <- function(input, output, session, ...) { - controller <- shiny::callModule(mwModule, "ui") + 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 (.runApp & isRuntimeShiny) { # We are in Rmarkdown document with shiny runtime. So we start a shiny app - controller$init() - mwModuleInput <- controller$getModuleUI(gadget = FALSE, saveBtn = .saveBtn) - mwModule <- controller$getModuleServer() - - ui <- mwModuleInput("ui", height = "100%") - server <- function(input, output, session, ...) { - controller <- shiny::callModule(mwModule, "ui") + 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. + # 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..a40ed35 --- /dev/null +++ b/R/module_ui.R @@ -0,0 +1,106 @@ +#' 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. +#' @rdname mwModule +#' @export +mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin = 0, width = "100%", height = 400) { + ns <- shiny::NS(id) + for (i in seq_along(margin)) { + margin[i] <- shiny::validateCssUnit(margin[i]) + } + + margin <-paste(margin, collapse = " ") + + class <- "" + if (border) class <- c(class, "with-border") + if(!okBtn) class <- c(class, "without-ok") + if(!saveBtn) class <- c(class, "without-save") + class <- paste(class, collapse = " ") + + res <- shiny::tagList( + 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, + ...) + }) + ) + + 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/mw_ui.R b/R/mw_ui.R index 2d821c6..40b08fc 100644 --- a/R/mw_ui.R +++ b/R/mw_ui.R @@ -51,11 +51,12 @@ mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL, .uiInputs <- function(ns, inputs) { inputs <- c(list(inputs$inputs$shared), inputs$inputs$ind) - inputs <- unname(lapply(inputs, function(x) { + 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", shiny::tagList(content)) - })) + 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) @@ -89,6 +90,7 @@ mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL, 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") @@ -99,7 +101,7 @@ mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL, } if (areaBtns && ncharts > 1) { - container <- tagAppendChild(container, .uiChartBtns(ncharts, nrow, ncol)) + container <- tagAppendChild(container, .uiChartBtns(ns, ncharts, nrow, ncol)) } if (updateBtn) { @@ -117,7 +119,7 @@ mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL, if (saveBtn) { bottom_px <- ifelse(okBtn, "bottom: 80px;", "bottom: 30px;") - saveBtnInput <- shiny::downloadButton(ns("save"), label = "", class = "mw-btn mw-btn-ok", + saveBtnInput <- shiny::downloadButton(ns("save"), label = "", class = "mw-btn mw-btn-save", style = bottom_px) container <- tagAppendChild(container, saveBtnInput) } @@ -125,10 +127,12 @@ mwUI <- function(ns, inputs, nrow = 1, ncol = 1, outputFun = NULL, container } -.uiChartBtns <- function(ncharts, nrow, ncol) { +.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") ) diff --git a/inst/examples/reactive_values_late_eval.R b/inst/examples/reactive_values_late_eval.R index 0ce7c56..767e8e6 100644 --- a/inst/examples/reactive_values_late_eval.R +++ b/inst/examples/reactive_values_late_eval.R @@ -1,22 +1,3 @@ -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, 2100)), - series = mwSharedValue("series1"), - title = mwSharedValue("Fictive time series"), .runApp = FALSE -) - -mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) -mwModule <- c$getModuleServer() - ui <- fillPage( fillRow( flex = c(NA, 1), @@ -24,7 +5,7 @@ ui <- fillPage( textInput("title", label = "Title", value = "glop"), selectInput("series", "series", choices = c("series1", "series2", "series3")) ), - uiOutput("ui", container = function(...) tags$div(style="height:100%;", ...)) + mwModuleUI("ui", height = "100%") ) ) @@ -40,18 +21,13 @@ server <- function(input, output, session) { { dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title) }, - range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSharedValue("series1"), - title = mwSharedValue("Fictive time series"), .runApp = FALSE + range = mwSlider(2001, 2100, c(2001, 2050)), + series = mwSharedValue(), + title = mwSharedValue(), .runApp = FALSE, + .compare = "range" ) # - # c$init() - mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) - mwModule <- c$getModuleServer() - id <- paste0("mwModule_", sample(1e9, 1)) - callModule(mwModule, id, series = reactive(input$series), title = reactive(input$title)) - #output$ui <- renderUI(mwModuleInput(id, height = "100%")) - # This should be executed after reactive values have been initialized and mwModule is initialized. + mwModule("ui", c, title = reactive(input$title), series = reactive(input$series)) } shinyApp(ui, server) diff --git a/inst/manipulate_widget/manipulate_widget.css b/inst/manipulate_widget/manipulate_widget.css index 9f65ff5..64c8ea5 100644 --- a/inst/manipulate_widget/manipulate_widget.css +++ b/inst/manipulate_widget/manipulate_widget.css @@ -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 1020661..d727d5d 100644 --- a/inst/manipulate_widget/manipulate_widget.js +++ b/inst/manipulate_widget/manipulate_widget.js @@ -1,20 +1,19 @@ -$( document ).ready(function() { +/*$( 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 diff --git a/man/mwModule.Rd b/man/mwModule.Rd new file mode 100644 index 0000000..5238eff --- /dev/null +++ b/man/mwModule.Rd @@ -0,0 +1,85 @@ +% 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) +} +\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.} +} +\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) + + +} + +} From 5f4c74ad72ff008648466dc6faafce7ad842860d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 8 Aug 2017 09:57:15 +0200 Subject: [PATCH 056/101] BUGFIX: widgets were not resizing anymore --- DESCRIPTION | 2 +- inst/manipulate_widget/manipulate_widget.js | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6143bc9..753ec3c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,7 +17,7 @@ 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, diff --git a/inst/manipulate_widget/manipulate_widget.js b/inst/manipulate_widget/manipulate_widget.js index d727d5d..ea04613 100644 --- a/inst/manipulate_widget/manipulate_widget.js +++ b/inst/manipulate_widget/manipulate_widget.js @@ -23,7 +23,7 @@ function select(el, id) { if (widgets) { for (var i = 0; i < widgets.length; i++) { container = document.getElementById(ids[i]); - if (widgets[i] && widgets[i].resize) { + if (widgets[i]) { HTMLWidgets.widgets[0].resize(container, container.clientWidth, container.clientHeight, widgets[i]); } } From 5d593b549353e17d281f6bfffe1098e2c84a8846 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 8 Aug 2017 11:27:26 +0200 Subject: [PATCH 057/101] Update examples --- ..._late_eval.R => example-reactive_values.R} | 0 ...teWidget.Rmd => example-runtime_shiny.Rmd} | 0 ...s_one_app.R => example-two_mods_one_app.R} | 43 ++++++++----------- inst/examples/reactive_values.R | 35 --------------- inst/manipulate_widget/manipulate_widget.css | 2 +- inst/manipulate_widget/manipulate_widget.js | 8 ---- 6 files changed, 20 insertions(+), 68 deletions(-) rename inst/examples/{reactive_values_late_eval.R => example-reactive_values.R} (100%) rename inst/examples/{manipulateWidget.Rmd => example-runtime_shiny.Rmd} (100%) rename inst/examples/{two_modules_one_app.R => example-two_mods_one_app.R} (55%) delete mode 100644 inst/examples/reactive_values.R diff --git a/inst/examples/reactive_values_late_eval.R b/inst/examples/example-reactive_values.R similarity index 100% rename from inst/examples/reactive_values_late_eval.R rename to inst/examples/example-reactive_values.R 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/two_modules_one_app.R b/inst/examples/example-two_mods_one_app.R similarity index 55% rename from inst/examples/two_modules_one_app.R rename to inst/examples/example-two_mods_one_app.R index 3dd89f8..2aa3029 100644 --- a/inst/examples/two_modules_one_app.R +++ b/inst/examples/example-two_mods_one_app.R @@ -1,3 +1,8 @@ +library(dygraphs) +library(plotly) +library(shiny) + + mydata <- data.frame( year = 2000+1:100, series1 = rnorm(100), @@ -11,7 +16,7 @@ c <- manipulateWidget( series = mwSelect(c("series1", "series2", "series3")), title = mwText("Fictive time series"), .compare = c("title", "series"), .runApp = FALSE -)$init() +) dt <- data.frame ( x = sort(runif(100)), @@ -30,33 +35,23 @@ c2 <- manipulateWidget( combineWidgets(myPlot(type, lwd)), type = mwSelect(c("points", "lines"), "points"), lwd = mwSlider(1, 10, 1, .display = type == "lines"), .runApp = FALSE -)$init() - -mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) -mwModule <- c$getModuleServer() - -mwModuleInput2 <- c2$getModuleUI(gadget = FALSE, saveBtn = TRUE) -mwModule2 <- c2$getModuleServer() - -ui <- fillPage( - fillRow( - tags$div(mwModuleInput("pane1"), style = 'height:100%;'), - tags$div(mwModuleInput2("pane2"), style = 'height:100%;') - ) ) -ui <- navbarPage("antaresViz", - tabPanel("prodStack", - tags$div(mwModuleInput("pane1"), style = 'height:800px;') - ), - tabPanel("exchangesStack", - tags$div(mwModuleInput2("pane2"), style = 'height:800px;') - ), - tabPanel("Table") +ui <- navbarPage( + "Test manipulateWidget", + tabPanel( + "Module 1", + mwModuleUI("mod1", height = "800px") + ), + tabPanel( + "Module 2", + mwModuleUI("mod2", height = "800px") + ) ) + server <- function(input, output, session) { - callModule(mwModule, "pane1") - callModule(mwModule2, "pane2") + mwModule("mod1", c) + mwModule("mod2", c2) } shinyApp(ui, server) diff --git a/inst/examples/reactive_values.R b/inst/examples/reactive_values.R deleted file mode 100644 index 33b88e7..0000000 --- a/inst/examples/reactive_values.R +++ /dev/null @@ -1,35 +0,0 @@ -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, 2100)), - series = mwSharedValue("series1"), - title = mwSharedValue("Fictive time series"), .runApp = FALSE -)$init() - -mwModuleInput <- c$getModuleUI(gadget = FALSE, saveBtn = TRUE) -mwModule <- c$getModuleServer() - -ui <- fillPage( - fillRow( - flex = c(NA, 1), - div( - textInput("title", label = "Title", value = "glop"), - selectInput("series", "series", choices = c("series1", "series2", "series3")) - ), - mwModuleInput("ui") - ) -) - -server <- function(input, output, session) { - callModule(mwModule, "ui", series = reactive(input$series), title = reactive(input$title)) -} - -shinyApp(ui, server) diff --git a/inst/manipulate_widget/manipulate_widget.css b/inst/manipulate_widget/manipulate_widget.css index 64c8ea5..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; } diff --git a/inst/manipulate_widget/manipulate_widget.js b/inst/manipulate_widget/manipulate_widget.js index ea04613..3bfe938 100644 --- a/inst/manipulate_widget/manipulate_widget.js +++ b/inst/manipulate_widget/manipulate_widget.js @@ -1,11 +1,3 @@ -/*$( document ).ready(function() { - $(".mw-btn-settings,.mw-btn-area") - .click(select) - .each(function(i) { - $(this).data("index", i); - }); -}); -*/ function select(el, id) { el = $(el); var active = el.hasClass("active"); From 85606f7b6480b071498674e67f7fc142e86e3603 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 8 Aug 2017 13:46:11 +0200 Subject: [PATCH 058/101] Update DESCRIPTION and NEWS --- DESCRIPTION | 5 +++-- NEWS.md | 15 +++++++++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 753ec3c..3fe9c0e 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 +Version: 0.8.0 Date: 2017-05-24 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 diff --git a/NEWS.md b/NEWS.md index a88a5da..fea106e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,20 @@ +# manipulateWidget 0.8.0 (2017-08-08) + +## New features +* 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 From a7cd48dbeb9fa44ff1714e908fb85cdf34ae7428 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Tue, 8 Aug 2017 13:58:47 +0200 Subject: [PATCH 059/101] replace isTRUE(all.equal(...)) by identical(...) --- R/controller.R | 4 ++-- R/input_class.R | 4 ++-- R/input_list_class.R | 3 +-- 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/R/controller.R b/R/controller.R index 6b124c8..5ab3d2f 100644 --- a/R/controller.R +++ b/R/controller.R @@ -116,7 +116,7 @@ MWController <- setRefClass( oldValue <- getValue(name, chartId) newValue <- inputList$setValue(name, value, chartId) if (!initialized) return() - if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { + if (autoUpdate && !identical(oldValue, newValue)) { if (inputList$isShared(name)) updateCharts() else updateChart(chartId) } @@ -126,7 +126,7 @@ MWController <- setRefClass( oldValue <- getValueById(id) newValue <- inputList$setValue(inputId = id, value = value) if (!initialized) return() - if (autoUpdate && !isTRUE(all.equal(oldValue, newValue))) { + if (autoUpdate && !identical(oldValue, newValue)) { if (grepl("^shared_", id)) updateCharts() else { chartId <- get(".id", envir = inputList$inputs[[id]]$env) diff --git a/R/input_class.R b/R/input_class.R index e1e489a..4d318d9 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -49,7 +49,7 @@ Input <- setRefClass( catIfDebug("Update value of ", getID()) oldValue <- value if (!emptyField(validFunc)) value <<- validFunc(value, getParams()) - if (!isTRUE(all.equal(value, oldValue))) { + if (!identical(value, oldValue)) { valueHasChanged <<- TRUE assign(name, value, envir = env) } @@ -63,7 +63,7 @@ Input <- setRefClass( for (n in names(lastParams)) { if (!is.null(oldParams[[n]]) && - !isTRUE(all.equal(lastParams[[n]], oldParams[[n]]))) { + !identical(lastParams[[n]], oldParams[[n]])) { changedParams[[n]] <<- lastParams[[n]] } } diff --git a/R/input_list_class.R b/R/input_list_class.R index 487866b..cd60bfa 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -126,8 +126,7 @@ InputList <- setRefClass( while(TRUE) { n <- n + 1 valueHasChanged <- sapply(inputs, function(x) { - #if (x$type == "group") return(FALSE) - !isTRUE(all.equal(x$value, x$updateValue())) + !identical(x$value, x$updateValue()) }) if (all(!valueHasChanged) | n > 10) break } From d3a3dd6c9a8fc1e7130aafff9bdd0323fd9e92a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 11 Aug 2017 15:22:02 +0200 Subject: [PATCH 060/101] Reduce number of input updates at startup --- R/input_list_class.R | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/R/input_list_class.R b/R/input_list_class.R index cd60bfa..7f87a86 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -37,7 +37,7 @@ InputList <- setRefClass( init = function() { if (!initialized) { - update() + update(forceDeps = TRUE) initialized <<- TRUE } return(.self) @@ -106,8 +106,8 @@ InputList <- setRefClass( res }, - updateRevDeps = function(input) { - if (!initialized) return() + updateRevDeps = function(input, force = FALSE) { + if (!initialized && !force) return() for (inputId in input$revDeps) { revDepInput <- getInput(inputId = inputId) if(!identical(revDepInput$value, revDepInput$updateValue())) { @@ -120,15 +120,10 @@ InputList <- setRefClass( updateHTML() }, - update = function() { + update = function(forceDeps = FALSE) { "Update all inputs" - n <- 0 - while(TRUE) { - n <- n + 1 - valueHasChanged <- sapply(inputs, function(x) { - !identical(x$value, x$updateValue()) - }) - if (all(!valueHasChanged) | n > 10) break + for (input in inputs) { + if (!identical(input$value, input$updateValue())) updateRevDeps(input, force = forceDeps) } updateHTML() }, From ffbe61f08b4ee81e41c78f95954fd6faf6924cda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 11 Aug 2017 15:27:16 +0200 Subject: [PATCH 061/101] Update dependant inputs only if value effectively changes --- R/input_list_class.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/input_list_class.R b/R/input_list_class.R index 7f87a86..324e8e4 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -101,8 +101,9 @@ InputList <- setRefClass( setValue = function(name, value, chartId = 1, inputId = NULL) { input <- getInput(name, chartId, inputId) + oldValue <- input$value res <- input$setValue(value) - updateRevDeps(input) + if (!identical(oldValue, res)) updateRevDeps(input) res }, From d419c961867b5d28ad9cf399c69d1416d2b3557d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 11 Aug 2017 15:48:32 +0200 Subject: [PATCH 062/101] Add a message when user tries to print a MWController object that has not been initialized. --- R/controller.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/controller.R b/R/controller.R index 5ab3d2f..233e1b7 100644 --- a/R/controller.R +++ b/R/controller.R @@ -173,6 +173,9 @@ MWController <- setRefClass( }, 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()) }, From 3e4a8967020896a5fe93fe584ee3052c2570aa41 Mon Sep 17 00:00:00 2001 From: TitouanRobert Date: Fri, 11 Aug 2017 15:59:57 +0200 Subject: [PATCH 063/101] add summary to MWController object --- NAMESPACE | 1 + R/controller.R | 17 +++++++++++++++++ man/summary.MWController.Rd | 16 ++++++++++++++++ 3 files changed, 34 insertions(+) create mode 100644 man/summary.MWController.Rd diff --git a/NAMESPACE b/NAMESPACE index bc08fa6..b3c938a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method(summary,MWController) export(combineWidgets) export(combineWidgetsOutput) export(compareOptions) diff --git a/R/controller.R b/R/controller.R index 5ab3d2f..99fa6cc 100644 --- a/R/controller.R +++ b/R/controller.R @@ -337,3 +337,20 @@ 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("List of inputs : \n\n") + sapply(names(object$inputList$inputs), function(X){ + cat(paste0("Input : ", X, "\n")) + }) + cat(paste0("\nNumber of chart(s) : ", object$ncharts, "\n")) + cat(paste0("Number of row(s) : ", object$nrow, "\n")) + cat(paste0("Number of column(s) : ", object$ncol, "\n")) +} + diff --git a/man/summary.MWController.Rd b/man/summary.MWController.Rd new file mode 100644 index 0000000..fee0b5d --- /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 +} From 8ec247878d88a515aa7cbeb4a95d4c5e42af590b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Wed, 16 Aug 2017 11:16:14 +0200 Subject: [PATCH 064/101] Print more information with summary.MWController --- R/controller.R | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/R/controller.R b/R/controller.R index 08ab128..7f47541 100644 --- a/R/controller.R +++ b/R/controller.R @@ -348,12 +348,32 @@ knit_print.MWController <- function(x, ...) { #' #' @export summary.MWController <- function(object, ...) { - cat("List of inputs : \n\n") - sapply(names(object$inputList$inputs), function(X){ - cat(paste0("Input : ", X, "\n")) + 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 { + value <- sprintf("%s object", 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) }) - cat(paste0("\nNumber of chart(s) : ", object$ncharts, "\n")) - cat(paste0("Number of row(s) : ", object$nrow, "\n")) - cat(paste0("Number of column(s) : ", object$ncol, "\n")) + infos$stringsAsFactors <- FALSE + infos <- do.call(rbind, infos) + print(infos) } From 91df535c6019586d0a1f3457bdb0525288963a34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Wed, 16 Aug 2017 11:33:57 +0200 Subject: [PATCH 065/101] Add basic test for summary.MWController --- R/controller.R | 4 ++-- tests/testthat/test-controller.R | 21 +++++++++++++++++++++ 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/R/controller.R b/R/controller.R index 7f47541..9a1ac54 100644 --- a/R/controller.R +++ b/R/controller.R @@ -88,7 +88,7 @@ MWController <- setRefClass( initialized <<- TRUE } - return(.self) + invisible(.self) }, setShinySession = function(output, session) { @@ -360,7 +360,7 @@ summary.MWController <- function(object, ...) { else if (length(input$value) == 0) value <- "" else value <- paste(input$value, collapse = ", ") } else { - value <- sprintf("%s object", class(input$value[1])) + value <- sprintf("<%s>", class(input$value[1])) } chartId <- as.character(get(".id", envir = input$env)) diff --git a/tests/testthat/test-controller.R b/tests/testthat/test-controller.R index 95142ed..2ff682b 100644 --- a/tests/testthat/test-controller.R +++ b/tests/testthat/test-controller.R @@ -79,3 +79,24 @@ describe("MWController", { 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") + }) +}) From 76a547a4696b69a433f958c86a6d0c127751249a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Thu, 17 Aug 2017 16:09:50 +0200 Subject: [PATCH 066/101] BUGFIX: invalid value when parameter "choice" is a named list instead of a vector. --- R/inputs.R | 8 ++++---- tests/testthat/test-inputs.R | 21 +++++++++++++++++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/R/inputs.R b/R/inputs.R index 5e96509..568092a 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -274,10 +274,10 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., type = "select", value = value, label = label, params = params, display = substitute(.display), validFunc = function(x, params) { - x <- intersect(x, params$choices) + x <- intersect(x, unlist(params$choices)) if (params$multiple) return(x) else if (length(x) > 0) return(x[1]) - else return(params$choices[1]) + else return(params$choices[[1]]) }, htmlFunc = htmlFuncFactory(shiny::selectInput, "selected"), htmlUpdateFunc = changeValueParam(shiny::updateSelectInput, "selected") @@ -363,7 +363,7 @@ mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) { display = substitute(.display), validFunc = function(x, params) { if (length(params$choices) == 0) return(NULL) - if (is.null(x) || !x %in% params$choices) return(params$choices[[1]]) + if (is.null(x) || !x %in% unlist(params$choices)) return(params$choices[[1]]) x }, htmlFunc = htmlFuncFactory(shiny::radioButtons, valueArgName = "selected"), @@ -510,7 +510,7 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = type = "checkboxGroup", value = value, label = label, params = params, display = substitute(.display), validFunc = function(x, params) { - intersect(x, params$choices) + intersect(x, unlist(params$choices)) }, htmlFunc = htmlFuncFactory(shiny::checkboxGroupInput, "selected"), htmlUpdateFunc = changeValueParam(shiny::updateCheckboxGroupInput, "selected") diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R index 5480740..009ddeb 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -26,6 +26,17 @@ test_input( 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( @@ -36,6 +47,11 @@ test_input( # 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( @@ -71,6 +87,11 @@ test_input( 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())) From 13fe4c995eee3cb08f5d84c9027f8797bda41ccf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Thu, 17 Aug 2017 17:27:27 +0200 Subject: [PATCH 067/101] # Hack to fix https://github.com/rstudio/shiny/issues/1490 --- R/controller.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/controller.R b/R/controller.R index 9a1ac54..5c766b1 100644 --- a/R/controller.R +++ b/R/controller.R @@ -232,6 +232,12 @@ MWController <- setRefClass( init() setShinySession(output, session) output$ui <- renderUI(getModuleUI()(ns, height = "100%")) + lapply(inputList$inputs, function(input) { + if (input$type == "select" && identical(input$lastParams$multiple, TRUE)) { + input$valueHasChanged <- TRUE + input$updateHTML(session) + } + }) if (autoUpdate) renderShinyOutputs() }, error = function(e) {catIfDebug("Initialization error"); print(e)}) }, From abbb1f44d0fb7f2f214388edd6dc5c289b7c0ace Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?fran=C3=A7ois=20GUILLEM?= Date: Fri, 18 Aug 2017 11:22:15 +0200 Subject: [PATCH 068/101] BUGFIX: all inputs were visible at the beggining --- R/controller.R | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/R/controller.R b/R/controller.R index 5c766b1..10a4485 100644 --- a/R/controller.R +++ b/R/controller.R @@ -152,14 +152,12 @@ MWController <- setRefClass( updateChart = function(chartId = 1) { catIfDebug("Update chart", chartId) - try({ - e <- new.env(parent = envs[[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) - }) + e <- new.env(parent = envs[[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() { @@ -232,7 +230,16 @@ MWController <- setRefClass( 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) From fc5740ceb1ca24b213630ca16977d1ec452b6d52 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Sep 2017 15:01:07 +0200 Subject: [PATCH 069/101] can now pass value as expr (and can depend of sharedValue or current variable) + fix dateRange control --- R/controller.R | 9 ++- R/input_class.R | 114 ++++++++++++++++++++++++++-- R/inputs.R | 29 +++++-- tests/testthat/helper-input_class.R | 6 +- 4 files changed, 144 insertions(+), 14 deletions(-) diff --git a/R/controller.R b/R/controller.R index 10a4485..d412c1f 100644 --- a/R/controller.R +++ b/R/controller.R @@ -373,7 +373,14 @@ summary.MWController <- function(object, ...) { else if (length(input$value) == 0) value <- "" else value <- paste(input$value, collapse = ", ") } else { - value <- sprintf("<%s>", class(input$value[1])) + 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)) diff --git a/R/input_class.R b/R/input_class.R index 4d318d9..a675f63 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -1,3 +1,83 @@ +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 <- deparse(value) + + 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) { @@ -6,13 +86,18 @@ evalParams <- function(params, env) { }) } +evalValue <- function(value, env) { + tryCatch(eval(value, envir = env), silent = TRUE, error = function(e) {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"), + "revDeps", "displayRevDeps", "value_expr"), methods = list( init = function(name, env) { @@ -27,7 +112,19 @@ Input <- setRefClass( if (emptyField(idFunc)) { idFunc <<- function(oid, name) paste(oid, name, sep = "_") } - assign(name, value, envir = env) + + 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 }, @@ -39,7 +136,7 @@ Input <- setRefClass( setValue = function(newValue) { "Modify value of the input. If newValue is invalid, it sets a valid value" catIfDebug("Set value of ", getID()) - if (!emptyField(validFunc)) value <<- validFunc(newValue, getParams()) + if (!emptyField(validFunc)) value <<- validFunc(evalValue(newValue, env), getParams()) assign(name, value, envir = env) value }, @@ -48,7 +145,14 @@ Input <- setRefClass( "Update value after a change in environment" catIfDebug("Update value of ", getID()) oldValue <- value - if (!emptyField(validFunc)) value <<- validFunc(value, getParams()) + + if (!emptyField(validFunc)){ + if(is.call(value_expr) | is.name(value_expr)){ + value <<- validFunc(evalValue(value_expr, env), getParams()) + } else { + value <<- validFunc(evalValue(value, env), getParams()) + } + } if (!identical(value, oldValue)) { valueHasChanged <<- TRUE assign(name, value, envir = env) @@ -67,14 +171,12 @@ Input <- setRefClass( 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( diff --git a/R/inputs.R b/R/inputs.R index 568092a..c3e28eb 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -84,7 +84,7 @@ 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), @@ -125,6 +125,7 @@ mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) { #' @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), @@ -164,6 +165,7 @@ mwText <- function(value = "", label = NULL, ..., .display = TRUE) { #' @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), @@ -207,6 +209,7 @@ mwNumeric <- function(value, label = NULL, ..., .display = TRUE) { #' @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), @@ -269,7 +272,7 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., 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), @@ -312,6 +315,7 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., #' @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), @@ -358,6 +362,7 @@ mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) { 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), @@ -397,6 +402,7 @@ mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) { #' @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), @@ -439,7 +445,9 @@ mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) { #' @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), @@ -447,9 +455,18 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ... if (length(x) == 0) x <- c(Sys.Date(), Sys.Date()) else if (length(x) == 1) x <- c(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) - + 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") }, @@ -505,7 +522,7 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ... 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), diff --git a/tests/testthat/helper-input_class.R b/tests/testthat/helper-input_class.R index b9a12c2..377ce71 100644 --- a/tests/testthat/helper-input_class.R +++ b/tests/testthat/helper-input_class.R @@ -7,7 +7,11 @@ test_input <- function(input, values = NULL, expectedValues = NULL, name = "myIn expect_initialized(input) expect_equal(input$env, env) expect_equal(input$label, name) - expect_equal(input$value, get(name, envir = env)) + 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") }) From 29475d7a0014596368edb928f210b40c76c301b2 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Sep 2017 15:01:16 +0200 Subject: [PATCH 070/101] add examples --- inst/examples/example-mwSharedValue.R | 45 +++++++++++++++++++++++++ inst/examples/example-reactive_values.R | 6 +++- 2 files changed, 50 insertions(+), 1 deletion(-) create mode 100644 inst/examples/example-mwSharedValue.R diff --git a/inst/examples/example-mwSharedValue.R b/inst/examples/example-mwSharedValue.R new file mode 100644 index 0000000..d4c35ae --- /dev/null +++ b/inst/examples/example-mwSharedValue.R @@ -0,0 +1,45 @@ +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 = 2001, max = 2001 + (nrow(data)-1), c(2001, 2001 + (nrow(data)-1))), + series = mwSelect(choices = colnames(data)[-1], value = colnames(data)[3]), + 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 index 767e8e6..55df37b 100644 --- a/inst/examples/example-reactive_values.R +++ b/inst/examples/example-reactive_values.R @@ -1,3 +1,6 @@ +require(manipulateWidget) +require(dygraphs) + ui <- fillPage( fillRow( flex = c(NA, 1), @@ -9,6 +12,7 @@ ui <- fillPage( ) ) +range = 2001 server <- function(input, output, session) { mydata <- data.frame( year = 2000+1:100, @@ -21,7 +25,7 @@ server <- function(input, output, session) { { dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title) }, - range = mwSlider(2001, 2100, c(2001, 2050)), + range = mwSlider(range, 2100, c(2010, 2050)), series = mwSharedValue(), title = mwSharedValue(), .runApp = FALSE, .compare = "range" From 2da186ac741c71350fd355b92306b2cb444c854c Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Sep 2017 15:57:36 +0200 Subject: [PATCH 071/101] fix deparse multiple line --- R/input_class.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/input_class.R b/R/input_class.R index a675f63..2c685e6 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -18,7 +18,7 @@ controlValueAndParams <- function(value, params, name, env){ assign(new_name, value_name, envir = env) # modify expr - char_call <- deparse(value) + char_call <- paste0(deparse(value), collapse = "\n") m <- gregexpr(paste0("((_.)[[:punct:]]|[[:space:]]|^){1}(", name, From b6a540e80b42e8f0913e0d515eeb2eb84aff071b Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Sep 2017 16:48:57 +0200 Subject: [PATCH 072/101] fix mwSharedValue passing reactive in shiny --- R/inputs.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/inputs.R b/R/inputs.R index c3e28eb..a57595b 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -586,8 +586,12 @@ mwSharedValue <- function(expr = NULL) { type = "sharedValue", value = value, label = NULL, params = params, display = FALSE, validFunc = function(x, params) { - if(params$dynamic) params$expr - else x + if(is.null(x)){ + if(params$dynamic) params$expr + else x + } else { + x + } } ) } From 2287a1560551a6584e71cf06d37a2ae35997535e Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Sep 2017 16:49:06 +0200 Subject: [PATCH 073/101] update test example --- inst/examples/example-reactive_values.R | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/inst/examples/example-reactive_values.R b/inst/examples/example-reactive_values.R index 55df37b..401d718 100644 --- a/inst/examples/example-reactive_values.R +++ b/inst/examples/example-reactive_values.R @@ -27,11 +27,17 @@ server <- function(input, output, session) { }, range = mwSlider(range, 2100, c(2010, 2050)), series = mwSharedValue(), - title = mwSharedValue(), .runApp = FALSE, + title = mwSharedValue( + {"init"} + ), .runApp = FALSE, .compare = "range" ) + + titre <- reactive({ + input$title + }) # - mwModule("ui", c, title = reactive(input$title), series = reactive(input$series)) + mwModule("ui", c, title = titre, series = reactive(input$series)) } shinyApp(ui, server) From 9b08ef6ec72d9d51606b74ba4f82a8f527eb74da Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Sep 2017 17:08:33 +0200 Subject: [PATCH 074/101] mwSharedValue -> disable dynamic passing reactive value --- R/controller.R | 6 +++--- R/input_class.R | 5 ++++- R/input_list_class.R | 4 ++-- R/inputs.R | 4 ---- 4 files changed, 9 insertions(+), 10 deletions(-) diff --git a/R/controller.R b/R/controller.R index d412c1f..718c916 100644 --- a/R/controller.R +++ b/R/controller.R @@ -111,10 +111,10 @@ MWController <- setRefClass( inputList$getValue(inputId = id) }, - setValue = function(name, value, chartId = 1) { + 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) + newValue <- inputList$setValue(name, value, chartId, reactive = reactive) if (!initialized) return() if (autoUpdate && !identical(oldValue, newValue)) { if (inputList$isShared(name)) updateCharts() @@ -257,7 +257,7 @@ MWController <- setRefClass( observe({ for (n in names(reactiveValueList)) { - controller$setValue(n, reactiveValueList[[n]]()) + controller$setValue(n, reactiveValueList[[n]](), reactive = TRUE) } controller$render(output, session) }) diff --git a/R/input_class.R b/R/input_class.R index 2c685e6..e1ee28f 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -133,9 +133,12 @@ Input <- setRefClass( gsub("[^a-zA-Z0-9]", "_", idFunc(get(".output", envir = env), name)) }, - setValue = function(newValue) { + 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) value diff --git a/R/input_list_class.R b/R/input_list_class.R index 324e8e4..678fbb5 100644 --- a/R/input_list_class.R +++ b/R/input_list_class.R @@ -99,10 +99,10 @@ InputList <- setRefClass( res }, - setValue = function(name, value, chartId = 1, inputId = NULL) { + setValue = function(name, value, chartId = 1, inputId = NULL, reactive = FALSE) { input <- getInput(name, chartId, inputId) oldValue <- input$value - res <- input$setValue(value) + res <- input$setValue(value, reactive = reactive) if (!identical(oldValue, res)) updateRevDeps(input) res }, diff --git a/R/inputs.R b/R/inputs.R index a57595b..c2a64f1 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -586,12 +586,8 @@ mwSharedValue <- function(expr = NULL) { type = "sharedValue", value = value, label = NULL, params = params, display = FALSE, validFunc = function(x, params) { - if(is.null(x)){ if(params$dynamic) params$expr else x - } else { - x - } } ) } From 4ed7e17da7e93509f00912b3eadaebabe9189515 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Thu, 7 Sep 2017 14:24:23 +0200 Subject: [PATCH 075/101] update .initial on shared env --- R/controller.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/R/controller.R b/R/controller.R index 718c916..b91ca63 100644 --- a/R/controller.R +++ b/R/controller.R @@ -57,7 +57,7 @@ MWController <- setRefClass( inputList <<- inputs$inputList uiSpec <<- inputs ncharts <<- inputs$ncharts - envs <<- inputs$envs$ind + envs <<- inputs$envs autoUpdate <<- autoUpdate outputFunc <<- NULL renderFunc <<- NULL @@ -96,10 +96,13 @@ MWController <- setRefClass( session <<- session shinyOutput <<- output inputList$session <<- session - for (env in envs) { + 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) { @@ -152,7 +155,7 @@ MWController <- setRefClass( updateChart = function(chartId = 1) { catIfDebug("Update chart", chartId) - e <- new.env(parent = envs[[chartId]]) # User can set values in expr without messing environments + 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]]) @@ -167,7 +170,7 @@ MWController <- setRefClass( } else { finalWidget <- combineWidgets(list = charts, nrow = nrow, ncol = ncol) } - returnFunc(finalWidget, envs) + returnFunc(finalWidget, envs$ind) }, show = function() { @@ -186,7 +189,7 @@ MWController <- setRefClass( if (!is.null(renderFunc) & !is.null(shinyOutput) & is(charts[[chartId]], "htmlwidget")) { catIfDebug("Render shiny output") - outputId <- get(".output", envir = envs[[chartId]]) + outputId <- get(".output", envir = envs$ind[[chartId]]) shinyOutput[[outputId]] <<- renderFunc(charts[[chartId]]) } }, From d106057fcc7393bfd50533b28d871873207c4a71 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Thu, 7 Sep 2017 14:25:14 +0200 Subject: [PATCH 076/101] use oldValue for validFunc if value is NULL --- R/input_class.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/input_class.R b/R/input_class.R index e1ee28f..7015b49 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -151,9 +151,13 @@ Input <- setRefClass( if (!emptyField(validFunc)){ if(is.call(value_expr) | is.name(value_expr)){ - value <<- validFunc(evalValue(value_expr, env), getParams()) + 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 { - value <<- validFunc(evalValue(value, env), getParams()) + 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)) { From d9cc2c25121e3e1531a55e1026df59b093998219 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Thu, 7 Sep 2017 15:11:24 +0200 Subject: [PATCH 077/101] updateHTML : keep current value if valid when changeParams --- R/input_class.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/input_class.R b/R/input_class.R index 7015b49..c4f50ea 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -203,6 +203,9 @@ Input <- setRefClass( 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) From adcd0f3ad9cccbea69fc59a46ceb4c56948419cf Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Thu, 7 Sep 2017 16:29:12 +0200 Subject: [PATCH 078/101] init visibility checkbox --- R/input_class.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/input_class.R b/R/input_class.R index c4f50ea..8f3017c 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -190,7 +190,7 @@ Input <- setRefClass( condition = sprintf("input['%s_visible']", id), tags$div( style="display:none;", - shiny::checkboxInput(paste0(id, "_visible"), "", value = TRUE) + shiny::checkboxInput(paste0(id, "_visible"), "", value = evalValue(display, env)) ), htmlFunc(id, label, value, lastParams, ns) ) From c5f9879292df124c2e69b27a4eda6c389260e789 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Mon, 11 Sep 2017 13:03:55 +0200 Subject: [PATCH 079/101] fix export bug (envs) --- R/on_done.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/on_done.R b/R/on_done.R index 97c91ce..9da447e 100644 --- a/R/on_done.R +++ b/R/on_done.R @@ -7,7 +7,7 @@ #' @return a htmlwidget #' @noRd onDone <- function(controller, stopApp = TRUE) { - for (env in controller$envs) { + for (env in controller$envs$ind) { assign(".initial", TRUE, envir = env) assign(".session", NULL, envir = env) } From 1c491f42f051f243c95fc9bcbc0b9b8f883ba604 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Mon, 25 Sep 2017 12:51:30 +0200 Subject: [PATCH 080/101] add message if error occured in eval params / values in mwDebug mode --- R/input_class.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/input_class.R b/R/input_class.R index 8f3017c..1b0304f 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -82,12 +82,16 @@ emptyField <- function(x) inherits(x, "uninitializedField") evalParams <- function(params, env) { lapply(params, function(x) { - tryCatch(eval(x, envir = env), silent = TRUE, error = function(e) {NULL}) + 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) {NULL}) + tryCatch(eval(value, envir = env), silent = TRUE, error = function(e) { + if(mwDebugMode()) message(e$message); + NULL}) } From a60b70cdf92bc3f742aa286bde17c28fef3720da Mon Sep 17 00:00:00 2001 From: TitouanRobert Date: Thu, 5 Oct 2017 10:18:07 +0200 Subject: [PATCH 081/101] up version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3fe9c0e..a6dabb9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: manipulateWidget Type: Package Title: Add Even More Interactivity to Interactive Charts -Version: 0.8.0 +Version: 0.9.0 Date: 2017-05-24 Authors@R: c( person("Francois", "Guillem", email = "francois.guillem@rte-france.com", role = c("aut", "cre")), From c88a73230d47aeb59d169da03e1e8ba03c7b97c4 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 25 Oct 2017 12:00:09 +0200 Subject: [PATCH 082/101] update tests --- DESCRIPTION | 2 +- R/input_class.R | 8 +++-- inst/examples/example-mwSharedValue.R | 6 ++-- .../test-get_output_and_render_func.R | 34 +++++++++---------- tests/testthat/test-manipulate_widget.R | 18 +++++----- tests/testthat/test-on_done.R | 4 +-- 6 files changed, 38 insertions(+), 34 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3fe9c0e..d016874 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: manipulateWidget Type: Package Title: Add Even More Interactivity to Interactive Charts Version: 0.8.0 -Date: 2017-05-24 +Date: 2017-10-25 Authors@R: c( person("Francois", "Guillem", email = "francois.guillem@rte-france.com", role = c("aut", "cre")), person("RTE", role = "cph"), diff --git a/R/input_class.R b/R/input_class.R index 1b0304f..76f8faf 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -11,7 +11,7 @@ controlValueAndParams <- function(value, params, name, env){ assign(new_name, value_name, envir = env) # modify expr value <- eval(parse(text = paste0("substitute(", new_name, ")"))) - # case of value / params of type call + # 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) @@ -84,14 +84,16 @@ evalParams <- function(params, env) { lapply(params, function(x) { tryCatch(eval(x, envir = env), silent = TRUE, error = function(e) { if(mwDebugMode()) message(e$message) - NULL}) + NULL + }) }) } evalValue <- function(value, env) { tryCatch(eval(value, envir = env), silent = TRUE, error = function(e) { if(mwDebugMode()) message(e$message); - NULL}) + NULL + }) } diff --git a/inst/examples/example-mwSharedValue.R b/inst/examples/example-mwSharedValue.R index d4c35ae..aee302d 100644 --- a/inst/examples/example-mwSharedValue.R +++ b/inst/examples/example-mwSharedValue.R @@ -33,8 +33,10 @@ server <- function(input, output, session) { { dygraph(data[range[1]:range[2] - 2000, c("year", series)], main = title) }, - range = mwSlider(min = 2001, max = 2001 + (nrow(data)-1), c(2001, 2001 + (nrow(data)-1))), - series = mwSelect(choices = colnames(data)[-1], value = colnames(data)[3]), + 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" diff --git a/tests/testthat/test-get_output_and_render_func.R b/tests/testthat/test-get_output_and_render_func.R index 4b585c4..37211bc 100644 --- a/tests/testthat/test-get_output_and_render_func.R +++ b/tests/testthat/test-get_output_and_render_func.R @@ -1,22 +1,22 @@ context("getOutputAndRenderFunc") describe("getOutputAndRenderFunc", { - library("leaflet") + 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 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) - }) + 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-manipulate_widget.R b/tests/testthat/test-manipulate_widget.R index 82b50e5..8e52388 100644 --- a/tests/testthat/test-manipulate_widget.R +++ b/tests/testthat/test-manipulate_widget.R @@ -6,7 +6,7 @@ describe("manipulateWidget", { paste(a, b), a = mwSelect(c("a", "b", "c")), b = mwText("test"), - .compare = "a" + .compare = "a", .runApp = FALSE ) expect_true(!c$initialized) }) @@ -16,7 +16,7 @@ describe("manipulateWidget", { paste(a, b), a = mwSelect(c("a", "b", "c")), b = mwText("test"), - .compare = "a" + .compare = "a", .runApp = FALSE ) c$init() expect_equal(c$ncharts, 2) @@ -29,7 +29,7 @@ describe("manipulateWidget", { paste(a, b), a = mwSelect(c("a", "b", "c")), b = mwText("test"), - .compare = list(a = NULL) + .compare = list(a = NULL), .runApp = FALSE ) c$init() expect_equal(c$ncharts, 2) @@ -42,7 +42,7 @@ describe("manipulateWidget", { paste(a, b), a = mwSelect(c("a", "b", "c")), b = mwText("test"), - .compare = list(a = list("a", "b")) + .compare = list(a = list("a", "b")), .runApp = FALSE ) c$init() expect_equal(c$ncharts, 2) @@ -58,7 +58,7 @@ describe("manipulateWidget", { a = mwSelect(c("a", "b", "c")), b = mwText("test"), .compare = list(a = list("a", "b", "c")), - .compareOpts = compareOptions(ncharts = 3) + .compareOpts = compareOptions(ncharts = 3), .runApp = FALSE ) c$init() expect_equal(c$ncharts, 3) @@ -74,7 +74,7 @@ describe("manipulateWidget", { c <- manipulateWidget( x + y, x = mwSlider(0, 10, 5), - y = mwSlider(0, x, 4) + y = mwSlider(0, x, 4), .runApp = FALSE ) c$init() expect_equal(c$getParams("y")$max, 5) @@ -87,7 +87,7 @@ describe("manipulateWidget", { c <- manipulateWidget( x + y, x = mwSlider(0, 10, 0), - y = mwSlider(0, 10, 0, .display = x < 5) + y = mwSlider(0, 10, 0, .display = x < 5), .runApp = FALSE ) c$init() expect_true(c$isVisible("y")) @@ -100,7 +100,7 @@ describe("manipulateWidget", { x2 + y, x = mwSlider(0, 10, 5), x2 = mwSharedValue(x * 2), - y = mwSlider(0, x2, 0) + y = mwSlider(0, x2, 0), .runApp = FALSE ) c$init() expect_equal(c$getParams("y")$max, 10) @@ -118,7 +118,7 @@ describe("manipulateWidget", { x = mwSlider(0, 10, 5), x2 = mwSharedValue(1), x3 = mwSharedValue(x + x2), - y = mwSlider(0, x2, 0) + y = mwSlider(0, x2, 0), .runApp = FALSE ) c$init() expect_equal(c$getParams("y")$max, 1) diff --git a/tests/testthat/test-on_done.R b/tests/testthat/test-on_done.R index cd8b725..dbc6ad6 100644 --- a/tests/testthat/test-on_done.R +++ b/tests/testthat/test-on_done.R @@ -21,7 +21,7 @@ describe("onDone", { }) it ("returns a combined widget if comparison", { - with_mock( + suppressWarnings({with_mock( `shiny::stopApp` = function(x) { print("Stop gadget") x @@ -39,7 +39,7 @@ describe("onDone", { expect_equal(res$widgets[[i]]$widgets[[1]], paste("value1", compare$x2[[i]])) } } - ) + )}) }) }) From 14e769172d08c77dce84d54594a11bdb25219da6 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 25 Oct 2017 13:17:55 +0200 Subject: [PATCH 083/101] add simple shiny module test --- tests/testthat/test-module.R | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 tests/testthat/test-module.R diff --git a/tests/testthat/test-module.R b/tests/testthat/test-module.R new file mode 100644 index 0000000..fcedce5 --- /dev/null +++ b/tests/testthat/test-module.R @@ -0,0 +1,20 @@ +context("Shiny Module") + +describe("Shiny Module", { + it("returns a well defined shiny module", { + c <- manipulateWidget( + paste(a, b), + a = mwSelect(c("a", "b", "c")), + b = mwText("test"), + .compare = "a", .runApp = FALSE + ) + + # server + f_server <- c$getModuleServer() + expect_is(f_server, "function") + expect_equal(names(formals(f_server)), c("input", "output", "session", "...")) + + f_ui <- c$getModuleUI() + expect_is(f_ui, "function") + }) +}) From e1e24884b1c83b4368209da9e67640fae41950c3 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 25 Oct 2017 13:20:42 +0200 Subject: [PATCH 084/101] update date --- NEWS.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index fea106e..e1ed964 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,6 @@ -# manipulateWidget 0.8.0 (2017-08-08) +# manipulateWidget 0.8.0 (2017-10-25) ## New features * 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. From a39f42145dc4f98562a3d7f7b312fc30f0a09584 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 25 Oct 2017 13:26:40 +0200 Subject: [PATCH 085/101] ad codecov --- README.md | 2 ++ 1 file changed, 2 insertions(+) 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 ================ [![CRAN Status Badge](http://www.r-pkg.org/badges/version/manipulateWidget)](http://cran.r-project.org/package=manipulateWidget) [![CRAN Downloads Badge](https://cranlogs.r-pkg.org/badges/manipulateWidget)](http://cran.r-project.org/package=manipulateWidget) [![Travis-CI Build Status](https://travis-ci.org/rte-antares-rpackage/manipulateWidget.svg?branch=master)](https://travis-ci.org/rte-antares-rpackage/manipulateWidget) [![Appveyor Build Status](https://ci.appveyor.com/api/projects/status/6y3tdofl0nk7oc4g/branch/master?svg=true)](https://ci.appveyor.com/project/rte-antares-rpackage/manipulatewidget/branch/master) +[![codecov](https://codecov.io/gh/rte-antares-rpackage/manipulateWidget/branch/master/graph/badge.svg)](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. From 42fa4044a4b4396be54421137c3ced0dc9ffc763 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 25 Oct 2017 14:07:52 +0200 Subject: [PATCH 086/101] add some tests --- inst/img/logo.png | Bin 0 -> 44784 bytes tests/testthat/test-inputs.R | 2 +- tests/testthat/test-module.R | 20 -------------------- tests/testthat/test-mwModuleUI.R | 23 +++++++++++++++++++++++ tests/testthat/test-staticPlot.R | 13 +++++++++++++ 5 files changed, 37 insertions(+), 21 deletions(-) create mode 100644 inst/img/logo.png delete mode 100644 tests/testthat/test-module.R create mode 100644 tests/testthat/test-mwModuleUI.R create mode 100644 tests/testthat/test-staticPlot.R diff --git a/inst/img/logo.png b/inst/img/logo.png new file mode 100644 index 0000000000000000000000000000000000000000..5fe3742ff687a4bdfd6af9b82f9a5acebae7214c GIT binary patch literal 44784 zcmeFYXH-*Nw;4aCs!jgKQmn&MSG~HnB5;3u^>+hDauD#HOSk}-rdnp;EAKNs~70XMicgmfU5)O zim8mQgswN((Z%&X%*W9Xre|aibGKJ;xT2~epd6$~A>irgXD1Nk>EY$87zDcV7hOfl z{hwy>D*}Ik__>3w{4JE3E<^wf^>GxC5t9gMqC+1do zVK3i*6h%>)c#xg9xTKhbxToize*FdQ>u2Ej|BLaTLi-v8dpn97IQl~Uee5aY;dJ$1 z$Q0fE?-~68q)4Oq$j6m3D0UwAp!WWrj$VEb?t!jQo`^ZPIw;2BHJVJ6?my7EFu;2Af2;AeKLs&se)Ji*t?rw62 zzX)Fy_}TS+m8`R2IYq#2U>8$T>Kffwa*ME;z8TDVk4&+|W+>+PXxdr(lff;TKQ7%B zB4b4T=Z0tAj3f4lt|-al>s20%s4`ls#R0K%#0{wU#uz&EH&h9$qlQq7y7?l7{u&4I%FSl8k<6Dq zQ&Jep_tIv*KwZaAuTx)Bp$YKVFT@^9!ibAGS9PxDkJ8WZ3O{=`iiC_rRo+Q7299$C zzc4I!-}O#n4Kf7n24+hnvwpbBMeW%NPI(1e33y&P{IeF4!JuK?Np3hx!M_{crXwwv zSi|M0E2Itn$k~|&QEZkrT_hK8m5*KCsY&qk7@a>KgR~KDE(}~hfMhVun~Q7J8~u%H zWQZPe6Tgiq*~~t*k@&fM6(k3B9l^Vg&O=3)KTdqu!Y`LjToiQsr6?aYODhOQj3@1JQfi=VBJ>TyIl#e=b77gpmt3-L?|6 zMaSf$!;W8dZ92j&z7gtUBu$ey`2)X*PncH<=An1EHR?X8pB_1 z)M=F&z6JCi05QDZGj&?nBcezy;3=6O@p(bsHa5puy5 z3h)_TCoy7~D=oNGC^#az?naTLiP@5dpxzF*Ov&~-WF6qBI!wtZDW=qgLiuq650)X* zyqyn>ew5_SzDI9oPuD{&hOUxygy03hzsTi1iixg~Gq0}y#%&+Q(_SEFVyV$Q5jh!) zI%*$%Mga+@ioTT_C1P`-bC^T)NyT_JJ7a_gw|cR{8-CXLZAjRqPMj#W1;by&ZhVxT zYPpiAEixX`6e+9*TnN?|UvuSHyPhvf56p3+z|eaOVTl~2!i8&8V#IcNNI^pwOZq&3 z#*1M-1Co*d56ILRsEhm4clZjI+y_}kFse~Y0 zCvPD=O!Ij4hFghO{~_0KUA;jfQO=?|f8wPPL*5(Yid)$Hg%}P+{TF1e;WK~fbgTM2 z=^Mw|(jGU!x7AO6I2+i|9cFzpnr-)=B zEQLo!8Zl|RhB6eev-M*SeWxgFv_w-@M()3Vj5K%YzcDi&FtY(}P)Gz8(f*NIZoi|V4xXQ>>w z&F{X?`jXDm=_YPVKR*UB_y>Ud%fxL_i-OLb@nMgk_m;fglSwC~};! z%5|%7DVrdRSRA1;gw@z>=FoL6I~%>x+x#d$ebK*q{IKdv_UyY2M#qc85yB&EowO)F zvucBRY;_3J{-cApe!Ks~n7_hh^!Jk@8lhqe`Rh4NGARK2qX+#L+NqZK;i7RQ_MnhDM~T?L9XaI>9k6@MCkK7_uuO<$t>D(c3MiE zcok}Zd?qO2Tj{QhakZiPf$EWR;J(5z+d}VUOE^_)^%GVr*A(>zk;M4u%7|sEyst~B zkSmEeGwIg=LujnrW|a(b`yE8FF#8o?(c+ls37qa~JIF`{0?0XQv| zB^>U$RS7wP#w;vR2|Y@kxd4EU?KDJ-rcCVL)A6SJW4OvJNk{dk*~JtNuBd5h7P}Ge z&TgZQ#D}qiFY=$-HkerMKHlz1Mo$4dO<%J=rltrLA+2vaL2KpMKSE8F7Z1#8{*is4 zSVF~g2^uDZLv9PlEZlK|DJF^|x0#9Q1{={z*t_aqEY&%Hx7!%s6|Da9X`${|TL{bGXe)#V%%i~#xXX$RR8kN5 zj3op;U5YZ~bXT3eJ$Sr;ADq72`2nJGv6Hpv?DrTB;e!cCm}|dugl&}1BcVTWnxgoZ z9QXPd1II5qiw#p7o%NJB76U*nLQqM<)Hgn5?Im(jwKBJ}b#AR_rurd7{_-XL>fF{; zaKoFTKdw?grp6@Lj2{)aTws(^bqKUaQ1){m8kg0%pb;9D=d2zYQ?YBOp0{=Ce^dSl zIiT^r%Pj`1@Ht!brgWV-JlO3ggXl~@U*`#=HfsC1hObb*w!4t?^U9HIW5JC&7rVFe zJn9OPiMfBmTgvY?)RA)H=QAq{*J6MHBD?kw^4&IJxcV4RClnk!bShG(iz=ydss5=P zlPB)tP9vHzz~6a3rdD#)tN&H<#Ld~uM)Bhh?aYOIk1j7C@h%cJ7%71n$T081g(zDX zK{GlA3&n_}l=aV&#H}+KRMD6dUw^R-64}C(OXZ??jZ4p*Ud)2(`t3pTKuvHh7E4fX z=l-q_3wLNH z?NQ1O{TB`a?3bTEtZ7A@TCGLo;dzE_S?6zZo$6f$+sv~3?glCjQ0qmYuO}+qbeSo( z3r*3;(UpZCmu$14Hqb-_ZVhFZ8l7YdpHgHlW03Hr+r`ZPE^nN>cd=4vygZJrU(3^K~hepOIW#-CDBh)n8sxFBCCdDxCc_mCDUXbmu zA3PT-Trf+P1UR|oA4;k$M(Eg*?+als?qpp0CGF$zJ=-R}!?zj#e%jk~%4#*@RuYGJ z@$o*aS@6Ud@G?sFJA2CTAn_ca$ocpA0FEI2@6BD{_s@m^>J8sc$&d)@hju6a9HIsR z%V#^3I$~M~4`X10?0zjvgxvh_%+f~eSN!Qu5iIS%GRE)FKlH;XrtIeia+{ySljf;J zul@Z)@=53^bVs7lw*M;3+t zRbL~s)Msw)FxNAp5Dxm{7GSRB;va2aZXO|u2`)it2vvM`1}ffSDaT_-FX({~Vs$MV z9qse@8N81+>_o9MsCx+h<~W%Sji`D_!g>%Je-dj9fEis}gvnYT_!)Zd`8=K(x+6~6 z@a3G@r`&fwWVAh7&OyCHxXg*)%|!(~f?uuc;2GKR^hh?9mAQ|1>fc0TtB&BQuikcU zk(PB0p}q5S(#?ZIG&?Lx0YJmpXjNKH&?lYW`_pYFZ|s|Jv0ox!?y?p~0g6R(-8low z4X2*{%3rK@6-~(vuHUz&+27QeQBuT?c4XZ$p&(EQ_o{Nq?&ay@2Ey?z-eTNV;IS29 z`SjmlOr%dTN;1s(j1JV6YzMoh(r zHfI?x$|T1>e?J1JqfA?DQLtH(}cf0Jst^Ae}$mPX2(^;wg&)7`0%CKdML<2f!je2(LL zSl81w5vA~DLIurPdTBoyr(1{XegY8Z_9|d!GVM4!NebE|BN4V~#1pDq$pz5uOQ+xC zXB7ZrOH{Z8Y>w%Hg5qcJ;Fl5{S4x(b_*Qtr?Pgc~H}K|@j9tYg5>ecyDbc5 zRYTX#*1v2~{pQI?aj=*(sYqWd-5{Ex4DMyqpsOoQ(n3YZGaooIVUBU(m2HtYRaj8G zZ)z;@f;9nkeJAi)%N_^dscH&xB|xqHROPqeZa!*qg?i>q^iZ2QUI`a($<+9j7;=ls zZFGtgGs{mf0kARB@$WYN_=FB^jlU%(znCTx%h0|Mv7sI2bz>ZOmjL!HoSq@T8tUvX z1%1L{vp%DU%83^Ac_d-~X1i-w zj*k#;+A3-5o20F2&VCgto3qXp!YL^1Dn@1F(oPUz%Ac2W9Z=$becKZYQ34^-l+1TrXIpz z1+-2r@8`^rNA7jO*39IC)J5Jr;z3)a^D&m#QVDmQIBv9dN~m(?59i8q`hY#%HE2XH z7*IJ4hdu&-9=a$Ozg!Ts{IPN17d&w2?np>hFX8<3K%+7wL@JNEM6(WgA;YzS@K*N* z?bT9Pfw3h2jy)fG7JaukN=mjpL>FXx`kR=r(LOY8Gi!3%vKn zyJ?D$%71S4yal#|^ky5YBV>EvkT?C)u$U(;c|a-Riz(Lw=$%pl@)D$le@BL8t4pRs zyc7>EHfftm>QH!HEZz+rDoTj|y)RdMq`dhCNEshKmTy5H@g8I4JjvF(zpZ>z^zwv- zrwyQ4avjos!4#&a?R)`bTILteW37SQQpOguG)e$1SmeT0E7b6F)^^~NvYv{0DB-r%4v zoA*Yab$515^ga{cOzU98JHWBJ?bU3Q2obfb4Zet$^X8(edI!_rrE*p=)~|5GJZ%wM zAbnhrb=8l3A_qmZ(-;Qyro(Eg5Bz*y;fs-hZab^$CZCPMV*V`H)5d_ma9YiX^I289|O#?aqlm868(ucZ&w_2wro?hv_Inkn@t31wA3!}pR~qp z7+cNYwA!xO06<>bqSYU@_9tNSPDN zRatOfCXUUL$PF6JwcH0&C)^)*I+j7wMQj~xvbgLisbh`V5H)G-RBY=@~2vG$Q$`WG~kAM8uKaZ3T{JfCt zORmO}6ig<)M+Fh5SIq%{OLvE>5KZ%{B2uDDIMZ}~!%l=A_8XvTa!n8xJc5^lP2?dh z&r&k_8{8II({g(uG){6d)zx($GV-ALio!i-0ERURXAX;xS9EDx%D8*lPB5{OwosDh z&iXA_CJ6Xqk8=|gBN8^9RG{^c$*W|CWN{y?%4hb${OF5NOtV)dP1=HIXg5vZ|xe{0j|!ilcP3{wG*R@b>M1eYnooG}~^(@SYl{*;9})4N$piMXycPl+(LA zw~hf4>LyupJuH;6QKq$Ztz&%dNoVix@s~P ztGV`w$d%gio>o6i55WAC`rhXiVWg=QKtrY#5>vG+vT-p>xB%175R_mghf3 zLtmo$^&@%98?(nZkH#;fLvv^LVKEfZTC7@fBC0pXKLU@uh;tkBvXmuJQF_=%*P~-? z1tQg*v}Kl}-m#$`cXd~{yd{!ZPIO`6IK55Vg0zv>r`E=gaS9OP#Urayn}a|O7V{Bj zz0_yoKj!@1kMS9cD0BFhEA0c(YuiR~jUUVOWgq;UBIh=Q@mIRce$dcp-n(TZJ!Aw( z^uy{|O{mv)S5ar1cGw6Y8CY&OPe&VZN>nU>NF! zPycMagn4wFHhqSt1N@;WP{MJ3O`)qKH6P>Eu4EEb_vnD2+m<9=RUlUe>c#gmI&oU= zN|<1AHTvXGN(|?pODE6XiH`N-bE%&Le}I4MUQs{zF27;ek^9Z^uvul$_Yynfa85E1 z^vR~a>QxBfTsBAYCNaZkiqRVMs{kT=IDCbJS+ljT<(N$y)lCP+a z@c3gGE|+J~LT8Q@aA-I@A@L;2b5CUXK~D|iFKPf+s7Z!R<8Fwk=nq7KMjOw~chfO? zw-wx^JXx+cOCsotIiVb0urq?DzsD zop|YWKZUtea;=s=!;!dd6{Rph zlQeA-wx%Gzgx5cTwQl+Pq+JvXSml=nK(G4#OAcG}1v?Gj5gCH}u{<6vkn`Rl5GJ(t z1GeU+6egDSrF@}xY9^xD3Zr=o(4q81{hd0+A-p=bFeK!5F!ppYnbncjo7m#|GZGDd z0nfxel7w|IkQg7YX`HLyo$P~o=~DJ}c>U%=Vouem!mV~4ESYGPmt$4CJm8?$uYbF| z@Y?cK;90BP*UfMorRmivN)-e=U5f2QtbW!l)^NK`MeK7upKu_FpIAj{Vip0Tqni-g z5Efio68pda${1s1nLmSBa;79C9Juv?;J#mCr)~|=wR=Hh>!&t^y?D_SfN57`{K?aC z?Vrl`I2s?iCS=~uE2K&&ar)4#H6<<6-jZO*`uN$o7bZxhgrWj^I?Q>XTr&j2POzMX zQv#65K%K!Ch?S`Gt+V?=g=Vzq1vHZ7i*4-hCQw#2;Vp! zPcDjXJPhVp-DmkW*uvjgCwdzElKZe|8Z7$Dr~bv#<=cl+E!DGUsiN*|#;o`_r!d%^A|7_fX&N zRG*G+GOKcOs~55h;@vt(1ulM_(W1-g0}|iVIe_M#{WeY;PDPPv1BI6Ei+ry~9EJOuyc_ zhk#hsN_*4FVSl(p$J3QYo7vf_zNn{{1aO?eo-V+tNON4k_!CvrA}pHl)YEDiAZydJ z2A~9oNG~so5A_j-ELl`;t<9a;!8axfZJ@?or0%WOow(OnL-BZ|WX5BCz%nLSSww%MuYp4~P#08g zxw@}_m^x7yiJVMw3f08~a0Wrl*X>AS3~{q(Pcw>-L5{ek_GH2U6L^@UBRlV-OW*Je)P4bN`VvSDI!qSnwX1&QqdlE+NpeT7mAF_Wn2FW7)wa{4x za{>P%mdM?+vzce-?QDJ&BD!X|_ncjI)w9U;y&j9Na(A0)t(1qy`;G~WUFP(C*w+aL zQQ%0=-i)_NTxPCKI{xcXXu>x@snSH`GZklim5a+K^)G@v6ZOp_h?W*xaB9tP$E#%A zz^hMy(XHa!!f#HlB=Q`GI+5l z*97op?7B;SB+6L(@)K8dcg6$8w!qIW0-qy6YjQ2(#93AW1AY1Q zq$Ls4DgAq=>O`gY#R06zcEvP!YPH;6?yVk9cSYVm#~0P`jPy0c6QSwSlVO_Me&Psh z4upmGV~4NsfVospr2%kHg=d4HxwG!+#b_ASA%+)?%E$wdYjUY-y5n(2c=V>?{e}8H z|B~egN3XtZpz^R}0N~YArWF_ZO$J~#`<2Ws7|-6DhEaZDYlr@js$JzSqd51gnJXF* z2RkRzJ~i)`LEqCejO!Sb!pbsx#v;SYI5>lKsGOdL59-cexE+?DP35xPK5*`gm505* zH#d)i+kIyMpCNcp^K=K`BmM5;G?neL<7m4qb*9U3KjrvkJeyW2FGs63G0JY}>aH## zo?8!Q64zKrYP4P;$iH`W}kRh+!@E{hPh)z#CO7 zwzyAwC77XJb6Ag6BWucW{UE_UwQla$7gH6cG$ErRoId6m?hssT<#r>;B?mX4{DuEO z!OCjE{c@`ay*JDvH$T{2;TzS%EIWJd>D-&cN`-Npg|quz(kCHAHongO7emTdh$XIS zEG+&!P*y)r;OxCvm+l5bKo3B4nf;^46i~e~Dckh1vc(gc`i>P%Fa$s6Z)p33oP}G_ z^zD+4_G$+Gkgi)ri=?y_Xc+r=-c7Hbi@qF35}4Hl=mF-pHe}LvH;#FWSbHuL@He(g zBG7R#qfkm3&w z^9&sT+qk8z&{9#05yTxpl6a3Tas}1hmZ8i2XJ`U1%*46xhT_^6T6N~zF_t10`rB`L zZB5&VH&kuMzaA(<3&e%4Tob-@G|={A%5Zafw@R8$w2A})-HH$1yj4RtcVBaAQAXy{ zhV<=_2MAh07XRknm4#{L7A@-82LPt!3hfQPeEe{f*G^7WL4y;w+dd0GFDeb!O9s;u z{R-u_Kb@Ii0-xAO%jvY;z;5`z+aQt^PMLEF7Gh#E&MVD@ay#xPTzxW6HAc2pKyK5v zhzxY$`Ex0TjT7+?d{?%ogy+s9PHlI5@8E4Ws*~r!UR&OT0ACsv`M|0#$|ruUU+3F?9bJm#(9+fQ^|KbzGW zhT8IA^4xdgg1_@Lfq*_kml3VomLDt9q!AnGHqu?*eLUZnYZ`L8RJAv(F>*;kZ!A{* zbL?Qm6JjEk)bhG9_%qD}AMn?!QXUq;A;=G=BehoL)8nbctsN~7kBM*_00FKnzeG6w z$~f^%psYoFH~X8S;_+o}Pmi*R7qGeGUq7{ScsmJM28i9y^yH(|Wj49T7 z1PY8kaxUcD=ir%`&_km{`Fe=%jT8K3N8pUiw>th|B4`qu91i`m{q>4npK5gUv0WSB zh`{%~zHE9Cw|Nc?=4;~MI?T&dy>yGX7i)B;NVc_5aEt3S*T^zG^YN*w;nU>{lBbcb z-;+ZrhhC?+WG2qQ==*xJ7+H+qHY5UXy7BpOjfVD=IFYLVH@Z-BLk(~fyG4bAZjl3Y zWodIyK)k_J~>aip6G2^Ofoc(>6nfV5>rLUc%ifga6vP1RsQLq`8uwnTl*nNu?LTJV5 zDhvRnYwqDE`Szs}ecg{nAMLR!m}vz*FqB(KkZEbIHQ zA|LJHR(HFAgoIh^OzpCtPh%Q(vDfa)Cm7_yThED{3P$9*bjl;2#}d_9M@L7_B^;a# zg4&j*vAg~X{a+N8qHoPxJfjsnL*U@C(f_HQOwsafZZJ$+|(jf}zS3nq@< zJirPh(!vs#Qmw(_KVp^?v{m=h!9fbM-s;_XPSaq7v$Oy6`H4X}2fD*A$4W<`)#d(I z8bLSj`xdwzmKLHk*#fPy z4+7Cem6RESQ##W=eEF}_#sQJt%@He^4WV4-#BwGM*|E%YWt?oFbXPLiy-<7fqc8XB zP!FsLX56&4%2S!SzErc(+~*j$wpJ4<_?5+xwd$;JCP!djhPT{>845w_GCzxmrQIS$ zrK?wK?euam{*IRPP@PsV`2PxDTA7xqqXHgk8Pg= zesaW76+dyY`?A3!-t?yh9u`w3S4{-$jec%H3AI*yXAmaa`05Lhf?iOHlmuGYfxfGkVq~dH z#b(oGMs5fPFq+>vTXXwE?Q1W1d3{As%gIDeZI!#XpB;xfudq?E#?B1KMT#O?{R)u7 z+%=znD{z#unS!K$OFT~-7nTR#tj0}brb*+`?smY`0M`D0{P`&C7HzcMwC(=N-s1~Yxm|J1bs6by{tZ2RLk~Tu|$DO z410e0EPF71DBw(S0V5Ta#ISJa`Gh@4PpylieEsxnBFpQ^Y0H+Qud;` zRmU&N9ZG%oF5q2`P!dd3Dx@gyZg{Ghvk(usa9$e7|5`m;*f#uUWnJL+ut^yg)#(X$ z0PkWI;S0jHp=8)ZnlntH)a}7|uHe~ePW9Oxt#dcmlH*ZN^RAjtTowv1>bzk5L11t~ z=99-!DbE1Zazpj)*3I^+ui5P0f4N1lY=*1_r6jFXImhm%B=@Z+qZH-HovgP0{q?BiH8}1@N@afN{SX| z%@>9XzoTpE0CLEGD-TroC)K+VY|B;8H;AY`yZCNrtoau8A)$v_`ZDl6ME`))r^Vk53qUwK#=teI5Vs z3FD!b5E?qs-;Ya4L?vc8r|`I~P6q1+=+npE^dGXcrk^;Hz6~n$enI zhwD+bujMX3Gx1Dc5FIh|rS~efSoQ?F4}6frjlE;DAmDJXdmME}?#&u+)To}7O>e>o zwyrO7RdT|jR|~Jw)aC^Cozu)lNNqn6y7t|%pKVwT?CCQ^O(>8a|{a*NCPjFj89}}l~XAzqS8sF!dBslHA$a z+D(<3cP@rgX5y1EAaB7$7WhUgY#J7AFalD3qVk%eEM#=B3{^u1QM zVi6RJp^H6$1(T!%Lf#7YUGN^7` zna9B(1|usie<|v@4+DdvanLcKY^54dx5C0VzE0N{0xakH~6ns1Ho)dF)R0zV0njoJpEu`*A;)Jdsn+JsTc$1Mfy`=-L3yRG3+K3iT%m^UipyH2XE5G&(${vYdyti<^{nYh zY|O^h3P;xD!&R*&*lHODwAY6UQyP`JMEuY*Ehs1uk&>sJP;GFhs~XdH4=Xn0Ok2FG(Kowg zzRPXFW+too-PD zxn>-9n=`Gk+#WA!Xjw>}OLLS4c(L-IR37VD@OM@wqn9!$C$l8xt`x=-3`=;gROcrH z_{^ml4&Os30hvkyA?Xcnf!D9sSe0-$FC+7dwqPx=F)nHlQPNh!B=OH(FS| z=A1m=&XpRHLa0Z=$LpS&; zr!WVqydxPN<8>Z>2jn3UulOKX8a}PsU0vv~P1o1SFX-p)$otYgt(!eHloZl3wr6hj zGTS>=Z_ki@$p_TyUz4%8@+qm(N|G3v=&_i=MHf zm6wq4h^Aw5|LopkW!)`;zYe?R$dt0Onj*8dw-xK_;i&Bxsv~YWpqz5I35i@wB9n8b zzb>ofF9{~Dg)B=lq^#ESaoaYp@Aidju!VPK^=>uudP0v+9y@Sto4Cq_>3ZPys6A#t zgZ2Ru5^3C1N+oRFjNUK5uJW-ZJ~X!k$6D7k535*2%<8@qEOC9BpsH-QzL+h&L^7T? zZ3c?eY|nN$OtOo#h^N{m+?}s!aQ6ubI8e?J@MjNdwg`QPddNOdB3g}iye7Ttyk^~n z-!J}9J*p+=H@OG>854we-xT z$$+T7y(&!T-f_Bh0Io%40{AR-<00E^NecrLo--qjBglTtf^^c_bzdG&HGAvNYRaB= z^hjLES~({Sxi-StXfv6Lwh#}F0gCa>4+8$I3hb%%iXpO3mz{hrKZq^6*HEe8s-3!n z{aU?xRMs-fc30C0r`adyEfbwZZlCweAva&wUd$cGsd`WXV=WJ5!4VB$8AVYPVA^Zi znP7OuIqdZrn*#Dp0BNFjotiuy=cVMS7io>D?4B+!x&D0X7xHd~9J*i3cKiu;9PbQo z+cI{2p&b;y^4BYe+{lCR>!N$D5n<#3-{@?w*6|{x&mXDRX}u_UcQ_Sizc5r}*qZts zDk99yxoy#^D8%(-VrMFHB)62#NjsbgRZ~?lVpCNx){{2D_C@c!`1wvzrN%YiUf#-y zz&$f8tijE_n%Cj2{3k%ce7mEN9(cJD$NRC}CKf4Vl3 zZe6SN{EP5v)K6yb%Q=UAZvsId`|{p^P^+ne9V4q9xJ3fAH9L0HdE99=lmlBIp>l{p z?LPV}DIE;r+uAWJ(4_3w%;26eA65jC$;o<+bKN`c*(2yEu&h63Nz_J_I4#Dry%RPX z@2KbpgWq22$niyZr}T8Ez4lGmUYY;ST<Yuk?a6T`0BjfwOV-E`2m+Rv8l(?EZP@mmX7u4fq~(GGGXaG#DObl8dJz z{mNUQykE2J_z|a#k@Ff7pcF~hLc(}DcMLDx?TS~M0Ez6)SuCTPhH0#@(LdM1Jet(U z?r3x*O3m##OU_IBop*p!%1-R2DV8FQ!(-8ybioszey@_3bk5OKu7jw@GqPL z{mAZDyoGHC#xdA?o&b}`{uM(jpL*gw(YACG$H}!ETsFR-QL}YoQKQ8#;_wV^DIC{5 z{kl0a+*YCLDy8564Z(-X%8N z=pdLQ0xR)>cMu9U?x^&_T^+IwXeOI^IaQn>0!uDMOc9?v{pcM9s}+A;)H>(!Si(`m zU&HtpU3tq$Ps)S~q061udH~CoBDJ4m4ca5b^On=G?rC7J+;Dg9xOZt`eQeMkA(>Wr z$kt+0S6!1;QZOuPi!B)rYi{ZY05F@_ho^R1GF-!;hyxHC&Q99t^1>f(uRkSqn%Hla zL0Y&vdz<_3I3!fP4#3DgWcL#z*;_6MUMFAC38v9!8G?fk^n_H2=YI8F8@8_EAEXpj z_ansPgB}E3m0WK$IBtG?!iA`fNa0i^o(brm;U9qEeYaM;bO)jKAADeo9OigDdk+13USE8BA+$Aw08< zkg~1E*B&9a@!*CZJo^mL5ZhV*un+w3D+?BUTUpx|u^eGuxkUAvpvACYAvEheFOMZg z)^v&)9&WVRD3xd%RFJ$V?{*w=ii3#hou;tN$Dl&mBV85Wh-~?mDk|Vr#T!(b7|&xF z=i#Wy1?nPRfPx!nb>*<(TB2!?waoAO0L^BvfS~lrWn74)njSjTNeH_^LVt>0g*LjLHjRSI5n|dXfiSOvT)}tW#8ME$V+)fRAg@;#0`tZ7M=BGL8G$#BB~~ zbL;b*zD@Fk73}w0fksXY;jYd`;Fqe_65ePvL&Kaw)yr=UnH`;;Tlngb--*k)e=k`8LtpA>-n4TA=07inLt3 z?xzFdBcyIAk7oV^VPI_!^?_RwCfJPobRKM9jX3kWpd&yt1mE zj0tvuWjBPTRRQQ`>U4Bm7>+LN^uhqrjPi9sqoIv2c1kjdK-Cr* z8{C2N8@)rxl3n}h6>1V*`5wW-$_$fX3ZJ>Js%!mAaF!D|vpX%$JbwtW`9N?EEX3|< zEC0UDHtmti0`l6N3qsr09Vjyw6C2G}I{Yf4i9AQ2`y$SSg*DOD;U>%gPX{*mdV^oM z?}n4S5C#30eDQq;2L-BZK@G7iy*-4Tv|T#+)F&t1<@lSsFodT4#k2B>I7p{#muEQu zy-}{aMx?FjMoi>5Zoo^OYfJ7fxgTb-FRwUih%j%5;IgLnzvwsl2KEj;uj52GA~P@c z^kW2-!%oK9WU(zHdW+w&`NpV|Nw!}Z%F2)FWK7YGJ^sGH*i1L6UY_S0o98qIZ%R)| z?VW?x2L^%5^L09E$H7rHr=PCyyjN@~K6(VwJ#BoCV8wF-fFHE3_HG{q`cGe0ZCkO! z${EOYSmjV=c-wiF6OtosRz1v|Fbknxe-1ejNW^cgpe{WC&@m~~m+ggbKF+W^zK0MW z(<9=HK&Pr4#LXf0{V^K?wN3{Ss~(&czF`^~_JyXm=mIeD(~2hbF9$$E-NJsC-~Iu# z`;e>wgmDDBkZAxl{T>4g$iETI(z9m{^Vy%LRc_&eUcZamP6fo1N1 zkh)y6qE%&jyPLu9|CWiD>L?vw+l?vIrI1E_W?H9dS(C?z|7XuF^Cs$iBL zCeUVCSB}aZf@jIKxujQ=u~9czdK)LZe8wb*lGRO6}JaKwEy?hG$n>i!jeVbxwG}}YIs22 zQn%}4?_H%adA=Dih3x6i-Ar9!bdToc;;n#_NMn@M{>?xjPN%5u-j@-iqNU|bE%kE! z#5l-Bb#%<$k~JD0JmqI(B7NoeV|@8kZLzbT*{6pp)djH&N1~o3Ra(W+w!L#P{5~eJ ze&QpL=J<(Gs~mYZtD+=LrZcwB~(c?$)3Qk9Yq zh-wIEN)ypabF-6JXee$mAs@Rah|pz87=&ndhmL1nn){V+#l24_Olsh99D!E1O zm!xtT=91gyR&JGRA#%Uuepzyv+sq}D+g!$6HhMC*UzWe?G`(b#xJn*?^GzhQ8Q;7dOpYc4V{@qLq1Nr;<&-fz5z$>iaxRg#Mwyq!n`}h2;WcR-5 zPn8inT3@OMs)O=FLF};ZfHU2iLmTK(Nq1mb^}=$K^?~jp8(8bRh(opEM9;M!RMBXu zmhQ^G6lj}dz9F@t(6d=bxetopZvh35;_?Iu*jCOdD-tQ*f9A*NBsZUQl_y#C#IeKn-k-U~P z@T0=z_Nv!dX(DlE$PJ^0Q%83IFAf#X`cc^nV5^+W22a zJhW8R?_heu%#U!8r*P1iDr}a$SAP!FUfE#$5(1)ln+={KbB&Lp6Y*iAyL{A<~ePj4Ygwn9?+Fdi5mQrm3>SRv9xi z`PsZB*pHYn(~O=1jZf{)U%&dGK<#EV2-?n=##IJw@lf8YD68I|WYp3B%*t}rFUK=& z!t$ewSJy;9Hn{&p1l&p@o{{A6TG3-Bc-4Asj1ItTQ|fI&RP0E%vp=(13j#p-FNjs6 zo}zDK1C9;9;-sRA{eJW#%b!Q;+pfp9*PlFh$-m{*P{tj(x_Q%0#DHL>I&A@N_Kedw zRvY{!TWS?j_=RaN#;F3{#_k>}0-=`=yk>^OC{ikPnx#<%%TdR{s@nnvbZm)-PzbD}JS ze$B6e%RMtuP|}Y&-4m|2dRNTk{(E~vU~Q0Sh57(C?! za*D3hQu&g35-7e5>g0p9+pNBsx$M~Y zF<9+`tSt%Pt5{!G>~0{YsQmN3D#aRVpGNIel@;HnojpDs0|8otPRW&fD*8NwG}W|z z5zv*bm8)w3D>WX>?$gq>!>0ab0<_TO{F3{_-a4yOQ%$ah2uw0UF^4RAo^Ba?DYeTa zhc!@!K z85t9-M8#XBj6x~GcZfd9-p8#I`4n(v&z<&ZW)^|c-`lZ{;Q!nNsq$}z5;xxgKaeHN zkQObZfS;;zBq+}pOYI|LLcNdyimTaxk-Xnl9?Cx5o$15V&_%(g0e`wk*w>Q|n^sqf z=ZcG1*p&T4!Ybfz_R`gF!{{`X=B!30hPHBBaGMs=D!AGx>S7eTx(^{|2E{65_$6%+ zb^`KQ)ohL7S26iIWNPqOws}qCOKa}o+PVQwm=FMvnYbW;_)T%kTf2Sg(BBs!K3G~2 zeaHaO79>sMqfiD16w*QL*PePc%xpHE0)G5f1uNp^iuD9b@7&9R4&~eVrylyoQ57(C zaqxgP5rJ(+P>IaVL%TUDZQ?lP76Y_v6QWqKQSaS67S*}SmSH&v4{Tm@M0~<4uu*H% z#22iyC101_>#HgV1GeKP-+Zek7t&BTf%ehnNCB&{jGBv+Uwz%VVd+!RA%=lb!xlZb!4>q{{H2nF zwRICm8&Sh7oDq!Xa`BCNW#0X*KOZYj;~{?B1!5;x`_b&ZEI$r!vS50gP6#a?J64qS ziOmqGeH1WO-#%q48hZ{rbd;ghahdqKGxpcuuG0-L{qt`hsQU8z)y?C!G!(&nMaqguB_eY+r0KC0FmSUB-)8->whYYD-?Jfk= zr@KITcw2cMLoL7VRK;fgf4PMtc)kI81o|44!)em}*um49fFv?qjv2>W!lO9|qR9Qgx;8RjZMzD?mE^$xU)P z?Dp!}^aoIXa79@W`SQqitB$=D+S-r*Y8}SSLD1bXTOwkkUxuTSzzX*6bF>DYbKh)~ zeCxEe1}ZeDTUc6_+TprO4w`xKkHP%FrNtH%zveu?U>HBKk_qs&{L&%djegsZ|DnCR z^qjV7q+#k6X2@d7M1%1kSqbJ;1X<%=1Q(`AIHXK>~6{hQJAznZmZYU?%gTsx)qK~b1stM|mIb-?`pCDrc_7cLM` zk&QDHK@_OXTYt8*xfIWMtAF|%0kCq>h@7t+rjTUB_De_ewi}?9s_N0 zUF@x9qgZ_OLDE4)S=RDpuRuKwh&Na5C#D-{=iu|%BGcDF)6d&?F|(rX)xyLFrJ&wg z8G9=lhe7YqH)CuT>9?9yyIeW80X|z9b2{!8gKq2;I^v-NK%u)oQ_-AngF=ltKWIHG z6!p-HbgG}}QyqR{X;83z>&lA@fJw584r0C3<7yAQj9`B+mS7$|MSL7oYQoON_r4Z1Z~|vr&@4PLw-9*Y7@+Zg=Dt{lS2O;F{mN^aS;v4fjdVwP3q|($;H* z&^2BO_tzW`Lv>Mhv7$*27mG4Bo>c1oxI9%>8vm~11r>5r&Qva3%Dsc+_|!?LXywVS zG`h;_aVT^<(!O%`kO!D4c2(n=9U1JjlQVXX#&C*II4c2WkA0WVOSrMnt5B`7q(X%k zSxas1EHFzv zn^0%f9Z-BN$mHYGfxT#E>uuW}DRhxddUBnA_p_XPwf#@2bR+3v`PX>EsS(xIlJg=c zOnT%^_svlDRZjIoIJ6)#1`YdUe65^2hzDJ#lmDIu@reI8iq=9KA+Ht*kF4bGZpS1P z*miV-rw_YWl5&rWk7S>DhFq;o*I=yzJDZW)+W#h~p0<4yp`Bf;xVii&rY%muJB#0P z4qOig@stHXubi8`X_G(1$z^gBd+W;|L}w3AV$I%*b7dNAEvEGC>i5&ek=ZiyfS;O; zZ|MkE7@h0F`05# z#(W+jc)N-N8G4}JoF(^2F?&?jETCan#Kj3j+Ex9hwt#%$8mjVgkz%AgpUqs2fZ)Uk z8QsKB@B!ZB+pY9{hSfz{z-Y&}gX^|13BVYFkRzQ)+)j-mI1n7m#+vn&1X~aFvw!EYb*&mGju?>{=vBiIgxum$d=1HeCl-{`W~J; z;!6xRNQtbx4tl=2{Lx*4IQZ)2*r|FB{i}xibvtJ#c-`i~VV8g19)8J3EPB2WE(^Ah z?jA-pUP(LCERK6g$&A$g27g%N)V^~^5k=;>UB~r;#;NW)MCx0p04e{QbIs<`j<{UG zQ!klspV^?NmB*v5E^xDWad~vA7=W~M8=6a-qJ!llpM7}sY%zx0Pe&-Pv8?Gh6inMZx?W){{G2&^3=iQ)HmxBcqmX< zpg7}(@tHFh!(PBAaT|YY|FmYP3g%uk>VUex-}N8eo%1ByFd#E;7AXa~{M`{yq}rhcJ7{#kjI_i^L-w0Z ztIV^Anal97*ajFIuULVcYQ40hiA`Yo`XSxcg)-v8@}g~C+ut$laExb7T^h-;HjV7c zAstHI-Pk>N5GOH^nHxB8)7CXFVF5=ZXTDuRr8W-nBudwcDJWrG??D$9sFpQKG{WiQ zpG*%BQCi-=(_9aXTN{Ycno%Txi<}N!v((Hu8dI#`WfVs=+Z)a30BD`4m-|LkZ4PW7 z=7|o!!Z0C;!`cgQgP-t|ROs?!#Ap11D7euJyh|im{cUi+p_HDk%PFxKTl(b#LM8Bj*o;(cWb}PE!lvLf&MZ;Gs{jIA1L7k zyUd-wWmz-76kqZ4g?tM9rAyVk*-|;}=XVKi7oVP0y*?BJD#u83rXMR4XTyqGg^;fC8yaK>4kZ{_PZCzMH=I^>caZ3*-E z)5va1<-(^!`yk%Mh5-!*iKNeHJCo^Ktne?R(Ro76I5fQyB2GVI6f68>!>a-*mULC*AV!4Hxy zTLnb^(|pL4o0d>|BCq!784e4YFdQe2}m)?jLljV6scmFzrNTNX_v z=MJ9wtB^A8uQDZ=O70)|iBfTemp`=N8P%HZS{EqX2|N$*%*=K?++D(MG`_GYcGUOg zVs(a1t9Uj0URuq%v*A;8Y?mMNEqdail{ft^Djx+rNB`yaIRL#v!Y&-a`?DUDWNqzQ zzDry_x*q5F1rwFQM+5hN84ZNM=QKjof1f%b>MkTEDth=1kuuX2*lNF_)kvBCu^F5bE(a-}ZYmGXV(4&`0PBMf_a zJ$SAlfr|vg%G>i*wU)#;{PfU_b(U4^GXSG;w2)|Buc@BM0}Qk$~j>{%fSAa z`|+|buJPpND#^B{)Z(UY=vtl${z3;52 zuQzcN_J?C>Ka*xQOn)*QV2?_2Cl%TjR_->F&_V5a1k|e)?>UWVIJZHx^Y4=GjrhYu z@pp?VR2{}wXY-}*X3y_+?SkJ8`Zm~2W_pM3c5~-;f@MUw<~Msh7BgLFz?SxPvA1_z zOpIKN0k{osf$KH-!&B(SAHs=f{Y=r&4f-!?E9&S9esb?j|BuW?WE9Hs@ZC2^@Pixp z_B)eL=WgX@T=eeHR?s1kkRw!coRz|t7a&*lIqWSf46(VP`^o`(Wb$Juedb<~TVSjY zq1R|Vix+ImeNAC)z4qc;xyen@E5cKz<9SBanqo&=$ZHRn64deM7ar1~57G9dNS}*~N2A#E3brt_z z%kTtrsd53%Sgpk3b~|OyQdD2d4s1|tVmB*%x2GYQ#AviVQx{43R&8Q6MT|n!@w(;zNiHUH~bo>$*KmDH%gF!CFL@oO$Oxfkb zF#$-T>!*A{6?K~ODQ=I%ABo3O?A%MH!)`qXTd5O=+{!dV8P&#@wKa;4K{fXf)HJ0M zB_oCP%~5U%#asy^U3%(AwGWL^I&Q_SC-7qlKOHOupL+{3CWc!~>66fnxOknixZt5YEswjO z_FIlfRQTYi+)k36Iuk_TM{HPAMJuJciALzdKRwl<=O2bjXr#!5du>Iu`sVnJ2REXp z#<0-3-nj2C3_p$-kayM4?k#J}f^|i}o&IvdkJrO+&Crp1{hEEw<<%D*6$(k9I*G&4 z5l%A)Z8y@{qLJf#mQsd(XuHcai|0%B%dcQgE0v5;%;Bg9PBm+l5UvK)B7adV`*WNsV7!4uG#5E9vAN*giJq=z#XcrKW z>KrDq#c+*p44C(0;{Y*4~MQ(itt&Ne^Sfe*;1_0 zSm8Q%eTO>hgBCz`~o)nw!G)!`mihh0YPG4Lf>e1@n$mR#U5R#mQAJ%50)HeoGdjln0ZGY@sJdD&z z|0B{zV@fLNt29{WLYtvAaUM}CpxNd3WhZ@33krd1Rd(o;es%9Avon6(tNr;zG_Av- zd8uBht_u1mxISPUuH*P;%8c6;ewjF=;u;0{YV~#L)dL?B^vi6e2)FB8Z;eX9x)Q z7gqUbZ~7{Z{8?djJ(h6S@!?0o%?h3x;`Gia)JTy!y>myhMHXjnIw{WYy17nlE}`uMnq&J#h7p)=>qMvh-Ag4J z+gh-fcg&sC`kw>6E=qmQi1gBoM|LFZqy&&u4q?P)t_B^rN1#|!Ne(e+Dlq{ zXkkgmC-0=M<^2zHFxUA2i;Hp_BHNTeAMM8`usNxVvdub7xjYKP2lQ=V2mi-4+HObf zZjDbs=;%EMy5x*~0RZ4iqtOGRcU(s_ucaB+U5m%NN8vxY*9T4^hhCKgyYDchOAM_aV)A=)b%PiH>5Bb&o;4|D+9H~|0^K$WiLH4(ePXZT1=399 zM13jrR_kcOBV6AEUj3CF5oa%9De#=p!AD-yozhIWTD#PE%FPPDG45bs<}<|0g?-0c zXu6=9A39g$2JqRLTy*ngw5Tv)?2A*|Mo0fAGbjFfr;BK+ph@0R^PgBmq!lT z0ug?Q4!3+^rIcr9vI9pTxP8LQ<_QSl{dIvTKg5DZtd`#%-%Hzn-SX0unYX_M4_#8B z`dBdGg8VtkZUA!JkeG}y`~+0{KaMB=DnQAtqVXo9!`AHoT5&%2J%!XTy<28 z@d{`k{Yzkeg)-}mTu5g&7a=(ToyPH5q{xcxP|pIciOuEBqqdGe`$uUwhmhLe#~cX> zta9R6b4uIMl5NO-U&QK0HfAEk4&dLvrrenq;N)Fh+4)0+b>>JQV30yq!tm>^@s;-0 zU(HFshziI=cf~{X#$w|%fKRY{0rkCDiw4`vh(jM_mMS2(gTJ=Zx*gKk6JOYFQYPtsf@s5_jc)gjx^ZB15R{U~y%|J1XQV<@5v^!}Ziy~q9% zK~5nUrjwPKOT=F~EsY1xEkz3n;0~7FK0B$d=JThqwzldb%~Lp%~p*-Udf0>(N&_*#YTlHGvqgh)C9Od8hTEC9-G_SYtMFoNwh{n2#Paq z4&DX66XT_E5rfpgUcnftBUJ^9eR)ODj`E1wOM`>WLgf2zF>rl5t`+40UJ@7Bl`xMf zyH?$KlR$NCh5Vxhubq91d!b}YGz-YdUcz^tA>93o&tV+~12uUhXv~{B>0E{I5YUR$ zlSbF_TlLR%=YV_O6KfitpSXG^f(Ihq%8SZoLe@PZ2#`xPwNDoz@^z_(jd;}{NoFv> zXFp)VDl**>ek8yHPh?f-tA87~uimY}5==i75Z*eN?$Qx2^bS=q;S?$S$iRX0Ch00o zYxQHN7}50T=elfG3c^VYu&$|XMb`OQvHon^y{YnhiIaZ^n88UXZXMgK?qdij*iHv<}o1ZFLXsMussk-X0 zX5`B)`pORblldBv!t^rp!#yy$Mkg?jCii_0+P|3qN1vG&ENt#@Ao9=~wVbw%Kjh^6 zJT$obN;Xr=o$gP3C5->q$`(=|w>||xkHg9zS)>bG*a=)pU`|Eum>5{TXP8(yT(_6D zn@l5rQt{PKFvSY&dN`O@MOR^Z)TZY|E{Q zV?~~`;EYCrANGNwk5%6l6I)tJX5{@Yt5MBF*CDt1YEk8BZgfB*ifEB15OPfw54M5$ z65E2OM(p+`Rg3!E>R7(Rfr!pwdFbO&zSD944+rA*sJ%KnE|LEhSsYFW#7-L2`Aook zcg>duo!Wp^#U%u_cZaG?&m=7GBqfbsEV7gSCr*a^bg3}-aa18IjK8=R=F7~o6%_ZF zE-7q5`)foqI}ajC^oA%kIepxs?ibjTRAV;j%C<#%7fK=FMvEVr@X}+)6%_o&D;S@r z_$jL=`*+$dk|rDX`-dF(FV3rm0HV$*T0i_??5tyHaVl?mn>)7u`cYSwmc)>2Rlz-oN4)%-} zT1CO!)@zDXcaCZ3$}3H-MgQ1`PTccb&ygYCHgAh%aJOzY&?-DvF4;P0oAxf`ks zNMo})ZZsBw$RAaR-uV2cVy8&-chIXfRTVd*veB~ReE+tauUc9FV%SjyY+CLLId9PR z>RLvlCD7BT!Py`_=#4{B?PZxHuP5GUv;$oT(Z3}RbuxjCJDumU_x1O{O>&)K%#0l< zH@PmlsyI5Q+Xbj4J!ndDsO>vfw?hX+{haz@nf%MV2n(xY1x;ROOg*?f@uqvA&VeLv zX=NN_0#rV-#^yf1q2$1CI@DP^dgbb|oE^1K-TUFE?!AzE*5)wwHabet$9OJZ%-)76 zwo_&^$T#L6uOrwusf4$^a#vytC+dQjVi6#?3$HC>@S{)U zmg~~XOONMCoj2Shi!af>Tsc1N#BH`Kw2Y$o(#Odbv31P_EyZ`TFOqj-=jv;RP;k0C z0iQ0=)tKx3C-Ty4Df5es%gi$Xr|EZq9Y+q%Z?=A;aOhb%3BYy{dm8&AETi%E_3%U~ z(Zj$u#!;E~krQ`qr=M>?GEl{xYJu(6DysKfu{A*L1qs?|&QHq=l!sW4JIDB+rhmb> zjk>B77PPI86CJTW0CT+I7JC^97QM7a7X0Nl2m3E7h_-nhGCjLd9E8x-;r0ORe7Q*C zvssLttCEd^X;EBN5cbtfLa9=nm?}#O45_R36PLqRsvK6#4fSNfec+%gLUpk=5P3z# z`7xRS?OrIN;VGmy8^gK-aPO_cZ3RIpVBqyJ~QHxU1tG_2=PlChM+z9VhU8isr$Gpasqs|DXD9Eb5k`ABE%c_4P6=Abwd7kzw zxq7uzlpB3c(=fg$OBr)c&e4r+oSClqxFN`n?biLl)@ARd&3la-=b4zx%8{$-=_GM$uX<-qN&JCX>F(F1v%Xt-5*;he49(*7|u~9X-ZCapxZH9p`7TxpMW0dry z+iFx2IfcL;$6O+I`j~p+(x=~Ob>aQOz2ZYe*lb*>FGA^)vEoS_-s1lEXB9R6TNyVQ z|0V+HUIXY6)I83C7MK9BsmGL(A%H`04HE zXA3{z47O_2JPYa#cz=yV+HJ<;SMs=dM#+WPh{?vU%b1bEG43jaFT-?MM>l#DK-1Ye=)Z zM*Z0fJ7_84F_n9k{;d@@0)U^1mz6^W@^=f^5e1A~$(mxkoi>OS?LN7!*AE(+P}z7O8-qj^O96O14-Ri4y2%Z` z?bC&a@zmnRr{=8LVwD$AD9MT*OluQc^QbjVb%rPdvXJlvaNSDTZ5 zC|`cMA8qtpdtM#bT&1XFPp&0!+!5Pa%zS5sVls`RRx3G~Bl8y&Z{VWg&m9#;^-`EC zm!{>-Wr1wBfA%I)Ki|2@!ZRONXih3w#+um#wKr;p9(2Zmn&u-aKPZgzOI2YSE856p z$`;UL&XEzRy|y%kc&i?N-H^907}uMOr8l@$%R z)$RAwlV`4>;k@BnXaAp2XHo%{i-@=Jp53vO)$oJgM1A=u>%8#R&gb+LUgfpj49=cH zlAkQloqDcIT#~qY1k*6i9L4KMSd;jyf^^@{1a<7hZungeKelN$2%Pd*QzR`mrO9d{3piE9RbXvTX<+h6<*%PkHAG zIgI#3&klM}LHd@zLT`-=YZ47BfO^IYV4;O-;V{u>K9gV16%N=MjvslTc~B9BQ|C%+ z1W3XRxSP8}W^Kf^&8>opH$cxx=_Uhk^rA8lq$Z*`m@>&bx4H8kcl{pw>;JL<7?)kN zk@NEK_z!2`)#!R7C+M4O_*Xs8|6g?O$0xNP`n5<`{WZUgeyZUJv#UA3HK}w_T}v)5 zdrhdOV^X7`vP-agZZ8t@r@`0J@6N|^HWt*`zwahBC?lITnFN1?hDDr8H7t5ku~lEz zeej$k;JuA+U-_@QAB!7&n;1Ghf`+QU*C80b=S%6zJ`=G2kj=QoR*~?dIh^y>cJ}j(!`oUCIA?c+xNFM5MO>2=gGkgTZy+>d0NS%f9KOFQdk(lCbI&N!OB< z5wOr59l=KRK>yarC~Y1fv9@R?uam9vXWK!r5%+gdzlQP}ZdHstX#MU6w13vSo?V+W zao1v4S$|=Cwej3`C1J>o>p;7(YfF}#%OmQjyA&Ga<{c$0cpL{!!3yk}xu2O^n@U%y zsK$XZ&Vgi4&^RL6vg{F+-h;Mi*Ke5(Ie*9cozF&@?m0*_GhNJ3OxXuQG#HCyw zxjgP0356`Ka|Zd^aceJ0yF8H^MG_|Ess$u|5p8a-s|~{JCdNS@mNwp9Rcq)ch8bRE zM@5}~>Mv7Z3Ig5P*maEhbu)<{ILRpbLmTt9eKqvT#;TrOkW7%(Y2UHWzK1ba6S=A} zKgN#A4m;cr`om~*!3<6F|2LzwG;(=u%Ydcka>?$gpCn7RA4nZ#cY87=8-`*Nbw5Y} zdL?ttbB1#NJP=OfP#?{HJt!}>x-Gk-_3`jdIF)#zeM~{Vwn)A~UoS+0u2jm~;qVR^ zHz^i%u=c)#vjo0=MW8Bo=#fj-jN$NQ-Ded~zCH#R_e+Z9RwAMjOT0Zg2(}FT(xfqB zIyTO75%SdL-61((w2Pz=c@VJdfpMb>*MUWU`<;zvU+%K;ztmMf&AqM>kGmWH!z^%z zcH8XBmkm2`E^nVdC*Nuw0=2}rcP+dgVK|i~`|Amr1+%>Fm?=o=}jA~6}pE&gLNZg%hc1Q5- z0QTk*Jz*v|2kSmQ15H=q%J&<76hKjU;VJ5ITefa2U3hBDiLxX&(b%Bp`>dFvC2H={ zmY~eq+|I`TI^q%ci(F^|pD50p3w+k2^tkAL2yg7%L%wY}lp)wl!b-4%R&3D!zyxb; zyk~2C64C;)c<<@Q{go`-92A0dTN8LHwQ)bzy*5yPH~EkgwCHUr9zj6GGMAOaRZCQ6Jy?%j>;*>`$7zorW%?y!s0rkKD9~pj-#evd zWtjFBBwlxpaA#9Lfh>cF&_WwH^SqJxemP#8p?etl*O@=|gkqcBg5^Ex z$x^Np^;;{a7dcoD)!t5K6~u(*o|IIs4b{27fKW?v@7Z>)%eDo~QTHVv%a|E}EFE&rRNRwfe{|)YA zut`3p>ZE} zbsn^*7pFY#SR5#OzhE5d&rU#6ufE-i#?D7w!t(%FL5WfIu1kzf?Csf2!rP(ikGvnW z>?lX`mr3}6i;HZ%9Yz`7(8?c=(?)XxJMQ3VTz$*OiY`x}yAF>XOD;nHk#Q*lN#x%mDekg?+M z2Z7q=$LV!L=E)0tqxrRjE`HMAsKSo&j{$nfO^mUA>8^T>(`L@$Hzpr-#w%Hywx>aOk5E*xijfxxaA zT=nbZF!?4xwmi(qEG@QhNtKE@?UAV^AHL-8-+R<-vak*%j6>E+aT$NShCmVV`vO6<+LoP2Fl42CBDv_vzI#qZ2;9p6?;lj0v{S?#w$-Hk3Q&xoqZSZ z{i$+{5nt*Dc3uq4h*MV=!|Ub3k@SV6?L=D-GSSjQc#1o+KiqLkt}ma7? zWbG=f?W%hghkGNv)%i~w`p7;=wdnH0?@n>unI;fI4J*+UhWq)S)EQf9>>Igaxf4cy zE4?!#Im}7fkmY*zBah7Dzcc>g--7%b)s&lpQx5LGMO2u92Su$)-!nH=hZQ_VunO9m4HM0gAYmFcI)XYpYE#@gpi5b43q0( z;%{xkP6V;%Ee|2qHGR8Ytk&b9&z*lUI87k7fcnwg4A{`CQ#{7e%~h3M8ScN_Xb;Pi zg;ACPq)Vl3WdxKldkwu0-Q_=j0+(t#7mp~^QaG6c=X?=s*KeSluo);D7!o}?HoS0} zC4^H_l1>_7W=QTJZ=u^NMGIGMbMG=(cl{E|XcUK7{1RNf@(t*&fNFEe95Udspk}~e zUe<`OUr4E9`k(EcSs9H?Og}Ol+9Di(b6*BIOy&bQG!~tcjrAdX$LWa8Y?ta zvM3bARr$$wi5`4+?4XJah6sjBZ{QCfcP)UIsEqhMJpuSJ_J98xdcye$Av)Gp@mPT| zHr6!CA?x>^h6Vsjq-lQ<@IHgiO`7lrZMJS`M{7Twb{J~s0v_x}uep`%My{~0;R3<0 z5ra$JR?QqOstXM@<6qFn!j1xY1H$aEI=zKN$HWl4ZR|g@@U6GNXVK_6wW&Bly??7< z1s7O#hAnGaxi1`jv|gqeP{Ea>b+!AeO;NsW(aOTadN=J1klzzaW0$)M66a#zf{wv) z6iouPdo*DaaT*xHL$VCo-ia{`b{7v>qbuP%;@hWLo7uWt-~HfdWKaG3q1oK!&R|vI zUq#-`^xg0+F8+$VQp&!Mtr^SYA0obeC0(-t2cc;SQk44CSSytJ4vO`XO>~L1<0fO| zjj_kkOK}nUf|+oOS`wR<*HZDa&CvWuWiTEYYop`$Xli%6iHdSbY^v(n+e6#ocsm8> zmN!F&yVj@0eSu;!P@&KZ6xLyp}n zD*2qjwhapEUCg!q7rV9jVa!_E#e^K!2ggS8*082J*=EeSWDhn^G zsF}-6fhYKvXwfd-a`7uRbBaqz4i+jxY#5=Bl*LSn&xd41p>(4a>qc$oGnO>;(WQdm zRCHUM^?z=4T!CmE)m8hoU8Z)|Cz<$?Z1pK@Z~Ox?U6PgQb5&ghYiDfvnRT}pqw_9T zWZ_M&b;5#TS5q9`-zIww`92#Snzal^G(}bS4F)%`*1<=OriP8b!w4D2v7^(cZR06S zI;Jgd{UmHBhshrjZ<*aKr`X#C=P|(g>sed;28gnK@@@q=sm;UgR4er#`z*T*DDF4W zD!-_?|1%|7>+nbjc1eU9dow}`5PzrU)?IYN4hrpwjI>SRNQDp-@x=2N8a5GC}COC$wv|*Ikgk;?I(fj+|e#6c+{8zy^_kpx`=^qW);Vh(F|o zpe(iIxj&*7zYwvY3e1cm#B}-R#{xEc3$vmy+pMGaEL$}bY4YDgqVH?u*I4goV!?e2 znSK%9Su61@E%huL(4?7Jj=s+WMX;Ha{icK;rO}u=I@R1SGX%A7g#?jmzyI-UA+P?i zk6bVcJxJ1m$fP{msLr=tTCp!&pbwHGe+MEdDqi9B*4^2`=v(&(Xrd}!+^?00NZ^}@ z(gs_R?6hnDDAwC=Y{DAck1$42tFg5F6fl|IGYCv#F%yjY(eu-|!X7`njOoQT( zMHK1p`EjEo!H!*er)*TH)x|p7zdhS);ASG5AtU(Nr#$I!%yE(*5Ld z>+dUC<(?}7yMcF#1RlPx;hB(@WbGS2__W>=@+xDaFtXprRyL{_EM`)BKy`K+6=YVC z{PXoh-HShC#lVhFIsoafT8ML^M~;M6uMHoc zAl30YuJc-|CLu-po{o`wppammBLvfO7!%K^O+tS9kQrwKMp{04y`qTh7CaP~p6&j& z?)em!n0v11q>b#fN5C_2b?nWoi^}IuR&X&RTW=rv)8*^VJxPqJq&WodHpJ{EZr>Z* zmgmk4PFz+JqzH$UsE^%Niqk3^3C1HkgMx#9AvNd^q3-jPYFo3@A%}hkOC9`b7ueb} zbC~7fr`a&(SU7D=>(%sDf^0hRDvK$tU!2IfFHJzzlC` zgP&A#=BNZ5yhHZim`vhxP`? zn@azP^v%v(xbiNzWpxhyfW%mF;{)x`iV}9@fxXUpM=kVw9K7st!W2p5!ojiB?v+ys zw}SkkcVDpQN=d!mvOkBZ4J=R({+3flQOSAKj36qz?$gqGQevI3zfN2v3>l?BUv=$Y zsKV7B7P5A;yHpEF{nIbrA2XwJ7)3`&M(?-qAMAbRst=TZF{bvCH4hjCj(_Q;QZTjX zb~w<}69OD%?5HSx_#x1frnB3iN_mIjLc4)NZAslZ*F3`%{#A#W?rcn{38q(Hxh4F# zr*`fgDk>}lu-J9SxW>%%I+Lk%uF=k{EpMV^<5#@lV|?tWTsG}3w4gi%1Z$4%RrD^%ew`c=Ph%#yh0 za6Ds~x3TLF^y4$(BB6&Mk;(Xd#wj#RXE*^ux2)(n53l)msIYYw=8QnUFCnDI`-fEx zzgs$z1)BED0EkmyS68W78MY)TK~k#iXrR1%^zeFr$-dTmp9f$1{@31jg*CY~|DvcU z7;#%b2t*MJB29`BB;W=S5s)CgNDZ@zQ${lDj&^E~I`%LVVnJFGRc)|y#s%{wzcBjqu{7W0B-)WJisJG+CY z-DvSl81sEy#|x{qLvxN21mb9f@(cjjIy=de-{sZHz8V=`oH|Y@e9H)c5G!UMNR}{@z1wrj~LJ@auRak^HiHRV2_RSNVkM7KZLK%;2^dI zCV#riDf7@5|0@5Iy1K8N>Xxlmv!r5`2~_nv+{TlpV+z0KMcAH@yU^G(hs2q6%i585 zb`0AN1_`(L{g};9Z1VIPySK`&oAC~EiTi4yh!7EA9%ykfMn^`>sUd$v`3es{)m)!Q zn}E6ipA(XpD7!iRt1k9(9CD2Xe3EOyqGi6p7Vkek_as2KBboUWlmcIrBGqFtCQC8E z$9y?&KXv%|#T33HiXVSq)N12r?Nr*lRl0c?@ORNE43dt*sAlQFQ77eAdq<{|UH^^e zML>RWI@freU|^uwnL(?jXLnN5x9HbsU2ip+i7r={kzS}&-hpoSnx^%;d6O0}WE1s* zAdvM3J8BM_pAmSHd<=)P4OiA{f2zN}mV522GRNEO5j&^_(?2BpghFRoiOt~83rrP6 z@$2U&AOsRPRWP%n@+-+c3R*oHGL;eWuCid?$`KWHE0ccILkA7w7?CBET#HF|vak0? z4yPO5MhG!m7G51GF<+tshtg?9otbwAixz`wBFUxMMmKo%Rw)sD^nSx8LdCa6i@_+C z?nP>7B94#clrPfaWZ-#-R57^K8?|12o$x0)Zp;!fH4!6M)Bzl&#T1U>_jjd82Bm{J zj)N4n3q8U`fmLxY@~ldN6FNr?VHz`$Z1|DOHJ1xlIh^T+jY6X$S+8{#*S#O;1Ut2} zwy$VPw+kWjCk8k+=>j7Ki2w#>R40H&Z8=X{Y-J4;^AVD<{u0?+R<9hpk!9OZC26Ct zq=pYdG|JKq@sS!-j5E{S=pzF6pt31Rc0x*rqe{vQt_=32vOSi`_wdc9X zo~tKx+wE3%Q!reP?ID$? zy6-7VqoJCU|RmQm5!1sc-2D!GePVY{DL>#5MXo(NQCS~WM3g$RI6*8k&cOFew zcb?dUvc?i-uWfnCo64zc1PaXRqV@6&9GjXxC;CTrIn!so^ELbzUKqL7VENkw1SXj` zPJ*IWAu6LHPL;0p~drnEvUp2b@zy zP3vzRdRh}(zy$hnjtF+ogBWua>(w=scbxB=bDkP6nCa{9~srq zzE*UN3ePvkq=mODzA5dPEpEV-R)+6}8zWt!kGKt#{D~?mUsk%BmpT?2r+~4v(J%a| zBiM@t3szm1My}Xwi6tD%evwrD=*_}?M*=22tR$h0Bk^6gMMj*%B367Qv$-OiG*2Sm zP%8a)9NTQ9aD6#GiVu|9o?UefYu0_zbhfir=B9^ow2A44EBt=9F+8|SC_`N_Xx%b0 z-c55uEYX48ROtf6pKiV?DR@sYW~#ZZSI9fF`e%1ioc*Q+(=r4o4sa}Rc)JyRf#V58 z65&VsnVEkb%d41X zVz#}-&?ku~VxQZOPqlRmWgk)H^0##&y&qaW3Y1#0W9O?zQ_Q#b3shh4=B)TWIyrvj z6rnWKO@-396QN!;m`F&=_B;z+$2D=T+F$&@F2mHoVtKA5OPeR5rU(4W6UR`NPhWJ8oH(4C!mKssb#pvpZCf=dKri_Q?l@afY;{>d zoGlf5*3^$b{^wf_Nn@a%T&3KV;JWYWEy!2Cb4C!Vii4eJpX=(Xzl9Ebb_IMMM;a@w z!`j9bF57L?oi6{*5GSZm$4Kre=?O^F?k?GwgdgZW>uBzoe&~4gvM08>4ih~4nTq@r z&__zLnp_WCQ6ThgI@R2_TAJNCf79cmXAkL0km$(4s{!Oc!tioC-aGri7Lq2Ek;z)v z5x{|Xw^57|v9i_8B_o=H*=U0=lqXf(vryay%KN8Q0AC_N9|(-~2QIHa+u}Zs$)D;u z>>r`wgQpm8_#s&RM!PZ(`ng`ov86^{;?DzGkgauIk2R1vk!p6`#G4W@XV_) zRBbq&bqz;d*IC+hVoow_Ro^gXKJmzQ(8?gqPjQ?Z*Ro%|Mt38=p=0dOcL_Q?kVq6izcA7(hRVa(%!L*Tb!AHpFs_qVH_G2qt~_LC~6-r$4o zhzj9nkea=uE2nZO!#Kib&klB0D zVWUR_Arq-P_3ER3*P>Y3JH8Adyez$ROu1JaC_*(vS{zJlal#L(H<$aTrX_t`4#?-? z4l|R4c%^WKkn?Q_9hn-<)bW;g!bJ(23SBoEIY0ObJIXgaooj_)8MFG{1=LDf@lW6Nq};w5j__tDn#puE%GI#Ha!*qUM<*$WQd)^AWT;KKNym{93$U#!t74 zOeOElbq3_iU?%l+dz53l|6BnTZfQ0$`3`cY@aFQgJ*6}~;*CDcancmO9~-{tFp@`o zeGWHfX-B>nIV&0D&IzQKORnf2tML7Zve&82b@wZefP`r?mFAW>ZVtEHq@j@os?jkX z+o_YviR)1Y*b0{2PFNF3w3|X5^=3XR)MHLCS;bNen(FsAkXK2)BMr#633j-Jpqa_} z+G~ZHskD-uARHsHHJ* zXdu%*D%IRiR^BdHqkMDNO*^d#`{m;%5W)fVLk3s#tUf>&8%WnPjzW@oJj&YV{N(5v z%^gt5>e52Ri|#x^VuO~$O*PNciUxg_w{`~cTc~AX;w__vru}%wp~4#XwQ2bMj%8)3 zwaoC5Al2Sa&;uqqOG%jE6%en=7|8ZV&&>qVYOnjwAeeTxf(5Dn;pWo^UVcHXPoE{( zDJRP@i~!GCLL|gQ{R00+u>@(^lH&JWnSUc-EgN-zv2=UFtT)O49cHQb(!E3f;Y-Ss z&z{Ou+K*3)@zy1X*0B`Nnr23s=X|ST`bO`@9YXlJ$rNi<@p70-yfI>@I;!0v$|7Jg z_B9xal2vnwq1`o=Z=n5L>Oq>}D}(_2j0?YZnu5ZMp+Yjku;HjdVM7fwL}KUUHi2ey zvQXxRQwT>UW{yqD6iF=nvFsVw=lrl1PAf*ZzMZIbNHqK`qF?Ibyd3g!%CyHW3lnMG zHdd{Df64S@|9HBs<2df=>?il2XV2*i4&QrcLEUV|U zsqJsz_6_HK@}rZ0$51I62&%ZY?_AFZpoo-iy3 za17l;r}7C7a}U)A)o_?hr9GPw-YTJBW**nX*(X>mSd~|%90q*h8j%yffWi=3pP=Hp z2iV2X+ix)Uf*sUh$7p2;Uw)$ImcwqG2DF~)qR*=*(iWBHPFZN!T&0?J+j)K4&aZn` zFW!Y37>nu#E;KorO{x>8HUx6-JV}QxF%l_JT}$oTslrrN#{#T>k%Cky_sube;nrup z&^3=Hs32BV6_s-eMm^p^2~x$9LRa)7jmMoOOYR$`3%=TNiJXvhksekQ(|Oh;-{E6n zn`irM%Py+fvhimAQqMg(;idOOvxD^LRHPd@z(5jN==a9_%JS{PRW%fsW=%&=Tdozw zdVtkx1oTY~bJCcK(jQq~FT-w#m-1%O&i7GwMy zR~~NYle8LT6)2ZH$p_o3w&EkO0pJGz50kYc)%~2z_lbwxrL@2nm{n~^VwzY91~*yu zJ^Es;^VXv_^tGcqyJNcpJ5LLL)gFYXr(5e?e%k#UV)9F1J2QAa)Qb13`Kb$@JRp#? zp)~2^!9#I#8QGp*L3jEf%*ibmbisID*X*VWFSs3&FUWm^k14(r5mAA19xdP;fSpTE zAiD~#4X?wlIv2M8!E1K;ae%JKnr4t?Q@8sUnsYS`DKRziI$U$&i@M!pTs|}x zoSyK43a8Hfxn{;|P0#OQ2Hp1tszMe^FlIkeNo8;B(<6Yga!2*dmVZf$!4c-6#^Atr zgv-i{QA0GoWT(*N zBsz&J@p@s33gJl1Le{_>dMkJTiv+9nWOPOESrczm>ghTg!<2||3X4gewPoBPT)OA| z+B%};Y0ag0-&A?~!2{Dvvu%a&@$ zvVqw}{y0Rw6d=k=idM{7)RW+=-o6rhUOe$bH&&sWdZu_;GjIa841G%7L_KAfBK0B#Z^T=*d{oK?;=(m$v`#0QGm?9b=PsV0?jg*$PW=2fk1i|zPT|Nt)Q;*J z5x`Q)m_R5FS*UHG`9K%| zSLj?l`Ie3gZgY{(#p6iEvq3P?M9nYuHw4y=PY!?eBGooBHBxTwPYfW1t+c~kKZ)=4 zb*#S{xJPV&?9xCo{c9|zWkIydZ+t4ZQw6Trf`fHu@A3ES(|M)NH>6YbwK55Kci1g4 zcwyVABkDR2Bugn6H&X_b_-t!-d$Px#dKy0QWjJ!@^>Hr4oxVj@a_C@}NFUqFpeOWXmmfmA+8(@e0a77hqrJw6Q2 zJ?@hQy}{NLn-t(_=4cA7Kwqc<_yJDpe>Pr0KPKa1(PxMn-O#rQ4B}@rn5Y{H1zNqv z;5Ldk?)ahIJe_l#Fts?S4fzsn=G`nW9dzL7IjoaJ^@uya z5zsI&t3QtW01-q~xD-!Tl;gf#?R1UW9&6d_(?C%4x%wUs5Vl4#)>RsL%>Iv_{e2Da zpplXJYkS-R(J$H%Zu(*kd6Nw1dvGza;aT{~3wWIn@%lfnBg;cq^e}TEdKV@?^PUVR z3{0e`Z@7wWYKk%94M#I!)Ve2R2ohMAd+!Gg-Na%SE#xmR zG-7Jb$MWG0b|vyLHgv^khv|nRjh_IxX@CY0e-dL=kJwjesEb?k6J-ISx1SfS&E#qG zwtuq$jT`!dxV8s!LCApN5 z)zbrB&xYT}n#+VKLx?1aWZK5jJ)AsXn2$g}_MT!SAm!G_N~|=Oue)dszQ9XI@iFU) zi5Gs0a)&H~KkJ{kwTJb49jqi=_k6 zgpvMZQrYHkb;{%rpUaN|3;~sMVsGe#GU*h6l>o7Xh!qqjKigd9r5BKB7;A0r#vZO-c~+wV2#9)+;mY)jYO;;rdwY@Otjr|mNBc-Fdq;1 z&*A$`#!ay&%amhbKk*0uDs|Nm)6MZ%i_1NL&H~1R=@sgc z1#Ol-Oow4=#A7#_U&Z}}Fdg3)$#;pY@?zcB%`OelU%+a`*z|#?%r|#(;X#kcyYAv` zIcWkePsJ!<9t9c}`-^TJ`Awy8YP{UnuQxO7N=F5PPLuvBJajGK}RZVhuc5O$)AT zpe8F?39}(@UuRZ2)LHE11?>%yj{5*RuPqZ3=Qu|bA}(WU`WgqTFnE1kg@T*0D9IU@ zFQiNjtWrhARV|+j@iVBrY@Fb)0YIf|d~XEmDelcf;$I;z{OJqK`ez|r z)d?)ZOp?=)ER|R#T;93l=o=^Qp~b+GGqznJ7t9|&$>XZFVk-jwc6>OvM(nW{io67C zuiY%uusAMcr`eHmv%fFi=KOU1S|xuEHe4H0f-w3ng*&{bY+SM0*o5|7LfMr{;}S#U zhw{redf5-{$=g*uaxA6p2kc)G$u03xUnI;GR>I)rrt;2v3JA=tI9_d3)anzt@k6*p z+GBE!Vpw$;-#ipbV;ec7UGo09_@_jv5Tm~Qd*i|-Ugx7P5B!!&!LBt^Bt)FDMZpU< zyn^@oRvKs(x>o(j^z+iS60H5i{=#>3b5)SYLhj@#Itm(Zs@>_IV2js)-1fu+wwK)O z7S5sg*EaFToJ%E>wXwk!-`XBTmP`I5Bs)QA=+D%%((jg$=UZs6xBO*WDDTZ^dZewc z^HRwP<&+oZn*`>f6noK?*YkzIh-;|9Z#yiMt#mL&MLG$eR2go7yZpIFJB9sglxEPE zLjTjXob9uThWgrQbE&VQQ(&=KFN|bG5lQF*in?h+lw@z`q^jIo_nLnDw_Si{1bb*- zh|zKc>< Date: Wed, 25 Oct 2017 14:14:10 +0200 Subject: [PATCH 087/101] fix staticImage test --- inst/img/logo.png | Bin 44784 -> 0 bytes tests/testthat/test-staticPlot.R | 8 +++++++- 2 files changed, 7 insertions(+), 1 deletion(-) delete mode 100644 inst/img/logo.png diff --git a/inst/img/logo.png b/inst/img/logo.png deleted file mode 100644 index 5fe3742ff687a4bdfd6af9b82f9a5acebae7214c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 44784 zcmeFYXH-*Nw;4aCs!jgKQmn&MSG~HnB5;3u^>+hDauD#HOSk}-rdnp;EAKNs~70XMicgmfU5)O zim8mQgswN((Z%&X%*W9Xre|aibGKJ;xT2~epd6$~A>irgXD1Nk>EY$87zDcV7hOfl z{hwy>D*}Ik__>3w{4JE3E<^wf^>GxC5t9gMqC+1do zVK3i*6h%>)c#xg9xTKhbxToize*FdQ>u2Ej|BLaTLi-v8dpn97IQl~Uee5aY;dJ$1 z$Q0fE?-~68q)4Oq$j6m3D0UwAp!WWrj$VEb?t!jQo`^ZPIw;2BHJVJ6?my7EFu;2Af2;AeKLs&se)Ji*t?rw62 zzX)Fy_}TS+m8`R2IYq#2U>8$T>Kffwa*ME;z8TDVk4&+|W+>+PXxdr(lff;TKQ7%B zB4b4T=Z0tAj3f4lt|-al>s20%s4`ls#R0K%#0{wU#uz&EH&h9$qlQq7y7?l7{u&4I%FSl8k<6Dq zQ&Jep_tIv*KwZaAuTx)Bp$YKVFT@^9!ibAGS9PxDkJ8WZ3O{=`iiC_rRo+Q7299$C zzc4I!-}O#n4Kf7n24+hnvwpbBMeW%NPI(1e33y&P{IeF4!JuK?Np3hx!M_{crXwwv zSi|M0E2Itn$k~|&QEZkrT_hK8m5*KCsY&qk7@a>KgR~KDE(}~hfMhVun~Q7J8~u%H zWQZPe6Tgiq*~~t*k@&fM6(k3B9l^Vg&O=3)KTdqu!Y`LjToiQsr6?aYODhOQj3@1JQfi=VBJ>TyIl#e=b77gpmt3-L?|6 zMaSf$!;W8dZ92j&z7gtUBu$ey`2)X*PncH<=An1EHR?X8pB_1 z)M=F&z6JCi05QDZGj&?nBcezy;3=6O@p(bsHa5puy5 z3h)_TCoy7~D=oNGC^#az?naTLiP@5dpxzF*Ov&~-WF6qBI!wtZDW=qgLiuq650)X* zyqyn>ew5_SzDI9oPuD{&hOUxygy03hzsTi1iixg~Gq0}y#%&+Q(_SEFVyV$Q5jh!) zI%*$%Mga+@ioTT_C1P`-bC^T)NyT_JJ7a_gw|cR{8-CXLZAjRqPMj#W1;by&ZhVxT zYPpiAEixX`6e+9*TnN?|UvuSHyPhvf56p3+z|eaOVTl~2!i8&8V#IcNNI^pwOZq&3 z#*1M-1Co*d56ILRsEhm4clZjI+y_}kFse~Y0 zCvPD=O!Ij4hFghO{~_0KUA;jfQO=?|f8wPPL*5(Yid)$Hg%}P+{TF1e;WK~fbgTM2 z=^Mw|(jGU!x7AO6I2+i|9cFzpnr-)=B zEQLo!8Zl|RhB6eev-M*SeWxgFv_w-@M()3Vj5K%YzcDi&FtY(}P)Gz8(f*NIZoi|V4xXQ>>w z&F{X?`jXDm=_YPVKR*UB_y>Ud%fxL_i-OLb@nMgk_m;fglSwC~};! z%5|%7DVrdRSRA1;gw@z>=FoL6I~%>x+x#d$ebK*q{IKdv_UyY2M#qc85yB&EowO)F zvucBRY;_3J{-cApe!Ks~n7_hh^!Jk@8lhqe`Rh4NGARK2qX+#L+NqZK;i7RQ_MnhDM~T?L9XaI>9k6@MCkK7_uuO<$t>D(c3MiE zcok}Zd?qO2Tj{QhakZiPf$EWR;J(5z+d}VUOE^_)^%GVr*A(>zk;M4u%7|sEyst~B zkSmEeGwIg=LujnrW|a(b`yE8FF#8o?(c+ls37qa~JIF`{0?0XQv| zB^>U$RS7wP#w;vR2|Y@kxd4EU?KDJ-rcCVL)A6SJW4OvJNk{dk*~JtNuBd5h7P}Ge z&TgZQ#D}qiFY=$-HkerMKHlz1Mo$4dO<%J=rltrLA+2vaL2KpMKSE8F7Z1#8{*is4 zSVF~g2^uDZLv9PlEZlK|DJF^|x0#9Q1{={z*t_aqEY&%Hx7!%s6|Da9X`${|TL{bGXe)#V%%i~#xXX$RR8kN5 zj3op;U5YZ~bXT3eJ$Sr;ADq72`2nJGv6Hpv?DrTB;e!cCm}|dugl&}1BcVTWnxgoZ z9QXPd1II5qiw#p7o%NJB76U*nLQqM<)Hgn5?Im(jwKBJ}b#AR_rurd7{_-XL>fF{; zaKoFTKdw?grp6@Lj2{)aTws(^bqKUaQ1){m8kg0%pb;9D=d2zYQ?YBOp0{=Ce^dSl zIiT^r%Pj`1@Ht!brgWV-JlO3ggXl~@U*`#=HfsC1hObb*w!4t?^U9HIW5JC&7rVFe zJn9OPiMfBmTgvY?)RA)H=QAq{*J6MHBD?kw^4&IJxcV4RClnk!bShG(iz=ydss5=P zlPB)tP9vHzz~6a3rdD#)tN&H<#Ld~uM)Bhh?aYOIk1j7C@h%cJ7%71n$T081g(zDX zK{GlA3&n_}l=aV&#H}+KRMD6dUw^R-64}C(OXZ??jZ4p*Ud)2(`t3pTKuvHh7E4fX z=l-q_3wLNH z?NQ1O{TB`a?3bTEtZ7A@TCGLo;dzE_S?6zZo$6f$+sv~3?glCjQ0qmYuO}+qbeSo( z3r*3;(UpZCmu$14Hqb-_ZVhFZ8l7YdpHgHlW03Hr+r`ZPE^nN>cd=4vygZJrU(3^K~hepOIW#-CDBh)n8sxFBCCdDxCc_mCDUXbmu zA3PT-Trf+P1UR|oA4;k$M(Eg*?+als?qpp0CGF$zJ=-R}!?zj#e%jk~%4#*@RuYGJ z@$o*aS@6Ud@G?sFJA2CTAn_ca$ocpA0FEI2@6BD{_s@m^>J8sc$&d)@hju6a9HIsR z%V#^3I$~M~4`X10?0zjvgxvh_%+f~eSN!Qu5iIS%GRE)FKlH;XrtIeia+{ySljf;J zul@Z)@=53^bVs7lw*M;3+t zRbL~s)Msw)FxNAp5Dxm{7GSRB;va2aZXO|u2`)it2vvM`1}ffSDaT_-FX({~Vs$MV z9qse@8N81+>_o9MsCx+h<~W%Sji`D_!g>%Je-dj9fEis}gvnYT_!)Zd`8=K(x+6~6 z@a3G@r`&fwWVAh7&OyCHxXg*)%|!(~f?uuc;2GKR^hh?9mAQ|1>fc0TtB&BQuikcU zk(PB0p}q5S(#?ZIG&?Lx0YJmpXjNKH&?lYW`_pYFZ|s|Jv0ox!?y?p~0g6R(-8low z4X2*{%3rK@6-~(vuHUz&+27QeQBuT?c4XZ$p&(EQ_o{Nq?&ay@2Ey?z-eTNV;IS29 z`SjmlOr%dTN;1s(j1JV6YzMoh(r zHfI?x$|T1>e?J1JqfA?DQLtH(}cf0Jst^Ae}$mPX2(^;wg&)7`0%CKdML<2f!je2(LL zSl81w5vA~DLIurPdTBoyr(1{XegY8Z_9|d!GVM4!NebE|BN4V~#1pDq$pz5uOQ+xC zXB7ZrOH{Z8Y>w%Hg5qcJ;Fl5{S4x(b_*Qtr?Pgc~H}K|@j9tYg5>ecyDbc5 zRYTX#*1v2~{pQI?aj=*(sYqWd-5{Ex4DMyqpsOoQ(n3YZGaooIVUBU(m2HtYRaj8G zZ)z;@f;9nkeJAi)%N_^dscH&xB|xqHROPqeZa!*qg?i>q^iZ2QUI`a($<+9j7;=ls zZFGtgGs{mf0kARB@$WYN_=FB^jlU%(znCTx%h0|Mv7sI2bz>ZOmjL!HoSq@T8tUvX z1%1L{vp%DU%83^Ac_d-~X1i-w zj*k#;+A3-5o20F2&VCgto3qXp!YL^1Dn@1F(oPUz%Ac2W9Z=$becKZYQ34^-l+1TrXIpz z1+-2r@8`^rNA7jO*39IC)J5Jr;z3)a^D&m#QVDmQIBv9dN~m(?59i8q`hY#%HE2XH z7*IJ4hdu&-9=a$Ozg!Ts{IPN17d&w2?np>hFX8<3K%+7wL@JNEM6(WgA;YzS@K*N* z?bT9Pfw3h2jy)fG7JaukN=mjpL>FXx`kR=r(LOY8Gi!3%vKn zyJ?D$%71S4yal#|^ky5YBV>EvkT?C)u$U(;c|a-Riz(Lw=$%pl@)D$le@BL8t4pRs zyc7>EHfftm>QH!HEZz+rDoTj|y)RdMq`dhCNEshKmTy5H@g8I4JjvF(zpZ>z^zwv- zrwyQ4avjos!4#&a?R)`bTILteW37SQQpOguG)e$1SmeT0E7b6F)^^~NvYv{0DB-r%4v zoA*Yab$515^ga{cOzU98JHWBJ?bU3Q2obfb4Zet$^X8(edI!_rrE*p=)~|5GJZ%wM zAbnhrb=8l3A_qmZ(-;Qyro(Eg5Bz*y;fs-hZab^$CZCPMV*V`H)5d_ma9YiX^I289|O#?aqlm868(ucZ&w_2wro?hv_Inkn@t31wA3!}pR~qp z7+cNYwA!xO06<>bqSYU@_9tNSPDN zRatOfCXUUL$PF6JwcH0&C)^)*I+j7wMQj~xvbgLisbh`V5H)G-RBY=@~2vG$Q$`WG~kAM8uKaZ3T{JfCt zORmO}6ig<)M+Fh5SIq%{OLvE>5KZ%{B2uDDIMZ}~!%l=A_8XvTa!n8xJc5^lP2?dh z&r&k_8{8II({g(uG){6d)zx($GV-ALio!i-0ERURXAX;xS9EDx%D8*lPB5{OwosDh z&iXA_CJ6Xqk8=|gBN8^9RG{^c$*W|CWN{y?%4hb${OF5NOtV)dP1=HIXg5vZ|xe{0j|!ilcP3{wG*R@b>M1eYnooG}~^(@SYl{*;9})4N$piMXycPl+(LA zw~hf4>LyupJuH;6QKq$Ztz&%dNoVix@s~P ztGV`w$d%gio>o6i55WAC`rhXiVWg=QKtrY#5>vG+vT-p>xB%175R_mghf3 zLtmo$^&@%98?(nZkH#;fLvv^LVKEfZTC7@fBC0pXKLU@uh;tkBvXmuJQF_=%*P~-? z1tQg*v}Kl}-m#$`cXd~{yd{!ZPIO`6IK55Vg0zv>r`E=gaS9OP#Urayn}a|O7V{Bj zz0_yoKj!@1kMS9cD0BFhEA0c(YuiR~jUUVOWgq;UBIh=Q@mIRce$dcp-n(TZJ!Aw( z^uy{|O{mv)S5ar1cGw6Y8CY&OPe&VZN>nU>NF! zPycMagn4wFHhqSt1N@;WP{MJ3O`)qKH6P>Eu4EEb_vnD2+m<9=RUlUe>c#gmI&oU= zN|<1AHTvXGN(|?pODE6XiH`N-bE%&Le}I4MUQs{zF27;ek^9Z^uvul$_Yynfa85E1 z^vR~a>QxBfTsBAYCNaZkiqRVMs{kT=IDCbJS+ljT<(N$y)lCP+a z@c3gGE|+J~LT8Q@aA-I@A@L;2b5CUXK~D|iFKPf+s7Z!R<8Fwk=nq7KMjOw~chfO? zw-wx^JXx+cOCsotIiVb0urq?DzsD zop|YWKZUtea;=s=!;!dd6{Rph zlQeA-wx%Gzgx5cTwQl+Pq+JvXSml=nK(G4#OAcG}1v?Gj5gCH}u{<6vkn`Rl5GJ(t z1GeU+6egDSrF@}xY9^xD3Zr=o(4q81{hd0+A-p=bFeK!5F!ppYnbncjo7m#|GZGDd z0nfxel7w|IkQg7YX`HLyo$P~o=~DJ}c>U%=Vouem!mV~4ESYGPmt$4CJm8?$uYbF| z@Y?cK;90BP*UfMorRmivN)-e=U5f2QtbW!l)^NK`MeK7upKu_FpIAj{Vip0Tqni-g z5Efio68pda${1s1nLmSBa;79C9Juv?;J#mCr)~|=wR=Hh>!&t^y?D_SfN57`{K?aC z?Vrl`I2s?iCS=~uE2K&&ar)4#H6<<6-jZO*`uN$o7bZxhgrWj^I?Q>XTr&j2POzMX zQv#65K%K!Ch?S`Gt+V?=g=Vzq1vHZ7i*4-hCQw#2;Vp! zPcDjXJPhVp-DmkW*uvjgCwdzElKZe|8Z7$Dr~bv#<=cl+E!DGUsiN*|#;o`_r!d%^A|7_fX&N zRG*G+GOKcOs~55h;@vt(1ulM_(W1-g0}|iVIe_M#{WeY;PDPPv1BI6Ei+ry~9EJOuyc_ zhk#hsN_*4FVSl(p$J3QYo7vf_zNn{{1aO?eo-V+tNON4k_!CvrA}pHl)YEDiAZydJ z2A~9oNG~so5A_j-ELl`;t<9a;!8axfZJ@?or0%WOow(OnL-BZ|WX5BCz%nLSSww%MuYp4~P#08g zxw@}_m^x7yiJVMw3f08~a0Wrl*X>AS3~{q(Pcw>-L5{ek_GH2U6L^@UBRlV-OW*Je)P4bN`VvSDI!qSnwX1&QqdlE+NpeT7mAF_Wn2FW7)wa{4x za{>P%mdM?+vzce-?QDJ&BD!X|_ncjI)w9U;y&j9Na(A0)t(1qy`;G~WUFP(C*w+aL zQQ%0=-i)_NTxPCKI{xcXXu>x@snSH`GZklim5a+K^)G@v6ZOp_h?W*xaB9tP$E#%A zz^hMy(XHa!!f#HlB=Q`GI+5l z*97op?7B;SB+6L(@)K8dcg6$8w!qIW0-qy6YjQ2(#93AW1AY1Q zq$Ls4DgAq=>O`gY#R06zcEvP!YPH;6?yVk9cSYVm#~0P`jPy0c6QSwSlVO_Me&Psh z4upmGV~4NsfVospr2%kHg=d4HxwG!+#b_ASA%+)?%E$wdYjUY-y5n(2c=V>?{e}8H z|B~egN3XtZpz^R}0N~YArWF_ZO$J~#`<2Ws7|-6DhEaZDYlr@js$JzSqd51gnJXF* z2RkRzJ~i)`LEqCejO!Sb!pbsx#v;SYI5>lKsGOdL59-cexE+?DP35xPK5*`gm505* zH#d)i+kIyMpCNcp^K=K`BmM5;G?neL<7m4qb*9U3KjrvkJeyW2FGs63G0JY}>aH## zo?8!Q64zKrYP4P;$iH`W}kRh+!@E{hPh)z#CO7 zwzyAwC77XJb6Ag6BWucW{UE_UwQla$7gH6cG$ErRoId6m?hssT<#r>;B?mX4{DuEO z!OCjE{c@`ay*JDvH$T{2;TzS%EIWJd>D-&cN`-Npg|quz(kCHAHongO7emTdh$XIS zEG+&!P*y)r;OxCvm+l5bKo3B4nf;^46i~e~Dckh1vc(gc`i>P%Fa$s6Z)p33oP}G_ z^zD+4_G$+Gkgi)ri=?y_Xc+r=-c7Hbi@qF35}4Hl=mF-pHe}LvH;#FWSbHuL@He(g zBG7R#qfkm3&w z^9&sT+qk8z&{9#05yTxpl6a3Tas}1hmZ8i2XJ`U1%*46xhT_^6T6N~zF_t10`rB`L zZB5&VH&kuMzaA(<3&e%4Tob-@G|={A%5Zafw@R8$w2A})-HH$1yj4RtcVBaAQAXy{ zhV<=_2MAh07XRknm4#{L7A@-82LPt!3hfQPeEe{f*G^7WL4y;w+dd0GFDeb!O9s;u z{R-u_Kb@Ii0-xAO%jvY;z;5`z+aQt^PMLEF7Gh#E&MVD@ay#xPTzxW6HAc2pKyK5v zhzxY$`Ex0TjT7+?d{?%ogy+s9PHlI5@8E4Ws*~r!UR&OT0ACsv`M|0#$|ruUU+3F?9bJm#(9+fQ^|KbzGW zhT8IA^4xdgg1_@Lfq*_kml3VomLDt9q!AnGHqu?*eLUZnYZ`L8RJAv(F>*;kZ!A{* zbL?Qm6JjEk)bhG9_%qD}AMn?!QXUq;A;=G=BehoL)8nbctsN~7kBM*_00FKnzeG6w z$~f^%psYoFH~X8S;_+o}Pmi*R7qGeGUq7{ScsmJM28i9y^yH(|Wj49T7 z1PY8kaxUcD=ir%`&_km{`Fe=%jT8K3N8pUiw>th|B4`qu91i`m{q>4npK5gUv0WSB zh`{%~zHE9Cw|Nc?=4;~MI?T&dy>yGX7i)B;NVc_5aEt3S*T^zG^YN*w;nU>{lBbcb z-;+ZrhhC?+WG2qQ==*xJ7+H+qHY5UXy7BpOjfVD=IFYLVH@Z-BLk(~fyG4bAZjl3Y zWodIyK)k_J~>aip6G2^Ofoc(>6nfV5>rLUc%ifga6vP1RsQLq`8uwnTl*nNu?LTJV5 zDhvRnYwqDE`Szs}ecg{nAMLR!m}vz*FqB(KkZEbIHQ zA|LJHR(HFAgoIh^OzpCtPh%Q(vDfa)Cm7_yThED{3P$9*bjl;2#}d_9M@L7_B^;a# zg4&j*vAg~X{a+N8qHoPxJfjsnL*U@C(f_HQOwsafZZJ$+|(jf}zS3nq@< zJirPh(!vs#Qmw(_KVp^?v{m=h!9fbM-s;_XPSaq7v$Oy6`H4X}2fD*A$4W<`)#d(I z8bLSj`xdwzmKLHk*#fPy z4+7Cem6RESQ##W=eEF}_#sQJt%@He^4WV4-#BwGM*|E%YWt?oFbXPLiy-<7fqc8XB zP!FsLX56&4%2S!SzErc(+~*j$wpJ4<_?5+xwd$;JCP!djhPT{>845w_GCzxmrQIS$ zrK?wK?euam{*IRPP@PsV`2PxDTA7xqqXHgk8Pg= zesaW76+dyY`?A3!-t?yh9u`w3S4{-$jec%H3AI*yXAmaa`05Lhf?iOHlmuGYfxfGkVq~dH z#b(oGMs5fPFq+>vTXXwE?Q1W1d3{As%gIDeZI!#XpB;xfudq?E#?B1KMT#O?{R)u7 z+%=znD{z#unS!K$OFT~-7nTR#tj0}brb*+`?smY`0M`D0{P`&C7HzcMwC(=N-s1~Yxm|J1bs6by{tZ2RLk~Tu|$DO z410e0EPF71DBw(S0V5Ta#ISJa`Gh@4PpylieEsxnBFpQ^Y0H+Qud;` zRmU&N9ZG%oF5q2`P!dd3Dx@gyZg{Ghvk(usa9$e7|5`m;*f#uUWnJL+ut^yg)#(X$ z0PkWI;S0jHp=8)ZnlntH)a}7|uHe~ePW9Oxt#dcmlH*ZN^RAjtTowv1>bzk5L11t~ z=99-!DbE1Zazpj)*3I^+ui5P0f4N1lY=*1_r6jFXImhm%B=@Z+qZH-HovgP0{q?BiH8}1@N@afN{SX| z%@>9XzoTpE0CLEGD-TroC)K+VY|B;8H;AY`yZCNrtoau8A)$v_`ZDl6ME`))r^Vk53qUwK#=teI5Vs z3FD!b5E?qs-;Ya4L?vc8r|`I~P6q1+=+npE^dGXcrk^;Hz6~n$enI zhwD+bujMX3Gx1Dc5FIh|rS~efSoQ?F4}6frjlE;DAmDJXdmME}?#&u+)To}7O>e>o zwyrO7RdT|jR|~Jw)aC^Cozu)lNNqn6y7t|%pKVwT?CCQ^O(>8a|{a*NCPjFj89}}l~XAzqS8sF!dBslHA$a z+D(<3cP@rgX5y1EAaB7$7WhUgY#J7AFalD3qVk%eEM#=B3{^u1QM zVi6RJp^H6$1(T!%Lf#7YUGN^7` zna9B(1|usie<|v@4+DdvanLcKY^54dx5C0VzE0N{0xakH~6ns1Ho)dF)R0zV0njoJpEu`*A;)Jdsn+JsTc$1Mfy`=-L3yRG3+K3iT%m^UipyH2XE5G&(${vYdyti<^{nYh zY|O^h3P;xD!&R*&*lHODwAY6UQyP`JMEuY*Ehs1uk&>sJP;GFhs~XdH4=Xn0Ok2FG(Kowg zzRPXFW+too-PD zxn>-9n=`Gk+#WA!Xjw>}OLLS4c(L-IR37VD@OM@wqn9!$C$l8xt`x=-3`=;gROcrH z_{^ml4&Os30hvkyA?Xcnf!D9sSe0-$FC+7dwqPx=F)nHlQPNh!B=OH(FS| z=A1m=&XpRHLa0Z=$LpS&; zr!WVqydxPN<8>Z>2jn3UulOKX8a}PsU0vv~P1o1SFX-p)$otYgt(!eHloZl3wr6hj zGTS>=Z_ki@$p_TyUz4%8@+qm(N|G3v=&_i=MHf zm6wq4h^Aw5|LopkW!)`;zYe?R$dt0Onj*8dw-xK_;i&Bxsv~YWpqz5I35i@wB9n8b zzb>ofF9{~Dg)B=lq^#ESaoaYp@Aidju!VPK^=>uudP0v+9y@Sto4Cq_>3ZPys6A#t zgZ2Ru5^3C1N+oRFjNUK5uJW-ZJ~X!k$6D7k535*2%<8@qEOC9BpsH-QzL+h&L^7T? zZ3c?eY|nN$OtOo#h^N{m+?}s!aQ6ubI8e?J@MjNdwg`QPddNOdB3g}iye7Ttyk^~n z-!J}9J*p+=H@OG>854we-xT z$$+T7y(&!T-f_Bh0Io%40{AR-<00E^NecrLo--qjBglTtf^^c_bzdG&HGAvNYRaB= z^hjLES~({Sxi-StXfv6Lwh#}F0gCa>4+8$I3hb%%iXpO3mz{hrKZq^6*HEe8s-3!n z{aU?xRMs-fc30C0r`adyEfbwZZlCweAva&wUd$cGsd`WXV=WJ5!4VB$8AVYPVA^Zi znP7OuIqdZrn*#Dp0BNFjotiuy=cVMS7io>D?4B+!x&D0X7xHd~9J*i3cKiu;9PbQo z+cI{2p&b;y^4BYe+{lCR>!N$D5n<#3-{@?w*6|{x&mXDRX}u_UcQ_Sizc5r}*qZts zDk99yxoy#^D8%(-VrMFHB)62#NjsbgRZ~?lVpCNx){{2D_C@c!`1wvzrN%YiUf#-y zz&$f8tijE_n%Cj2{3k%ce7mEN9(cJD$NRC}CKf4Vl3 zZe6SN{EP5v)K6yb%Q=UAZvsId`|{p^P^+ne9V4q9xJ3fAH9L0HdE99=lmlBIp>l{p z?LPV}DIE;r+uAWJ(4_3w%;26eA65jC$;o<+bKN`c*(2yEu&h63Nz_J_I4#Dry%RPX z@2KbpgWq22$niyZr}T8Ez4lGmUYY;ST<Yuk?a6T`0BjfwOV-E`2m+Rv8l(?EZP@mmX7u4fq~(GGGXaG#DObl8dJz z{mNUQykE2J_z|a#k@Ff7pcF~hLc(}DcMLDx?TS~M0Ez6)SuCTPhH0#@(LdM1Jet(U z?r3x*O3m##OU_IBop*p!%1-R2DV8FQ!(-8ybioszey@_3bk5OKu7jw@GqPL z{mAZDyoGHC#xdA?o&b}`{uM(jpL*gw(YACG$H}!ETsFR-QL}YoQKQ8#;_wV^DIC{5 z{kl0a+*YCLDy8564Z(-X%8N z=pdLQ0xR)>cMu9U?x^&_T^+IwXeOI^IaQn>0!uDMOc9?v{pcM9s}+A;)H>(!Si(`m zU&HtpU3tq$Ps)S~q061udH~CoBDJ4m4ca5b^On=G?rC7J+;Dg9xOZt`eQeMkA(>Wr z$kt+0S6!1;QZOuPi!B)rYi{ZY05F@_ho^R1GF-!;hyxHC&Q99t^1>f(uRkSqn%Hla zL0Y&vdz<_3I3!fP4#3DgWcL#z*;_6MUMFAC38v9!8G?fk^n_H2=YI8F8@8_EAEXpj z_ansPgB}E3m0WK$IBtG?!iA`fNa0i^o(brm;U9qEeYaM;bO)jKAADeo9OigDdk+13USE8BA+$Aw08< zkg~1E*B&9a@!*CZJo^mL5ZhV*un+w3D+?BUTUpx|u^eGuxkUAvpvACYAvEheFOMZg z)^v&)9&WVRD3xd%RFJ$V?{*w=ii3#hou;tN$Dl&mBV85Wh-~?mDk|Vr#T!(b7|&xF z=i#Wy1?nPRfPx!nb>*<(TB2!?waoAO0L^BvfS~lrWn74)njSjTNeH_^LVt>0g*LjLHjRSI5n|dXfiSOvT)}tW#8ME$V+)fRAg@;#0`tZ7M=BGL8G$#BB~~ zbL;b*zD@Fk73}w0fksXY;jYd`;Fqe_65ePvL&Kaw)yr=UnH`;;Tlngb--*k)e=k`8LtpA>-n4TA=07inLt3 z?xzFdBcyIAk7oV^VPI_!^?_RwCfJPobRKM9jX3kWpd&yt1mE zj0tvuWjBPTRRQQ`>U4Bm7>+LN^uhqrjPi9sqoIv2c1kjdK-Cr* z8{C2N8@)rxl3n}h6>1V*`5wW-$_$fX3ZJ>Js%!mAaF!D|vpX%$JbwtW`9N?EEX3|< zEC0UDHtmti0`l6N3qsr09Vjyw6C2G}I{Yf4i9AQ2`y$SSg*DOD;U>%gPX{*mdV^oM z?}n4S5C#30eDQq;2L-BZK@G7iy*-4Tv|T#+)F&t1<@lSsFodT4#k2B>I7p{#muEQu zy-}{aMx?FjMoi>5Zoo^OYfJ7fxgTb-FRwUih%j%5;IgLnzvwsl2KEj;uj52GA~P@c z^kW2-!%oK9WU(zHdW+w&`NpV|Nw!}Z%F2)FWK7YGJ^sGH*i1L6UY_S0o98qIZ%R)| z?VW?x2L^%5^L09E$H7rHr=PCyyjN@~K6(VwJ#BoCV8wF-fFHE3_HG{q`cGe0ZCkO! z${EOYSmjV=c-wiF6OtosRz1v|Fbknxe-1ejNW^cgpe{WC&@m~~m+ggbKF+W^zK0MW z(<9=HK&Pr4#LXf0{V^K?wN3{Ss~(&czF`^~_JyXm=mIeD(~2hbF9$$E-NJsC-~Iu# z`;e>wgmDDBkZAxl{T>4g$iETI(z9m{^Vy%LRc_&eUcZamP6fo1N1 zkh)y6qE%&jyPLu9|CWiD>L?vw+l?vIrI1E_W?H9dS(C?z|7XuF^Cs$iBL zCeUVCSB}aZf@jIKxujQ=u~9czdK)LZe8wb*lGRO6}JaKwEy?hG$n>i!jeVbxwG}}YIs22 zQn%}4?_H%adA=Dih3x6i-Ar9!bdToc;;n#_NMn@M{>?xjPN%5u-j@-iqNU|bE%kE! z#5l-Bb#%<$k~JD0JmqI(B7NoeV|@8kZLzbT*{6pp)djH&N1~o3Ra(W+w!L#P{5~eJ ze&QpL=J<(Gs~mYZtD+=LrZcwB~(c?$)3Qk9Yq zh-wIEN)ypabF-6JXee$mAs@Rah|pz87=&ndhmL1nn){V+#l24_Olsh99D!E1O zm!xtT=91gyR&JGRA#%Uuepzyv+sq}D+g!$6HhMC*UzWe?G`(b#xJn*?^GzhQ8Q;7dOpYc4V{@qLq1Nr;<&-fz5z$>iaxRg#Mwyq!n`}h2;WcR-5 zPn8inT3@OMs)O=FLF};ZfHU2iLmTK(Nq1mb^}=$K^?~jp8(8bRh(opEM9;M!RMBXu zmhQ^G6lj}dz9F@t(6d=bxetopZvh35;_?Iu*jCOdD-tQ*f9A*NBsZUQl_y#C#IeKn-k-U~P z@T0=z_Nv!dX(DlE$PJ^0Q%83IFAf#X`cc^nV5^+W22a zJhW8R?_heu%#U!8r*P1iDr}a$SAP!FUfE#$5(1)ln+={KbB&Lp6Y*iAyL{A<~ePj4Ygwn9?+Fdi5mQrm3>SRv9xi z`PsZB*pHYn(~O=1jZf{)U%&dGK<#EV2-?n=##IJw@lf8YD68I|WYp3B%*t}rFUK=& z!t$ewSJy;9Hn{&p1l&p@o{{A6TG3-Bc-4Asj1ItTQ|fI&RP0E%vp=(13j#p-FNjs6 zo}zDK1C9;9;-sRA{eJW#%b!Q;+pfp9*PlFh$-m{*P{tj(x_Q%0#DHL>I&A@N_Kedw zRvY{!TWS?j_=RaN#;F3{#_k>}0-=`=yk>^OC{ikPnx#<%%TdR{s@nnvbZm)-PzbD}JS ze$B6e%RMtuP|}Y&-4m|2dRNTk{(E~vU~Q0Sh57(C?! za*D3hQu&g35-7e5>g0p9+pNBsx$M~Y zF<9+`tSt%Pt5{!G>~0{YsQmN3D#aRVpGNIel@;HnojpDs0|8otPRW&fD*8NwG}W|z z5zv*bm8)w3D>WX>?$gq>!>0ab0<_TO{F3{_-a4yOQ%$ah2uw0UF^4RAo^Ba?DYeTa zhc!@!K z85t9-M8#XBj6x~GcZfd9-p8#I`4n(v&z<&ZW)^|c-`lZ{;Q!nNsq$}z5;xxgKaeHN zkQObZfS;;zBq+}pOYI|LLcNdyimTaxk-Xnl9?Cx5o$15V&_%(g0e`wk*w>Q|n^sqf z=ZcG1*p&T4!Ybfz_R`gF!{{`X=B!30hPHBBaGMs=D!AGx>S7eTx(^{|2E{65_$6%+ zb^`KQ)ohL7S26iIWNPqOws}qCOKa}o+PVQwm=FMvnYbW;_)T%kTf2Sg(BBs!K3G~2 zeaHaO79>sMqfiD16w*QL*PePc%xpHE0)G5f1uNp^iuD9b@7&9R4&~eVrylyoQ57(C zaqxgP5rJ(+P>IaVL%TUDZQ?lP76Y_v6QWqKQSaS67S*}SmSH&v4{Tm@M0~<4uu*H% z#22iyC101_>#HgV1GeKP-+Zek7t&BTf%ehnNCB&{jGBv+Uwz%VVd+!RA%=lb!xlZb!4>q{{H2nF zwRICm8&Sh7oDq!Xa`BCNW#0X*KOZYj;~{?B1!5;x`_b&ZEI$r!vS50gP6#a?J64qS ziOmqGeH1WO-#%q48hZ{rbd;ghahdqKGxpcuuG0-L{qt`hsQU8z)y?C!G!(&nMaqguB_eY+r0KC0FmSUB-)8->whYYD-?Jfk= zr@KITcw2cMLoL7VRK;fgf4PMtc)kI81o|44!)em}*um49fFv?qjv2>W!lO9|qR9Qgx;8RjZMzD?mE^$xU)P z?Dp!}^aoIXa79@W`SQqitB$=D+S-r*Y8}SSLD1bXTOwkkUxuTSzzX*6bF>DYbKh)~ zeCxEe1}ZeDTUc6_+TprO4w`xKkHP%FrNtH%zveu?U>HBKk_qs&{L&%djegsZ|DnCR z^qjV7q+#k6X2@d7M1%1kSqbJ;1X<%=1Q(`AIHXK>~6{hQJAznZmZYU?%gTsx)qK~b1stM|mIb-?`pCDrc_7cLM` zk&QDHK@_OXTYt8*xfIWMtAF|%0kCq>h@7t+rjTUB_De_ewi}?9s_N0 zUF@x9qgZ_OLDE4)S=RDpuRuKwh&Na5C#D-{=iu|%BGcDF)6d&?F|(rX)xyLFrJ&wg z8G9=lhe7YqH)CuT>9?9yyIeW80X|z9b2{!8gKq2;I^v-NK%u)oQ_-AngF=ltKWIHG z6!p-HbgG}}QyqR{X;83z>&lA@fJw584r0C3<7yAQj9`B+mS7$|MSL7oYQoON_r4Z1Z~|vr&@4PLw-9*Y7@+Zg=Dt{lS2O;F{mN^aS;v4fjdVwP3q|($;H* z&^2BO_tzW`Lv>Mhv7$*27mG4Bo>c1oxI9%>8vm~11r>5r&Qva3%Dsc+_|!?LXywVS zG`h;_aVT^<(!O%`kO!D4c2(n=9U1JjlQVXX#&C*II4c2WkA0WVOSrMnt5B`7q(X%k zSxas1EHFzv zn^0%f9Z-BN$mHYGfxT#E>uuW}DRhxddUBnA_p_XPwf#@2bR+3v`PX>EsS(xIlJg=c zOnT%^_svlDRZjIoIJ6)#1`YdUe65^2hzDJ#lmDIu@reI8iq=9KA+Ht*kF4bGZpS1P z*miV-rw_YWl5&rWk7S>DhFq;o*I=yzJDZW)+W#h~p0<4yp`Bf;xVii&rY%muJB#0P z4qOig@stHXubi8`X_G(1$z^gBd+W;|L}w3AV$I%*b7dNAEvEGC>i5&ek=ZiyfS;O; zZ|MkE7@h0F`05# z#(W+jc)N-N8G4}JoF(^2F?&?jETCan#Kj3j+Ex9hwt#%$8mjVgkz%AgpUqs2fZ)Uk z8QsKB@B!ZB+pY9{hSfz{z-Y&}gX^|13BVYFkRzQ)+)j-mI1n7m#+vn&1X~aFvw!EYb*&mGju?>{=vBiIgxum$d=1HeCl-{`W~J; z;!6xRNQtbx4tl=2{Lx*4IQZ)2*r|FB{i}xibvtJ#c-`i~VV8g19)8J3EPB2WE(^Ah z?jA-pUP(LCERK6g$&A$g27g%N)V^~^5k=;>UB~r;#;NW)MCx0p04e{QbIs<`j<{UG zQ!klspV^?NmB*v5E^xDWad~vA7=W~M8=6a-qJ!llpM7}sY%zx0Pe&-Pv8?Gh6inMZx?W){{G2&^3=iQ)HmxBcqmX< zpg7}(@tHFh!(PBAaT|YY|FmYP3g%uk>VUex-}N8eo%1ByFd#E;7AXa~{M`{yq}rhcJ7{#kjI_i^L-w0Z ztIV^Anal97*ajFIuULVcYQ40hiA`Yo`XSxcg)-v8@}g~C+ut$laExb7T^h-;HjV7c zAstHI-Pk>N5GOH^nHxB8)7CXFVF5=ZXTDuRr8W-nBudwcDJWrG??D$9sFpQKG{WiQ zpG*%BQCi-=(_9aXTN{Ycno%Txi<}N!v((Hu8dI#`WfVs=+Z)a30BD`4m-|LkZ4PW7 z=7|o!!Z0C;!`cgQgP-t|ROs?!#Ap11D7euJyh|im{cUi+p_HDk%PFxKTl(b#LM8Bj*o;(cWb}PE!lvLf&MZ;Gs{jIA1L7k zyUd-wWmz-76kqZ4g?tM9rAyVk*-|;}=XVKi7oVP0y*?BJD#u83rXMR4XTyqGg^;fC8yaK>4kZ{_PZCzMH=I^>caZ3*-E z)5va1<-(^!`yk%Mh5-!*iKNeHJCo^Ktne?R(Ro76I5fQyB2GVI6f68>!>a-*mULC*AV!4Hxy zTLnb^(|pL4o0d>|BCq!784e4YFdQe2}m)?jLljV6scmFzrNTNX_v z=MJ9wtB^A8uQDZ=O70)|iBfTemp`=N8P%HZS{EqX2|N$*%*=K?++D(MG`_GYcGUOg zVs(a1t9Uj0URuq%v*A;8Y?mMNEqdail{ft^Djx+rNB`yaIRL#v!Y&-a`?DUDWNqzQ zzDry_x*q5F1rwFQM+5hN84ZNM=QKjof1f%b>MkTEDth=1kuuX2*lNF_)kvBCu^F5bE(a-}ZYmGXV(4&`0PBMf_a zJ$SAlfr|vg%G>i*wU)#;{PfU_b(U4^GXSG;w2)|Buc@BM0}Qk$~j>{%fSAa z`|+|buJPpND#^B{)Z(UY=vtl${z3;52 zuQzcN_J?C>Ka*xQOn)*QV2?_2Cl%TjR_->F&_V5a1k|e)?>UWVIJZHx^Y4=GjrhYu z@pp?VR2{}wXY-}*X3y_+?SkJ8`Zm~2W_pM3c5~-;f@MUw<~Msh7BgLFz?SxPvA1_z zOpIKN0k{osf$KH-!&B(SAHs=f{Y=r&4f-!?E9&S9esb?j|BuW?WE9Hs@ZC2^@Pixp z_B)eL=WgX@T=eeHR?s1kkRw!coRz|t7a&*lIqWSf46(VP`^o`(Wb$Juedb<~TVSjY zq1R|Vix+ImeNAC)z4qc;xyen@E5cKz<9SBanqo&=$ZHRn64deM7ar1~57G9dNS}*~N2A#E3brt_z z%kTtrsd53%Sgpk3b~|OyQdD2d4s1|tVmB*%x2GYQ#AviVQx{43R&8Q6MT|n!@w(;zNiHUH~bo>$*KmDH%gF!CFL@oO$Oxfkb zF#$-T>!*A{6?K~ODQ=I%ABo3O?A%MH!)`qXTd5O=+{!dV8P&#@wKa;4K{fXf)HJ0M zB_oCP%~5U%#asy^U3%(AwGWL^I&Q_SC-7qlKOHOupL+{3CWc!~>66fnxOknixZt5YEswjO z_FIlfRQTYi+)k36Iuk_TM{HPAMJuJciALzdKRwl<=O2bjXr#!5du>Iu`sVnJ2REXp z#<0-3-nj2C3_p$-kayM4?k#J}f^|i}o&IvdkJrO+&Crp1{hEEw<<%D*6$(k9I*G&4 z5l%A)Z8y@{qLJf#mQsd(XuHcai|0%B%dcQgE0v5;%;Bg9PBm+l5UvK)B7adV`*WNsV7!4uG#5E9vAN*giJq=z#XcrKW z>KrDq#c+*p44C(0;{Y*4~MQ(itt&Ne^Sfe*;1_0 zSm8Q%eTO>hgBCz`~o)nw!G)!`mihh0YPG4Lf>e1@n$mR#U5R#mQAJ%50)HeoGdjln0ZGY@sJdD&z z|0B{zV@fLNt29{WLYtvAaUM}CpxNd3WhZ@33krd1Rd(o;es%9Avon6(tNr;zG_Av- zd8uBht_u1mxISPUuH*P;%8c6;ewjF=;u;0{YV~#L)dL?B^vi6e2)FB8Z;eX9x)Q z7gqUbZ~7{Z{8?djJ(h6S@!?0o%?h3x;`Gia)JTy!y>myhMHXjnIw{WYy17nlE}`uMnq&J#h7p)=>qMvh-Ag4J z+gh-fcg&sC`kw>6E=qmQi1gBoM|LFZqy&&u4q?P)t_B^rN1#|!Ne(e+Dlq{ zXkkgmC-0=M<^2zHFxUA2i;Hp_BHNTeAMM8`usNxVvdub7xjYKP2lQ=V2mi-4+HObf zZjDbs=;%EMy5x*~0RZ4iqtOGRcU(s_ucaB+U5m%NN8vxY*9T4^hhCKgyYDchOAM_aV)A=)b%PiH>5Bb&o;4|D+9H~|0^K$WiLH4(ePXZT1=399 zM13jrR_kcOBV6AEUj3CF5oa%9De#=p!AD-yozhIWTD#PE%FPPDG45bs<}<|0g?-0c zXu6=9A39g$2JqRLTy*ngw5Tv)?2A*|Mo0fAGbjFfr;BK+ph@0R^PgBmq!lT z0ug?Q4!3+^rIcr9vI9pTxP8LQ<_QSl{dIvTKg5DZtd`#%-%Hzn-SX0unYX_M4_#8B z`dBdGg8VtkZUA!JkeG}y`~+0{KaMB=DnQAtqVXo9!`AHoT5&%2J%!XTy<28 z@d{`k{Yzkeg)-}mTu5g&7a=(ToyPH5q{xcxP|pIciOuEBqqdGe`$uUwhmhLe#~cX> zta9R6b4uIMl5NO-U&QK0HfAEk4&dLvrrenq;N)Fh+4)0+b>>JQV30yq!tm>^@s;-0 zU(HFshziI=cf~{X#$w|%fKRY{0rkCDiw4`vh(jM_mMS2(gTJ=Zx*gKk6JOYFQYPtsf@s5_jc)gjx^ZB15R{U~y%|J1XQV<@5v^!}Ziy~q9% zK~5nUrjwPKOT=F~EsY1xEkz3n;0~7FK0B$d=JThqwzldb%~Lp%~p*-Udf0>(N&_*#YTlHGvqgh)C9Od8hTEC9-G_SYtMFoNwh{n2#Paq z4&DX66XT_E5rfpgUcnftBUJ^9eR)ODj`E1wOM`>WLgf2zF>rl5t`+40UJ@7Bl`xMf zyH?$KlR$NCh5Vxhubq91d!b}YGz-YdUcz^tA>93o&tV+~12uUhXv~{B>0E{I5YUR$ zlSbF_TlLR%=YV_O6KfitpSXG^f(Ihq%8SZoLe@PZ2#`xPwNDoz@^z_(jd;}{NoFv> zXFp)VDl**>ek8yHPh?f-tA87~uimY}5==i75Z*eN?$Qx2^bS=q;S?$S$iRX0Ch00o zYxQHN7}50T=elfG3c^VYu&$|XMb`OQvHon^y{YnhiIaZ^n88UXZXMgK?qdij*iHv<}o1ZFLXsMussk-X0 zX5`B)`pORblldBv!t^rp!#yy$Mkg?jCii_0+P|3qN1vG&ENt#@Ao9=~wVbw%Kjh^6 zJT$obN;Xr=o$gP3C5->q$`(=|w>||xkHg9zS)>bG*a=)pU`|Eum>5{TXP8(yT(_6D zn@l5rQt{PKFvSY&dN`O@MOR^Z)TZY|E{Q zV?~~`;EYCrANGNwk5%6l6I)tJX5{@Yt5MBF*CDt1YEk8BZgfB*ifEB15OPfw54M5$ z65E2OM(p+`Rg3!E>R7(Rfr!pwdFbO&zSD944+rA*sJ%KnE|LEhSsYFW#7-L2`Aook zcg>duo!Wp^#U%u_cZaG?&m=7GBqfbsEV7gSCr*a^bg3}-aa18IjK8=R=F7~o6%_ZF zE-7q5`)foqI}ajC^oA%kIepxs?ibjTRAV;j%C<#%7fK=FMvEVr@X}+)6%_o&D;S@r z_$jL=`*+$dk|rDX`-dF(FV3rm0HV$*T0i_??5tyHaVl?mn>)7u`cYSwmc)>2Rlz-oN4)%-} zT1CO!)@zDXcaCZ3$}3H-MgQ1`PTccb&ygYCHgAh%aJOzY&?-DvF4;P0oAxf`ks zNMo})ZZsBw$RAaR-uV2cVy8&-chIXfRTVd*veB~ReE+tauUc9FV%SjyY+CLLId9PR z>RLvlCD7BT!Py`_=#4{B?PZxHuP5GUv;$oT(Z3}RbuxjCJDumU_x1O{O>&)K%#0l< zH@PmlsyI5Q+Xbj4J!ndDsO>vfw?hX+{haz@nf%MV2n(xY1x;ROOg*?f@uqvA&VeLv zX=NN_0#rV-#^yf1q2$1CI@DP^dgbb|oE^1K-TUFE?!AzE*5)wwHabet$9OJZ%-)76 zwo_&^$T#L6uOrwusf4$^a#vytC+dQjVi6#?3$HC>@S{)U zmg~~XOONMCoj2Shi!af>Tsc1N#BH`Kw2Y$o(#Odbv31P_EyZ`TFOqj-=jv;RP;k0C z0iQ0=)tKx3C-Ty4Df5es%gi$Xr|EZq9Y+q%Z?=A;aOhb%3BYy{dm8&AETi%E_3%U~ z(Zj$u#!;E~krQ`qr=M>?GEl{xYJu(6DysKfu{A*L1qs?|&QHq=l!sW4JIDB+rhmb> zjk>B77PPI86CJTW0CT+I7JC^97QM7a7X0Nl2m3E7h_-nhGCjLd9E8x-;r0ORe7Q*C zvssLttCEd^X;EBN5cbtfLa9=nm?}#O45_R36PLqRsvK6#4fSNfec+%gLUpk=5P3z# z`7xRS?OrIN;VGmy8^gK-aPO_cZ3RIpVBqyJ~QHxU1tG_2=PlChM+z9VhU8isr$Gpasqs|DXD9Eb5k`ABE%c_4P6=Abwd7kzw zxq7uzlpB3c(=fg$OBr)c&e4r+oSClqxFN`n?biLl)@ARd&3la-=b4zx%8{$-=_GM$uX<-qN&JCX>F(F1v%Xt-5*;he49(*7|u~9X-ZCapxZH9p`7TxpMW0dry z+iFx2IfcL;$6O+I`j~p+(x=~Ob>aQOz2ZYe*lb*>FGA^)vEoS_-s1lEXB9R6TNyVQ z|0V+HUIXY6)I83C7MK9BsmGL(A%H`04HE zXA3{z47O_2JPYa#cz=yV+HJ<;SMs=dM#+WPh{?vU%b1bEG43jaFT-?MM>l#DK-1Ye=)Z zM*Z0fJ7_84F_n9k{;d@@0)U^1mz6^W@^=f^5e1A~$(mxkoi>OS?LN7!*AE(+P}z7O8-qj^O96O14-Ri4y2%Z` z?bC&a@zmnRr{=8LVwD$AD9MT*OluQc^QbjVb%rPdvXJlvaNSDTZ5 zC|`cMA8qtpdtM#bT&1XFPp&0!+!5Pa%zS5sVls`RRx3G~Bl8y&Z{VWg&m9#;^-`EC zm!{>-Wr1wBfA%I)Ki|2@!ZRONXih3w#+um#wKr;p9(2Zmn&u-aKPZgzOI2YSE856p z$`;UL&XEzRy|y%kc&i?N-H^907}uMOr8l@$%R z)$RAwlV`4>;k@BnXaAp2XHo%{i-@=Jp53vO)$oJgM1A=u>%8#R&gb+LUgfpj49=cH zlAkQloqDcIT#~qY1k*6i9L4KMSd;jyf^^@{1a<7hZungeKelN$2%Pd*QzR`mrO9d{3piE9RbXvTX<+h6<*%PkHAG zIgI#3&klM}LHd@zLT`-=YZ47BfO^IYV4;O-;V{u>K9gV16%N=MjvslTc~B9BQ|C%+ z1W3XRxSP8}W^Kf^&8>opH$cxx=_Uhk^rA8lq$Z*`m@>&bx4H8kcl{pw>;JL<7?)kN zk@NEK_z!2`)#!R7C+M4O_*Xs8|6g?O$0xNP`n5<`{WZUgeyZUJv#UA3HK}w_T}v)5 zdrhdOV^X7`vP-agZZ8t@r@`0J@6N|^HWt*`zwahBC?lITnFN1?hDDr8H7t5ku~lEz zeej$k;JuA+U-_@QAB!7&n;1Ghf`+QU*C80b=S%6zJ`=G2kj=QoR*~?dIh^y>cJ}j(!`oUCIA?c+xNFM5MO>2=gGkgTZy+>d0NS%f9KOFQdk(lCbI&N!OB< z5wOr59l=KRK>yarC~Y1fv9@R?uam9vXWK!r5%+gdzlQP}ZdHstX#MU6w13vSo?V+W zao1v4S$|=Cwej3`C1J>o>p;7(YfF}#%OmQjyA&Ga<{c$0cpL{!!3yk}xu2O^n@U%y zsK$XZ&Vgi4&^RL6vg{F+-h;Mi*Ke5(Ie*9cozF&@?m0*_GhNJ3OxXuQG#HCyw zxjgP0356`Ka|Zd^aceJ0yF8H^MG_|Ess$u|5p8a-s|~{JCdNS@mNwp9Rcq)ch8bRE zM@5}~>Mv7Z3Ig5P*maEhbu)<{ILRpbLmTt9eKqvT#;TrOkW7%(Y2UHWzK1ba6S=A} zKgN#A4m;cr`om~*!3<6F|2LzwG;(=u%Ydcka>?$gpCn7RA4nZ#cY87=8-`*Nbw5Y} zdL?ttbB1#NJP=OfP#?{HJt!}>x-Gk-_3`jdIF)#zeM~{Vwn)A~UoS+0u2jm~;qVR^ zHz^i%u=c)#vjo0=MW8Bo=#fj-jN$NQ-Ded~zCH#R_e+Z9RwAMjOT0Zg2(}FT(xfqB zIyTO75%SdL-61((w2Pz=c@VJdfpMb>*MUWU`<;zvU+%K;ztmMf&AqM>kGmWH!z^%z zcH8XBmkm2`E^nVdC*Nuw0=2}rcP+dgVK|i~`|Amr1+%>Fm?=o=}jA~6}pE&gLNZg%hc1Q5- z0QTk*Jz*v|2kSmQ15H=q%J&<76hKjU;VJ5ITefa2U3hBDiLxX&(b%Bp`>dFvC2H={ zmY~eq+|I`TI^q%ci(F^|pD50p3w+k2^tkAL2yg7%L%wY}lp)wl!b-4%R&3D!zyxb; zyk~2C64C;)c<<@Q{go`-92A0dTN8LHwQ)bzy*5yPH~EkgwCHUr9zj6GGMAOaRZCQ6Jy?%j>;*>`$7zorW%?y!s0rkKD9~pj-#evd zWtjFBBwlxpaA#9Lfh>cF&_WwH^SqJxemP#8p?etl*O@=|gkqcBg5^Ex z$x^Np^;;{a7dcoD)!t5K6~u(*o|IIs4b{27fKW?v@7Z>)%eDo~QTHVv%a|E}EFE&rRNRwfe{|)YA zut`3p>ZE} zbsn^*7pFY#SR5#OzhE5d&rU#6ufE-i#?D7w!t(%FL5WfIu1kzf?Csf2!rP(ikGvnW z>?lX`mr3}6i;HZ%9Yz`7(8?c=(?)XxJMQ3VTz$*OiY`x}yAF>XOD;nHk#Q*lN#x%mDekg?+M z2Z7q=$LV!L=E)0tqxrRjE`HMAsKSo&j{$nfO^mUA>8^T>(`L@$Hzpr-#w%Hywx>aOk5E*xijfxxaA zT=nbZF!?4xwmi(qEG@QhNtKE@?UAV^AHL-8-+R<-vak*%j6>E+aT$NShCmVV`vO6<+LoP2Fl42CBDv_vzI#qZ2;9p6?;lj0v{S?#w$-Hk3Q&xoqZSZ z{i$+{5nt*Dc3uq4h*MV=!|Ub3k@SV6?L=D-GSSjQc#1o+KiqLkt}ma7? zWbG=f?W%hghkGNv)%i~w`p7;=wdnH0?@n>unI;fI4J*+UhWq)S)EQf9>>Igaxf4cy zE4?!#Im}7fkmY*zBah7Dzcc>g--7%b)s&lpQx5LGMO2u92Su$)-!nH=hZQ_VunO9m4HM0gAYmFcI)XYpYE#@gpi5b43q0( z;%{xkP6V;%Ee|2qHGR8Ytk&b9&z*lUI87k7fcnwg4A{`CQ#{7e%~h3M8ScN_Xb;Pi zg;ACPq)Vl3WdxKldkwu0-Q_=j0+(t#7mp~^QaG6c=X?=s*KeSluo);D7!o}?HoS0} zC4^H_l1>_7W=QTJZ=u^NMGIGMbMG=(cl{E|XcUK7{1RNf@(t*&fNFEe95Udspk}~e zUe<`OUr4E9`k(EcSs9H?Og}Ol+9Di(b6*BIOy&bQG!~tcjrAdX$LWa8Y?ta zvM3bARr$$wi5`4+?4XJah6sjBZ{QCfcP)UIsEqhMJpuSJ_J98xdcye$Av)Gp@mPT| zHr6!CA?x>^h6Vsjq-lQ<@IHgiO`7lrZMJS`M{7Twb{J~s0v_x}uep`%My{~0;R3<0 z5ra$JR?QqOstXM@<6qFn!j1xY1H$aEI=zKN$HWl4ZR|g@@U6GNXVK_6wW&Bly??7< z1s7O#hAnGaxi1`jv|gqeP{Ea>b+!AeO;NsW(aOTadN=J1klzzaW0$)M66a#zf{wv) z6iouPdo*DaaT*xHL$VCo-ia{`b{7v>qbuP%;@hWLo7uWt-~HfdWKaG3q1oK!&R|vI zUq#-`^xg0+F8+$VQp&!Mtr^SYA0obeC0(-t2cc;SQk44CSSytJ4vO`XO>~L1<0fO| zjj_kkOK}nUf|+oOS`wR<*HZDa&CvWuWiTEYYop`$Xli%6iHdSbY^v(n+e6#ocsm8> zmN!F&yVj@0eSu;!P@&KZ6xLyp}n zD*2qjwhapEUCg!q7rV9jVa!_E#e^K!2ggS8*082J*=EeSWDhn^G zsF}-6fhYKvXwfd-a`7uRbBaqz4i+jxY#5=Bl*LSn&xd41p>(4a>qc$oGnO>;(WQdm zRCHUM^?z=4T!CmE)m8hoU8Z)|Cz<$?Z1pK@Z~Ox?U6PgQb5&ghYiDfvnRT}pqw_9T zWZ_M&b;5#TS5q9`-zIww`92#Snzal^G(}bS4F)%`*1<=OriP8b!w4D2v7^(cZR06S zI;Jgd{UmHBhshrjZ<*aKr`X#C=P|(g>sed;28gnK@@@q=sm;UgR4er#`z*T*DDF4W zD!-_?|1%|7>+nbjc1eU9dow}`5PzrU)?IYN4hrpwjI>SRNQDp-@x=2N8a5GC}COC$wv|*Ikgk;?I(fj+|e#6c+{8zy^_kpx`=^qW);Vh(F|o zpe(iIxj&*7zYwvY3e1cm#B}-R#{xEc3$vmy+pMGaEL$}bY4YDgqVH?u*I4goV!?e2 znSK%9Su61@E%huL(4?7Jj=s+WMX;Ha{icK;rO}u=I@R1SGX%A7g#?jmzyI-UA+P?i zk6bVcJxJ1m$fP{msLr=tTCp!&pbwHGe+MEdDqi9B*4^2`=v(&(Xrd}!+^?00NZ^}@ z(gs_R?6hnDDAwC=Y{DAck1$42tFg5F6fl|IGYCv#F%yjY(eu-|!X7`njOoQT( zMHK1p`EjEo!H!*er)*TH)x|p7zdhS);ASG5AtU(Nr#$I!%yE(*5Ld z>+dUC<(?}7yMcF#1RlPx;hB(@WbGS2__W>=@+xDaFtXprRyL{_EM`)BKy`K+6=YVC z{PXoh-HShC#lVhFIsoafT8ML^M~;M6uMHoc zAl30YuJc-|CLu-po{o`wppammBLvfO7!%K^O+tS9kQrwKMp{04y`qTh7CaP~p6&j& z?)em!n0v11q>b#fN5C_2b?nWoi^}IuR&X&RTW=rv)8*^VJxPqJq&WodHpJ{EZr>Z* zmgmk4PFz+JqzH$UsE^%Niqk3^3C1HkgMx#9AvNd^q3-jPYFo3@A%}hkOC9`b7ueb} zbC~7fr`a&(SU7D=>(%sDf^0hRDvK$tU!2IfFHJzzlC` zgP&A#=BNZ5yhHZim`vhxP`? zn@azP^v%v(xbiNzWpxhyfW%mF;{)x`iV}9@fxXUpM=kVw9K7st!W2p5!ojiB?v+ys zw}SkkcVDpQN=d!mvOkBZ4J=R({+3flQOSAKj36qz?$gqGQevI3zfN2v3>l?BUv=$Y zsKV7B7P5A;yHpEF{nIbrA2XwJ7)3`&M(?-qAMAbRst=TZF{bvCH4hjCj(_Q;QZTjX zb~w<}69OD%?5HSx_#x1frnB3iN_mIjLc4)NZAslZ*F3`%{#A#W?rcn{38q(Hxh4F# zr*`fgDk>}lu-J9SxW>%%I+Lk%uF=k{EpMV^<5#@lV|?tWTsG}3w4gi%1Z$4%RrD^%ew`c=Ph%#yh0 za6Ds~x3TLF^y4$(BB6&Mk;(Xd#wj#RXE*^ux2)(n53l)msIYYw=8QnUFCnDI`-fEx zzgs$z1)BED0EkmyS68W78MY)TK~k#iXrR1%^zeFr$-dTmp9f$1{@31jg*CY~|DvcU z7;#%b2t*MJB29`BB;W=S5s)CgNDZ@zQ${lDj&^E~I`%LVVnJFGRc)|y#s%{wzcBjqu{7W0B-)WJisJG+CY z-DvSl81sEy#|x{qLvxN21mb9f@(cjjIy=de-{sZHz8V=`oH|Y@e9H)c5G!UMNR}{@z1wrj~LJ@auRak^HiHRV2_RSNVkM7KZLK%;2^dI zCV#riDf7@5|0@5Iy1K8N>Xxlmv!r5`2~_nv+{TlpV+z0KMcAH@yU^G(hs2q6%i585 zb`0AN1_`(L{g};9Z1VIPySK`&oAC~EiTi4yh!7EA9%ykfMn^`>sUd$v`3es{)m)!Q zn}E6ipA(XpD7!iRt1k9(9CD2Xe3EOyqGi6p7Vkek_as2KBboUWlmcIrBGqFtCQC8E z$9y?&KXv%|#T33HiXVSq)N12r?Nr*lRl0c?@ORNE43dt*sAlQFQ77eAdq<{|UH^^e zML>RWI@freU|^uwnL(?jXLnN5x9HbsU2ip+i7r={kzS}&-hpoSnx^%;d6O0}WE1s* zAdvM3J8BM_pAmSHd<=)P4OiA{f2zN}mV522GRNEO5j&^_(?2BpghFRoiOt~83rrP6 z@$2U&AOsRPRWP%n@+-+c3R*oHGL;eWuCid?$`KWHE0ccILkA7w7?CBET#HF|vak0? z4yPO5MhG!m7G51GF<+tshtg?9otbwAixz`wBFUxMMmKo%Rw)sD^nSx8LdCa6i@_+C z?nP>7B94#clrPfaWZ-#-R57^K8?|12o$x0)Zp;!fH4!6M)Bzl&#T1U>_jjd82Bm{J zj)N4n3q8U`fmLxY@~ldN6FNr?VHz`$Z1|DOHJ1xlIh^T+jY6X$S+8{#*S#O;1Ut2} zwy$VPw+kWjCk8k+=>j7Ki2w#>R40H&Z8=X{Y-J4;^AVD<{u0?+R<9hpk!9OZC26Ct zq=pYdG|JKq@sS!-j5E{S=pzF6pt31Rc0x*rqe{vQt_=32vOSi`_wdc9X zo~tKx+wE3%Q!reP?ID$? zy6-7VqoJCU|RmQm5!1sc-2D!GePVY{DL>#5MXo(NQCS~WM3g$RI6*8k&cOFew zcb?dUvc?i-uWfnCo64zc1PaXRqV@6&9GjXxC;CTrIn!so^ELbzUKqL7VENkw1SXj` zPJ*IWAu6LHPL;0p~drnEvUp2b@zy zP3vzRdRh}(zy$hnjtF+ogBWua>(w=scbxB=bDkP6nCa{9~srq zzE*UN3ePvkq=mODzA5dPEpEV-R)+6}8zWt!kGKt#{D~?mUsk%BmpT?2r+~4v(J%a| zBiM@t3szm1My}Xwi6tD%evwrD=*_}?M*=22tR$h0Bk^6gMMj*%B367Qv$-OiG*2Sm zP%8a)9NTQ9aD6#GiVu|9o?UefYu0_zbhfir=B9^ow2A44EBt=9F+8|SC_`N_Xx%b0 z-c55uEYX48ROtf6pKiV?DR@sYW~#ZZSI9fF`e%1ioc*Q+(=r4o4sa}Rc)JyRf#V58 z65&VsnVEkb%d41X zVz#}-&?ku~VxQZOPqlRmWgk)H^0##&y&qaW3Y1#0W9O?zQ_Q#b3shh4=B)TWIyrvj z6rnWKO@-396QN!;m`F&=_B;z+$2D=T+F$&@F2mHoVtKA5OPeR5rU(4W6UR`NPhWJ8oH(4C!mKssb#pvpZCf=dKri_Q?l@afY;{>d zoGlf5*3^$b{^wf_Nn@a%T&3KV;JWYWEy!2Cb4C!Vii4eJpX=(Xzl9Ebb_IMMM;a@w z!`j9bF57L?oi6{*5GSZm$4Kre=?O^F?k?GwgdgZW>uBzoe&~4gvM08>4ih~4nTq@r z&__zLnp_WCQ6ThgI@R2_TAJNCf79cmXAkL0km$(4s{!Oc!tioC-aGri7Lq2Ek;z)v z5x{|Xw^57|v9i_8B_o=H*=U0=lqXf(vryay%KN8Q0AC_N9|(-~2QIHa+u}Zs$)D;u z>>r`wgQpm8_#s&RM!PZ(`ng`ov86^{;?DzGkgauIk2R1vk!p6`#G4W@XV_) zRBbq&bqz;d*IC+hVoow_Ro^gXKJmzQ(8?gqPjQ?Z*Ro%|Mt38=p=0dOcL_Q?kVq6izcA7(hRVa(%!L*Tb!AHpFs_qVH_G2qt~_LC~6-r$4o zhzj9nkea=uE2nZO!#Kib&klB0D zVWUR_Arq-P_3ER3*P>Y3JH8Adyez$ROu1JaC_*(vS{zJlal#L(H<$aTrX_t`4#?-? z4l|R4c%^WKkn?Q_9hn-<)bW;g!bJ(23SBoEIY0ObJIXgaooj_)8MFG{1=LDf@lW6Nq};w5j__tDn#puE%GI#Ha!*qUM<*$WQd)^AWT;KKNym{93$U#!t74 zOeOElbq3_iU?%l+dz53l|6BnTZfQ0$`3`cY@aFQgJ*6}~;*CDcancmO9~-{tFp@`o zeGWHfX-B>nIV&0D&IzQKORnf2tML7Zve&82b@wZefP`r?mFAW>ZVtEHq@j@os?jkX z+o_YviR)1Y*b0{2PFNF3w3|X5^=3XR)MHLCS;bNen(FsAkXK2)BMr#633j-Jpqa_} z+G~ZHskD-uARHsHHJ* zXdu%*D%IRiR^BdHqkMDNO*^d#`{m;%5W)fVLk3s#tUf>&8%WnPjzW@oJj&YV{N(5v z%^gt5>e52Ri|#x^VuO~$O*PNciUxg_w{`~cTc~AX;w__vru}%wp~4#XwQ2bMj%8)3 zwaoC5Al2Sa&;uqqOG%jE6%en=7|8ZV&&>qVYOnjwAeeTxf(5Dn;pWo^UVcHXPoE{( zDJRP@i~!GCLL|gQ{R00+u>@(^lH&JWnSUc-EgN-zv2=UFtT)O49cHQb(!E3f;Y-Ss z&z{Ou+K*3)@zy1X*0B`Nnr23s=X|ST`bO`@9YXlJ$rNi<@p70-yfI>@I;!0v$|7Jg z_B9xal2vnwq1`o=Z=n5L>Oq>}D}(_2j0?YZnu5ZMp+Yjku;HjdVM7fwL}KUUHi2ey zvQXxRQwT>UW{yqD6iF=nvFsVw=lrl1PAf*ZzMZIbNHqK`qF?Ibyd3g!%CyHW3lnMG zHdd{Df64S@|9HBs<2df=>?il2XV2*i4&QrcLEUV|U zsqJsz_6_HK@}rZ0$51I62&%ZY?_AFZpoo-iy3 za17l;r}7C7a}U)A)o_?hr9GPw-YTJBW**nX*(X>mSd~|%90q*h8j%yffWi=3pP=Hp z2iV2X+ix)Uf*sUh$7p2;Uw)$ImcwqG2DF~)qR*=*(iWBHPFZN!T&0?J+j)K4&aZn` zFW!Y37>nu#E;KorO{x>8HUx6-JV}QxF%l_JT}$oTslrrN#{#T>k%Cky_sube;nrup z&^3=Hs32BV6_s-eMm^p^2~x$9LRa)7jmMoOOYR$`3%=TNiJXvhksekQ(|Oh;-{E6n zn`irM%Py+fvhimAQqMg(;idOOvxD^LRHPd@z(5jN==a9_%JS{PRW%fsW=%&=Tdozw zdVtkx1oTY~bJCcK(jQq~FT-w#m-1%O&i7GwMy zR~~NYle8LT6)2ZH$p_o3w&EkO0pJGz50kYc)%~2z_lbwxrL@2nm{n~^VwzY91~*yu zJ^Es;^VXv_^tGcqyJNcpJ5LLL)gFYXr(5e?e%k#UV)9F1J2QAa)Qb13`Kb$@JRp#? zp)~2^!9#I#8QGp*L3jEf%*ibmbisID*X*VWFSs3&FUWm^k14(r5mAA19xdP;fSpTE zAiD~#4X?wlIv2M8!E1K;ae%JKnr4t?Q@8sUnsYS`DKRziI$U$&i@M!pTs|}x zoSyK43a8Hfxn{;|P0#OQ2Hp1tszMe^FlIkeNo8;B(<6Yga!2*dmVZf$!4c-6#^Atr zgv-i{QA0GoWT(*N zBsz&J@p@s33gJl1Le{_>dMkJTiv+9nWOPOESrczm>ghTg!<2||3X4gewPoBPT)OA| z+B%};Y0ag0-&A?~!2{Dvvu%a&@$ zvVqw}{y0Rw6d=k=idM{7)RW+=-o6rhUOe$bH&&sWdZu_;GjIa841G%7L_KAfBK0B#Z^T=*d{oK?;=(m$v`#0QGm?9b=PsV0?jg*$PW=2fk1i|zPT|Nt)Q;*J z5x`Q)m_R5FS*UHG`9K%| zSLj?l`Ie3gZgY{(#p6iEvq3P?M9nYuHw4y=PY!?eBGooBHBxTwPYfW1t+c~kKZ)=4 zb*#S{xJPV&?9xCo{c9|zWkIydZ+t4ZQw6Trf`fHu@A3ES(|M)NH>6YbwK55Kci1g4 zcwyVABkDR2Bugn6H&X_b_-t!-d$Px#dKy0QWjJ!@^>Hr4oxVj@a_C@}NFUqFpeOWXmmfmA+8(@e0a77hqrJw6Q2 zJ?@hQy}{NLn-t(_=4cA7Kwqc<_yJDpe>Pr0KPKa1(PxMn-O#rQ4B}@rn5Y{H1zNqv z;5Ldk?)ahIJe_l#Fts?S4fzsn=G`nW9dzL7IjoaJ^@uya z5zsI&t3QtW01-q~xD-!Tl;gf#?R1UW9&6d_(?C%4x%wUs5Vl4#)>RsL%>Iv_{e2Da zpplXJYkS-R(J$H%Zu(*kd6Nw1dvGza;aT{~3wWIn@%lfnBg;cq^e}TEdKV@?^PUVR z3{0e`Z@7wWYKk%94M#I!)Ve2R2ohMAd+!Gg-Na%SE#xmR zG-7Jb$MWG0b|vyLHgv^khv|nRjh_IxX@CY0e-dL=kJwjesEb?k6J-ISx1SfS&E#qG zwtuq$jT`!dxV8s!LCApN5 z)zbrB&xYT}n#+VKLx?1aWZK5jJ)AsXn2$g}_MT!SAm!G_N~|=Oue)dszQ9XI@iFU) zi5Gs0a)&H~KkJ{kwTJb49jqi=_k6 zgpvMZQrYHkb;{%rpUaN|3;~sMVsGe#GU*h6l>o7Xh!qqjKigd9r5BKB7;A0r#vZO-c~+wV2#9)+;mY)jYO;;rdwY@Otjr|mNBc-Fdq;1 z&*A$`#!ay&%amhbKk*0uDs|Nm)6MZ%i_1NL&H~1R=@sgc z1#Ol-Oow4=#A7#_U&Z}}Fdg3)$#;pY@?zcB%`OelU%+a`*z|#?%r|#(;X#kcyYAv` zIcWkePsJ!<9t9c}`-^TJ`Awy8YP{UnuQxO7N=F5PPLuvBJajGK}RZVhuc5O$)AT zpe8F?39}(@UuRZ2)LHE11?>%yj{5*RuPqZ3=Qu|bA}(WU`WgqTFnE1kg@T*0D9IU@ zFQiNjtWrhARV|+j@iVBrY@Fb)0YIf|d~XEmDelcf;$I;z{OJqK`ez|r z)d?)ZOp?=)ER|R#T;93l=o=^Qp~b+GGqznJ7t9|&$>XZFVk-jwc6>OvM(nW{io67C zuiY%uusAMcr`eHmv%fFi=KOU1S|xuEHe4H0f-w3ng*&{bY+SM0*o5|7LfMr{;}S#U zhw{redf5-{$=g*uaxA6p2kc)G$u03xUnI;GR>I)rrt;2v3JA=tI9_d3)anzt@k6*p z+GBE!Vpw$;-#ipbV;ec7UGo09_@_jv5Tm~Qd*i|-Ugx7P5B!!&!LBt^Bt)FDMZpU< zyn^@oRvKs(x>o(j^z+iS60H5i{=#>3b5)SYLhj@#Itm(Zs@>_IV2js)-1fu+wwK)O z7S5sg*EaFToJ%E>wXwk!-`XBTmP`I5Bs)QA=+D%%((jg$=UZs6xBO*WDDTZ^dZewc z^HRwP<&+oZn*`>f6noK?*YkzIh-;|9Z#yiMt#mL&MLG$eR2go7yZpIFJB9sglxEPE zLjTjXob9uThWgrQbE&VQQ(&=KFN|bG5lQF*in?h+lw@z`q^jIo_nLnDw_Si{1bb*- zh|zKc>< Date: Wed, 25 Oct 2017 14:25:10 +0200 Subject: [PATCH 088/101] udpate man --- man/MWController-class.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/MWController-class.Rd b/man/MWController-class.Rd index 05065f2..dc3a175 100644 --- a/man/MWController-class.Rd +++ b/man/MWController-class.Rd @@ -37,7 +37,7 @@ updated when a value changes} \item{\code{returnCharts()}}{Return all charts.} -\item{\code{setValue(name, value, chartId = 1)}}{Update the value of a variable for a given chart.} +\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.} }} From f1fcaf96c4c3068fa0fe0c8c330e7ac16e5ae59b Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 25 Oct 2017 14:25:20 +0200 Subject: [PATCH 089/101] add saveWidgets test --- tests/testthat/test-staticPlot.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/testthat/test-staticPlot.R b/tests/testthat/test-staticPlot.R index 51d7173..78c501d 100644 --- a/tests/testthat/test-staticPlot.R +++ b/tests/testthat/test-staticPlot.R @@ -15,5 +15,11 @@ describe("Static plot & image", { 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)) + }) }) From 7d55959bd11be2de4dd016cf1c2c75c05c1e43d5 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Mon, 30 Oct 2017 15:06:12 +0100 Subject: [PATCH 090/101] add .updateInitBtn argument --- R/controller.R | 14 +++++++------- R/manipulate_widget.R | 4 +++- man/MWController-class.Rd | 2 +- man/manipulateWidget.Rd | 9 ++++++--- 4 files changed, 17 insertions(+), 12 deletions(-) diff --git a/R/controller.R b/R/controller.R index b91ca63..b1d6917 100644 --- a/R/controller.R +++ b/R/controller.R @@ -41,7 +41,7 @@ #' @field nrow Number of rows. #' @field ncol Number of columns. #' @field autoUpdate Boolean indicating if charts should be automatically -#' updated when a value changes +#' updated when a value changes. list with \code{value} and \code{initBtn} (not autoUpdate, if want first charts on init) #' #' @export MWController <- setRefClass( @@ -51,7 +51,7 @@ MWController <- setRefClass( "returnFunc", "initialized"), methods = list( - initialize = function(expr, inputs, autoUpdate = TRUE, nrow = NULL, + initialize = function(expr, inputs, autoUpdate = list(value = TRUE, initBtn = FALSE), nrow = NULL, ncol = NULL, returnFunc = function(widget, envs) {widget}) { expr <<- expr inputList <<- inputs$inputList @@ -119,7 +119,7 @@ MWController <- setRefClass( oldValue <- getValue(name, chartId) newValue <- inputList$setValue(name, value, chartId, reactive = reactive) if (!initialized) return() - if (autoUpdate && !identical(oldValue, newValue)) { + if (autoUpdate$value && !identical(oldValue, newValue)) { if (inputList$isShared(name)) updateCharts() else updateChart(chartId) } @@ -129,7 +129,7 @@ MWController <- setRefClass( oldValue <- getValueById(id) newValue <- inputList$setValue(inputId = id, value = value) if (!initialized) return() - if (autoUpdate && !identical(oldValue, newValue)) { + if (autoUpdate$value && !identical(oldValue, newValue)) { if (grepl("^shared_", id)) updateCharts() else { chartId <- get(".id", envir = inputList$inputs[[id]]$env) @@ -220,7 +220,7 @@ MWController <- setRefClass( function(ns, okBtn = gadget, width = "100%", height = "400px") { #ns <- shiny::NS(id) mwUI(ns, uiSpec, nrow, ncol, outputFunc, - okBtn = okBtn, updateBtn = !autoUpdate, saveBtn = saveBtn, + okBtn = okBtn, updateBtn = !autoUpdate$value, saveBtn = saveBtn, areaBtns = length(uiSpec$inputs$ind) > 1, border = addBorder, width = width, height = height) } @@ -248,7 +248,7 @@ MWController <- setRefClass( input$updateHTML(session) } }) - if (autoUpdate) renderShinyOutputs() + if (autoUpdate$value) renderShinyOutputs() }, error = function(e) {catIfDebug("Initialization error"); print(e)}) }, @@ -283,7 +283,7 @@ MWController <- setRefClass( } }) - observeEvent(input$.update, controller$updateCharts()) + observeEvent(input$.update, controller$updateCharts(), ignoreNULL = !autoUpdate$initBtn) observeEvent(input$done, onDone(controller)) output$save <- shiny::downloadHandler( diff --git a/R/manipulate_widget.R b/R/manipulate_widget.R index 0ff8dde..7a7e7c5 100644 --- a/R/manipulate_widget.R +++ b/R/manipulate_widget.R @@ -26,6 +26,7 @@ #' \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. @@ -221,6 +222,7 @@ #' @export #' manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, + .updateBtnInit = FALSE, .viewer = c("pane", "window", "browser"), .compare = NULL, .compareOpts = compareOptions(), @@ -254,7 +256,7 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, inputs <- initInputs(list(...), env = .env, compare = .compare, ncharts = .compareOpts$ncharts) # Initialize controller - controller <- MWController(.expr, inputs, autoUpdate = !.updateBtn, + controller <- MWController(.expr, inputs, autoUpdate = list(value = !.updateBtn, initBtn = .updateBtnInit), nrow = dims$nrow, ncol = dims$ncol, returnFunc = .return) diff --git a/man/MWController-class.Rd b/man/MWController-class.Rd index dc3a175..ade349d 100644 --- a/man/MWController-class.Rd +++ b/man/MWController-class.Rd @@ -21,7 +21,7 @@ desire to create automatic tests for applications created with \item{\code{ncol}}{Number of columns.} \item{\code{autoUpdate}}{Boolean indicating if charts should be automatically -updated when a value changes} +updated when a value changes. list with \code{value} and \code{initBtn} (not autoUpdate, if want first charts on init)} }} \section{Methods}{ diff --git a/man/manipulateWidget.Rd b/man/manipulateWidget.Rd index 6c2fefa..0a8a211 100644 --- a/man/manipulateWidget.Rd +++ b/man/manipulateWidget.Rd @@ -5,9 +5,10 @@ \title{Add Controls to Interactive Plots} \usage{ manipulateWidget(.expr, ..., .updateBtn = FALSE, .saveBtn = TRUE, - .viewer = c("pane", "window", "browser"), .compare = NULL, - .compareOpts = compareOptions(), .return = function(widget, envs) { - widget }, .width = NULL, .height = NULL, .runApp = TRUE) + .updateBtnInit = FALSE, .viewer = c("pane", "window", "browser"), + .compare = NULL, .compareOpts = compareOptions(), + .return = function(widget, envs) { widget }, .width = NULL, + .height = NULL, .runApp = TRUE) } \arguments{ \item{.expr}{expression to evaluate that returns an interactive plot of class @@ -28,6 +29,8 @@ 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.} From 87ead97bb62b61f2c0f3d6088f80c406f995f442 Mon Sep 17 00:00:00 2001 From: zawam Date: Thu, 9 Nov 2017 09:08:27 +0100 Subject: [PATCH 091/101] update doc --- man/MWController-class.Rd | 154 +++++----- man/combineWidgets-shiny.Rd | 60 ++-- man/compareOptions.Rd | 106 +++---- man/knit_print.MWController.Rd | 32 +-- man/manipulateWidget-package.Rd | 152 +++++----- man/manipulateWidget.Rd | 490 ++++++++++++++++---------------- man/mwGroup.Rd | 90 +++--- man/mwModule.Rd | 170 +++++------ man/mwSharedValue.Rd | 118 ++++---- man/staticPlot.Rd | 108 +++---- man/summary.MWController.Rd | 32 +-- 11 files changed, 756 insertions(+), 756 deletions(-) diff --git a/man/MWController-class.Rd b/man/MWController-class.Rd index ade349d..a3a60ef 100644 --- a/man/MWController-class.Rd +++ b/man/MWController-class.Rd @@ -1,77 +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) -}) - -} -} - +% 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 17567a6..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/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. -} +% 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/compareOptions.Rd b/man/compareOptions.Rd index 513ecf0..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/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) - ) -} - -} +% 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 index b8d3b9e..56b2410 100644 --- a/man/knit_print.MWController.Rd +++ b/man/knit_print.MWController.Rd @@ -1,16 +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 -} +% 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 0a8a211..1c9baab 100644 --- a/man/manipulateWidget.Rd +++ b/man/manipulateWidget.Rd @@ -1,245 +1,245 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/manipulate_widget.R -\name{manipulateWidget} -\alias{manipulateWidget} -\title{Add Controls to Interactive Plots} -\usage{ -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, .runApp = TRUE) -} -\arguments{ -\item{.expr}{expression to evaluate that returns an interactive plot of class -\code{htmlwidget}. This expression is re-evaluated each time a control is -modified.} - -\item{...}{One or more named control arguments created with functions -\code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control -is the name of the variable the controls modifies in the expression. One -can also create a group of inputs by passing a list of such control -arguments. for instance \code{mygroup = list(txt = mwText(""), nb = -mwNumeric(0))} creates a group of inputs named mygroup with two inputs -named "txt" and "nb".} - -\item{.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.} - -\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.} - -\item{.compare}{Sometimes one wants to compare the same chart but with two -different sets of parameters. This is the purpose of this argument. It can -be a character vector of input names or a named list whose names are the -names of the inputs that should vary between the two charts. Each element -of the list must be a vector or a list of length equal to the number of -charts with the initial values of the corresponding parameter for each -chart. It can also be \code{NULL}. In this case, the parameter is -initialized with the default value for the two charts.} - -\item{.compareOpts}{List of options created \code{\link{compareOptions}}. -These options indicate the number of charts to create and their disposition.} - -\item{.return}{A function that can be used to modify the output of -\code{manipulateWidget}. It must take two parameters: the first one is the -final widget, the second one is a list of environments containing the input -values of each individual widget. The length of this list is one if .compare -is null, two or more if it has been defined.} - -\item{.width}{Width of the UI. Used only on Rmarkdown documents with option -\code{runtime: shiny}.} - -\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. -It should be an object of class \code{htmlWidget}. -} -\description{ -This function permits to add controls to an interactive plot created with -packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order -to change the input data or the parameters of the plot. - -Technically, the function starts a shiny gadget. The R session is bloqued -until the user clicks on "cancel" or "done". If he clicks on "done", then the -the function returns the last displayed plot so the user can modify it and/or -save it. -} -\section{Advanced Usage}{ - -The "normal" use of the function is to provide an expression that always -return an \code{htmlwidget}. In such case, every time the user changes the -value of an input, the current widget is destroyed and a new one is created -and rendered. - -Some packages provide functions to update a widget that has already been -rendered. This is the case for instance for package \code{leaflet} with the -function \code{\link[leaflet]{leafletProxy}}. To use such functions, -\code{manipulateWidget} evaluates the parameter \code{.expr} with four extra -variables: - -\itemize{ - \item{\code{.initial}:}{ - \code{TRUE} if the expression is evaluated for the first time and then - the widget has not been rendered yet, \code{FALSE} if the widget has - already been rendered. - } - \item{\code{.session}:}{ - A shiny session object. - } - \item{\code{.output}:}{ - ID of the output in the shiny interface. - } - \item{\code{.id}:}{ - Id of the chart. It can be used in comparison mode to make further - customization without the need to create additional input controls. - } -} - -You can take a look at the last example to see how to use these two -variables to update a leaflet widget. -} - -\section{Modify the returned widget}{ - - In some specific situations, a developer may want to use - \code{manipulateWidget} in a function that waits the user to click on the - "Done" button and modifies the widget returned by \code{manipulateWidget}. - In such situation, parameter \code{.return} should be used so that - \code{manipulateWidget} is the last function called. Indeed, if other code - is present after, the custom function will act very weird in a Rmarkdown - document with "runtime: shiny". -} - -\examples{ -if (require(dygraphs)) { - - mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) - manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - title = mwText("Fictive time series")) - -} - -# Comparison mode -if (require(dygraphs)) { - - mydata <- data.frame( - year = 2000+1:100, - series1 = rnorm(100), - series2 = rnorm(100), - series3 = rnorm(100) - ) - - manipulateWidget( - dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSelect(c("series1", "series2", "series3")), - title = mwText("Fictive time series"), - .compare = c("title", "series") - ) - - # Setting different initial values for each chart - manipulateWidget( - dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSelect(c("series1", "series2", "series3")), - title = mwText(), - .compare = list( - title = list("First chart", "Second chart"), - series = NULL - ) - ) -} - -# Grouping inputs -if (require(dygraphs)) { - - mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) - manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], - main = title, xlab = xlab, ylab = ylab), - range = mwSlider(2001, 2100, c(2001, 2100)), - "Graphical parameters" = mwGroup( - title = mwText("Fictive time series"), - xlab = mwText("X axis label"), - ylab = mwText("Y axis label") - ) - ) - -} - -# Example of conditional input controls -# -# In this example, we plot a x series against a y series. User can choose to -# use points or lines. If he chooses lines, then an additional input is displayed -# to let him control the width of the lines. -if (require("plotly")) { - - dt <- data.frame ( - x = sort(runif(100)), - y = rnorm(100) - ) - - myPlot <- function(type, lwd) { - if (type == "points") { - plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers") - } else { - plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd)) - } - } - - manipulateWidget( - myPlot(type, lwd), - type = mwSelect(c("points", "lines"), "points"), - lwd = mwSlider(1, 10, 1, .display = type == "lines") - ) - -} - -# Advanced Usage -# -# .expr is evaluated with extra variables .initial, .outputId and .session -# that can be used to update an already rendered widget instead of replacing -# it each time an input value is modified. -# -# Here we generate a UI that permits to change color and size of arbitrary -# points on a map generated with leaflet. - -if (require(leaflet)) { - lon <- rnorm(10, sd = 20) - lat <- rnorm(10, sd = 20) - - myMapFun <- function(radius, color, initial, session, output) { - if (initial) { - # Widget has not been rendered - map <- leaflet() \%>\% addTiles() - } else { - # widget has already been rendered - map <- leafletProxy(output, session) \%>\% clearMarkers() - } - - map \%>\% addCircleMarkers(lon, lat, radius = radius, color = color) - } - - manipulateWidget(myMapFun(radius, color, .initial, .session, .output), - radius = mwSlider(5, 30, 10), - color = mwSelect(c("red", "blue", "green"))) - -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/manipulate_widget.R +\name{manipulateWidget} +\alias{manipulateWidget} +\title{Add Controls to Interactive Plots} +\usage{ +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, .runApp = TRUE) +} +\arguments{ +\item{.expr}{expression to evaluate that returns an interactive plot of class +\code{htmlwidget}. This expression is re-evaluated each time a control is +modified.} + +\item{...}{One or more named control arguments created with functions +\code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control +is the name of the variable the controls modifies in the expression. One +can also create a group of inputs by passing a list of such control +arguments. for instance \code{mygroup = list(txt = mwText(""), nb = +mwNumeric(0))} creates a group of inputs named mygroup with two inputs +named "txt" and "nb".} + +\item{.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.} + +\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.} + +\item{.compare}{Sometimes one wants to compare the same chart but with two +different sets of parameters. This is the purpose of this argument. It can +be a character vector of input names or a named list whose names are the +names of the inputs that should vary between the two charts. Each element +of the list must be a vector or a list of length equal to the number of +charts with the initial values of the corresponding parameter for each +chart. It can also be \code{NULL}. In this case, the parameter is +initialized with the default value for the two charts.} + +\item{.compareOpts}{List of options created \code{\link{compareOptions}}. +These options indicate the number of charts to create and their disposition.} + +\item{.return}{A function that can be used to modify the output of +\code{manipulateWidget}. It must take two parameters: the first one is the +final widget, the second one is a list of environments containing the input +values of each individual widget. The length of this list is one if .compare +is null, two or more if it has been defined.} + +\item{.width}{Width of the UI. Used only on Rmarkdown documents with option +\code{runtime: shiny}.} + +\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. +It should be an object of class \code{htmlWidget}. +} +\description{ +This function permits to add controls to an interactive plot created with +packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order +to change the input data or the parameters of the plot. + +Technically, the function starts a shiny gadget. The R session is bloqued +until the user clicks on "cancel" or "done". If he clicks on "done", then the +the function returns the last displayed plot so the user can modify it and/or +save it. +} +\section{Advanced Usage}{ + +The "normal" use of the function is to provide an expression that always +return an \code{htmlwidget}. In such case, every time the user changes the +value of an input, the current widget is destroyed and a new one is created +and rendered. + +Some packages provide functions to update a widget that has already been +rendered. This is the case for instance for package \code{leaflet} with the +function \code{\link[leaflet]{leafletProxy}}. To use such functions, +\code{manipulateWidget} evaluates the parameter \code{.expr} with four extra +variables: + +\itemize{ + \item{\code{.initial}:}{ + \code{TRUE} if the expression is evaluated for the first time and then + the widget has not been rendered yet, \code{FALSE} if the widget has + already been rendered. + } + \item{\code{.session}:}{ + A shiny session object. + } + \item{\code{.output}:}{ + ID of the output in the shiny interface. + } + \item{\code{.id}:}{ + Id of the chart. It can be used in comparison mode to make further + customization without the need to create additional input controls. + } +} + +You can take a look at the last example to see how to use these two +variables to update a leaflet widget. +} + +\section{Modify the returned widget}{ + + In some specific situations, a developer may want to use + \code{manipulateWidget} in a function that waits the user to click on the + "Done" button and modifies the widget returned by \code{manipulateWidget}. + In such situation, parameter \code{.return} should be used so that + \code{manipulateWidget} is the last function called. Indeed, if other code + is present after, the custom function will act very weird in a Rmarkdown + document with "runtime: shiny". +} + +\examples{ +if (require(dygraphs)) { + + mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) + manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + title = mwText("Fictive time series")) + +} + +# Comparison mode +if (require(dygraphs)) { + + mydata <- data.frame( + year = 2000+1:100, + series1 = rnorm(100), + series2 = rnorm(100), + series3 = rnorm(100) + ) + + manipulateWidget( + dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + series = mwSelect(c("series1", "series2", "series3")), + title = mwText("Fictive time series"), + .compare = c("title", "series") + ) + + # Setting different initial values for each chart + manipulateWidget( + dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + series = mwSelect(c("series1", "series2", "series3")), + title = mwText(), + .compare = list( + title = list("First chart", "Second chart"), + series = NULL + ) + ) +} + +# Grouping inputs +if (require(dygraphs)) { + + mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) + manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], + main = title, xlab = xlab, ylab = ylab), + range = mwSlider(2001, 2100, c(2001, 2100)), + "Graphical parameters" = mwGroup( + title = mwText("Fictive time series"), + xlab = mwText("X axis label"), + ylab = mwText("Y axis label") + ) + ) + +} + +# Example of conditional input controls +# +# In this example, we plot a x series against a y series. User can choose to +# use points or lines. If he chooses lines, then an additional input is displayed +# to let him control the width of the lines. +if (require("plotly")) { + + dt <- data.frame ( + x = sort(runif(100)), + y = rnorm(100) + ) + + myPlot <- function(type, lwd) { + if (type == "points") { + plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers") + } else { + plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd)) + } + } + + manipulateWidget( + myPlot(type, lwd), + type = mwSelect(c("points", "lines"), "points"), + lwd = mwSlider(1, 10, 1, .display = type == "lines") + ) + +} + +# Advanced Usage +# +# .expr is evaluated with extra variables .initial, .outputId and .session +# that can be used to update an already rendered widget instead of replacing +# it each time an input value is modified. +# +# Here we generate a UI that permits to change color and size of arbitrary +# points on a map generated with leaflet. + +if (require(leaflet)) { + lon <- rnorm(10, sd = 20) + lat <- rnorm(10, sd = 20) + + myMapFun <- function(radius, color, initial, session, output) { + if (initial) { + # Widget has not been rendered + map <- leaflet() \%>\% addTiles() + } else { + # widget has already been rendered + map <- leafletProxy(output, session) \%>\% clearMarkers() + } + + map \%>\% addCircleMarkers(lon, lat, radius = radius, color = color) + } + + manipulateWidget(myMapFun(radius, color, .initial, .session, .output), + radius = mwSlider(5, 30, 10), + color = mwSelect(c("red", "blue", "green"))) + +} + +} diff --git a/man/mwGroup.Rd b/man/mwGroup.Rd index de27d13..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/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}} -} +% 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 index 5238eff..0b2206e 100644 --- a/man/mwModule.Rd +++ b/man/mwModule.Rd @@ -1,85 +1,85 @@ -% 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) -} -\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.} -} -\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) - - -} - -} +% 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) +} +\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.} +} +\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/mwSharedValue.Rd b/man/mwSharedValue.Rd index e41dfd9..0d1dc47 100644 --- a/man/mwSharedValue.Rd +++ b/man/mwSharedValue.Rd @@ -1,59 +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}} -} +% 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/staticPlot.Rd b/man/staticPlot.Rd index 338fa58..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/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) - ) -} - -} +% 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 index fee0b5d..f11cf5b 100644 --- a/man/summary.MWController.Rd +++ b/man/summary.MWController.Rd @@ -1,16 +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 -} +% 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 +} From ebb83a29c94c85e3eddee693b8bb90ccb199be54 Mon Sep 17 00:00:00 2001 From: zawam Date: Thu, 9 Nov 2017 09:17:00 +0100 Subject: [PATCH 092/101] build vignette when building package --- manipulateWidget.Rproj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 0bc7e30efd1747a0e54ad7437c9e7b6ff84877a2 Mon Sep 17 00:00:00 2001 From: zawam Date: Tue, 14 Nov 2017 15:58:27 +0100 Subject: [PATCH 093/101] update doc --- man/MWController-class.Rd | 154 +++++----- man/combineWidgets-shiny.Rd | 60 ++-- man/compareOptions.Rd | 106 +++---- man/knit_print.MWController.Rd | 32 +-- man/manipulateWidget-package.Rd | 152 +++++----- man/manipulateWidget.Rd | 490 ++++++++++++++++---------------- man/mwGroup.Rd | 90 +++--- man/mwModule.Rd | 170 +++++------ man/mwSharedValue.Rd | 118 ++++---- man/staticPlot.Rd | 108 +++---- man/summary.MWController.Rd | 32 +-- 11 files changed, 756 insertions(+), 756 deletions(-) diff --git a/man/MWController-class.Rd b/man/MWController-class.Rd index ade349d..a3a60ef 100644 --- a/man/MWController-class.Rd +++ b/man/MWController-class.Rd @@ -1,77 +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) -}) - -} -} - +% 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 17567a6..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/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. -} +% 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/compareOptions.Rd b/man/compareOptions.Rd index 513ecf0..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/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) - ) -} - -} +% 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 index b8d3b9e..56b2410 100644 --- a/man/knit_print.MWController.Rd +++ b/man/knit_print.MWController.Rd @@ -1,16 +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 -} +% 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 0a8a211..1c9baab 100644 --- a/man/manipulateWidget.Rd +++ b/man/manipulateWidget.Rd @@ -1,245 +1,245 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/manipulate_widget.R -\name{manipulateWidget} -\alias{manipulateWidget} -\title{Add Controls to Interactive Plots} -\usage{ -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, .runApp = TRUE) -} -\arguments{ -\item{.expr}{expression to evaluate that returns an interactive plot of class -\code{htmlwidget}. This expression is re-evaluated each time a control is -modified.} - -\item{...}{One or more named control arguments created with functions -\code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control -is the name of the variable the controls modifies in the expression. One -can also create a group of inputs by passing a list of such control -arguments. for instance \code{mygroup = list(txt = mwText(""), nb = -mwNumeric(0))} creates a group of inputs named mygroup with two inputs -named "txt" and "nb".} - -\item{.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.} - -\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.} - -\item{.compare}{Sometimes one wants to compare the same chart but with two -different sets of parameters. This is the purpose of this argument. It can -be a character vector of input names or a named list whose names are the -names of the inputs that should vary between the two charts. Each element -of the list must be a vector or a list of length equal to the number of -charts with the initial values of the corresponding parameter for each -chart. It can also be \code{NULL}. In this case, the parameter is -initialized with the default value for the two charts.} - -\item{.compareOpts}{List of options created \code{\link{compareOptions}}. -These options indicate the number of charts to create and their disposition.} - -\item{.return}{A function that can be used to modify the output of -\code{manipulateWidget}. It must take two parameters: the first one is the -final widget, the second one is a list of environments containing the input -values of each individual widget. The length of this list is one if .compare -is null, two or more if it has been defined.} - -\item{.width}{Width of the UI. Used only on Rmarkdown documents with option -\code{runtime: shiny}.} - -\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. -It should be an object of class \code{htmlWidget}. -} -\description{ -This function permits to add controls to an interactive plot created with -packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order -to change the input data or the parameters of the plot. - -Technically, the function starts a shiny gadget. The R session is bloqued -until the user clicks on "cancel" or "done". If he clicks on "done", then the -the function returns the last displayed plot so the user can modify it and/or -save it. -} -\section{Advanced Usage}{ - -The "normal" use of the function is to provide an expression that always -return an \code{htmlwidget}. In such case, every time the user changes the -value of an input, the current widget is destroyed and a new one is created -and rendered. - -Some packages provide functions to update a widget that has already been -rendered. This is the case for instance for package \code{leaflet} with the -function \code{\link[leaflet]{leafletProxy}}. To use such functions, -\code{manipulateWidget} evaluates the parameter \code{.expr} with four extra -variables: - -\itemize{ - \item{\code{.initial}:}{ - \code{TRUE} if the expression is evaluated for the first time and then - the widget has not been rendered yet, \code{FALSE} if the widget has - already been rendered. - } - \item{\code{.session}:}{ - A shiny session object. - } - \item{\code{.output}:}{ - ID of the output in the shiny interface. - } - \item{\code{.id}:}{ - Id of the chart. It can be used in comparison mode to make further - customization without the need to create additional input controls. - } -} - -You can take a look at the last example to see how to use these two -variables to update a leaflet widget. -} - -\section{Modify the returned widget}{ - - In some specific situations, a developer may want to use - \code{manipulateWidget} in a function that waits the user to click on the - "Done" button and modifies the widget returned by \code{manipulateWidget}. - In such situation, parameter \code{.return} should be used so that - \code{manipulateWidget} is the last function called. Indeed, if other code - is present after, the custom function will act very weird in a Rmarkdown - document with "runtime: shiny". -} - -\examples{ -if (require(dygraphs)) { - - mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) - manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - title = mwText("Fictive time series")) - -} - -# Comparison mode -if (require(dygraphs)) { - - mydata <- data.frame( - year = 2000+1:100, - series1 = rnorm(100), - series2 = rnorm(100), - series3 = rnorm(100) - ) - - manipulateWidget( - dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSelect(c("series1", "series2", "series3")), - title = mwText("Fictive time series"), - .compare = c("title", "series") - ) - - # Setting different initial values for each chart - manipulateWidget( - dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), - range = mwSlider(2001, 2100, c(2001, 2100)), - series = mwSelect(c("series1", "series2", "series3")), - title = mwText(), - .compare = list( - title = list("First chart", "Second chart"), - series = NULL - ) - ) -} - -# Grouping inputs -if (require(dygraphs)) { - - mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) - manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], - main = title, xlab = xlab, ylab = ylab), - range = mwSlider(2001, 2100, c(2001, 2100)), - "Graphical parameters" = mwGroup( - title = mwText("Fictive time series"), - xlab = mwText("X axis label"), - ylab = mwText("Y axis label") - ) - ) - -} - -# Example of conditional input controls -# -# In this example, we plot a x series against a y series. User can choose to -# use points or lines. If he chooses lines, then an additional input is displayed -# to let him control the width of the lines. -if (require("plotly")) { - - dt <- data.frame ( - x = sort(runif(100)), - y = rnorm(100) - ) - - myPlot <- function(type, lwd) { - if (type == "points") { - plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers") - } else { - plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd)) - } - } - - manipulateWidget( - myPlot(type, lwd), - type = mwSelect(c("points", "lines"), "points"), - lwd = mwSlider(1, 10, 1, .display = type == "lines") - ) - -} - -# Advanced Usage -# -# .expr is evaluated with extra variables .initial, .outputId and .session -# that can be used to update an already rendered widget instead of replacing -# it each time an input value is modified. -# -# Here we generate a UI that permits to change color and size of arbitrary -# points on a map generated with leaflet. - -if (require(leaflet)) { - lon <- rnorm(10, sd = 20) - lat <- rnorm(10, sd = 20) - - myMapFun <- function(radius, color, initial, session, output) { - if (initial) { - # Widget has not been rendered - map <- leaflet() \%>\% addTiles() - } else { - # widget has already been rendered - map <- leafletProxy(output, session) \%>\% clearMarkers() - } - - map \%>\% addCircleMarkers(lon, lat, radius = radius, color = color) - } - - manipulateWidget(myMapFun(radius, color, .initial, .session, .output), - radius = mwSlider(5, 30, 10), - color = mwSelect(c("red", "blue", "green"))) - -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/manipulate_widget.R +\name{manipulateWidget} +\alias{manipulateWidget} +\title{Add Controls to Interactive Plots} +\usage{ +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, .runApp = TRUE) +} +\arguments{ +\item{.expr}{expression to evaluate that returns an interactive plot of class +\code{htmlwidget}. This expression is re-evaluated each time a control is +modified.} + +\item{...}{One or more named control arguments created with functions +\code{\link{mwSlider}}, \code{\link{mwText}}, etc. The name of each control +is the name of the variable the controls modifies in the expression. One +can also create a group of inputs by passing a list of such control +arguments. for instance \code{mygroup = list(txt = mwText(""), nb = +mwNumeric(0))} creates a group of inputs named mygroup with two inputs +named "txt" and "nb".} + +\item{.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.} + +\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.} + +\item{.compare}{Sometimes one wants to compare the same chart but with two +different sets of parameters. This is the purpose of this argument. It can +be a character vector of input names or a named list whose names are the +names of the inputs that should vary between the two charts. Each element +of the list must be a vector or a list of length equal to the number of +charts with the initial values of the corresponding parameter for each +chart. It can also be \code{NULL}. In this case, the parameter is +initialized with the default value for the two charts.} + +\item{.compareOpts}{List of options created \code{\link{compareOptions}}. +These options indicate the number of charts to create and their disposition.} + +\item{.return}{A function that can be used to modify the output of +\code{manipulateWidget}. It must take two parameters: the first one is the +final widget, the second one is a list of environments containing the input +values of each individual widget. The length of this list is one if .compare +is null, two or more if it has been defined.} + +\item{.width}{Width of the UI. Used only on Rmarkdown documents with option +\code{runtime: shiny}.} + +\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. +It should be an object of class \code{htmlWidget}. +} +\description{ +This function permits to add controls to an interactive plot created with +packages like \code{dygraphs}, \code{highcharter} or \code{plotly} in order +to change the input data or the parameters of the plot. + +Technically, the function starts a shiny gadget. The R session is bloqued +until the user clicks on "cancel" or "done". If he clicks on "done", then the +the function returns the last displayed plot so the user can modify it and/or +save it. +} +\section{Advanced Usage}{ + +The "normal" use of the function is to provide an expression that always +return an \code{htmlwidget}. In such case, every time the user changes the +value of an input, the current widget is destroyed and a new one is created +and rendered. + +Some packages provide functions to update a widget that has already been +rendered. This is the case for instance for package \code{leaflet} with the +function \code{\link[leaflet]{leafletProxy}}. To use such functions, +\code{manipulateWidget} evaluates the parameter \code{.expr} with four extra +variables: + +\itemize{ + \item{\code{.initial}:}{ + \code{TRUE} if the expression is evaluated for the first time and then + the widget has not been rendered yet, \code{FALSE} if the widget has + already been rendered. + } + \item{\code{.session}:}{ + A shiny session object. + } + \item{\code{.output}:}{ + ID of the output in the shiny interface. + } + \item{\code{.id}:}{ + Id of the chart. It can be used in comparison mode to make further + customization without the need to create additional input controls. + } +} + +You can take a look at the last example to see how to use these two +variables to update a leaflet widget. +} + +\section{Modify the returned widget}{ + + In some specific situations, a developer may want to use + \code{manipulateWidget} in a function that waits the user to click on the + "Done" button and modifies the widget returned by \code{manipulateWidget}. + In such situation, parameter \code{.return} should be used so that + \code{manipulateWidget} is the last function called. Indeed, if other code + is present after, the custom function will act very weird in a Rmarkdown + document with "runtime: shiny". +} + +\examples{ +if (require(dygraphs)) { + + mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) + manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + title = mwText("Fictive time series")) + +} + +# Comparison mode +if (require(dygraphs)) { + + mydata <- data.frame( + year = 2000+1:100, + series1 = rnorm(100), + series2 = rnorm(100), + series3 = rnorm(100) + ) + + manipulateWidget( + dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + series = mwSelect(c("series1", "series2", "series3")), + title = mwText("Fictive time series"), + .compare = c("title", "series") + ) + + # Setting different initial values for each chart + manipulateWidget( + dygraph(mydata[range[1]:range[2] - 2000, c("year", series)], main = title), + range = mwSlider(2001, 2100, c(2001, 2100)), + series = mwSelect(c("series1", "series2", "series3")), + title = mwText(), + .compare = list( + title = list("First chart", "Second chart"), + series = NULL + ) + ) +} + +# Grouping inputs +if (require(dygraphs)) { + + mydata <- data.frame(year = 2000+1:100, value = rnorm(100)) + manipulateWidget(dygraph(mydata[range[1]:range[2] - 2000, ], + main = title, xlab = xlab, ylab = ylab), + range = mwSlider(2001, 2100, c(2001, 2100)), + "Graphical parameters" = mwGroup( + title = mwText("Fictive time series"), + xlab = mwText("X axis label"), + ylab = mwText("Y axis label") + ) + ) + +} + +# Example of conditional input controls +# +# In this example, we plot a x series against a y series. User can choose to +# use points or lines. If he chooses lines, then an additional input is displayed +# to let him control the width of the lines. +if (require("plotly")) { + + dt <- data.frame ( + x = sort(runif(100)), + y = rnorm(100) + ) + + myPlot <- function(type, lwd) { + if (type == "points") { + plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "markers") + } else { + plot_ly(dt, x= ~x, y = ~y, type = "scatter", mode = "lines", line = list(width = lwd)) + } + } + + manipulateWidget( + myPlot(type, lwd), + type = mwSelect(c("points", "lines"), "points"), + lwd = mwSlider(1, 10, 1, .display = type == "lines") + ) + +} + +# Advanced Usage +# +# .expr is evaluated with extra variables .initial, .outputId and .session +# that can be used to update an already rendered widget instead of replacing +# it each time an input value is modified. +# +# Here we generate a UI that permits to change color and size of arbitrary +# points on a map generated with leaflet. + +if (require(leaflet)) { + lon <- rnorm(10, sd = 20) + lat <- rnorm(10, sd = 20) + + myMapFun <- function(radius, color, initial, session, output) { + if (initial) { + # Widget has not been rendered + map <- leaflet() \%>\% addTiles() + } else { + # widget has already been rendered + map <- leafletProxy(output, session) \%>\% clearMarkers() + } + + map \%>\% addCircleMarkers(lon, lat, radius = radius, color = color) + } + + manipulateWidget(myMapFun(radius, color, .initial, .session, .output), + radius = mwSlider(5, 30, 10), + color = mwSelect(c("red", "blue", "green"))) + +} + +} diff --git a/man/mwGroup.Rd b/man/mwGroup.Rd index de27d13..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/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}} -} +% 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 index 5238eff..0b2206e 100644 --- a/man/mwModule.Rd +++ b/man/mwModule.Rd @@ -1,85 +1,85 @@ -% 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) -} -\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.} -} -\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) - - -} - -} +% 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) +} +\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.} +} +\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/mwSharedValue.Rd b/man/mwSharedValue.Rd index e41dfd9..0d1dc47 100644 --- a/man/mwSharedValue.Rd +++ b/man/mwSharedValue.Rd @@ -1,59 +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}} -} +% 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/staticPlot.Rd b/man/staticPlot.Rd index 338fa58..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/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) - ) -} - -} +% 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 index fee0b5d..f11cf5b 100644 --- a/man/summary.MWController.Rd +++ b/man/summary.MWController.Rd @@ -1,16 +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 -} +% 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 +} From 7b8de339bc34e7492c734088bc48751324ab946a Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 15 Nov 2017 11:09:26 +0100 Subject: [PATCH 094/101] rm saveWidget test --- tests/testthat/test-staticPlot.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-staticPlot.R b/tests/testthat/test-staticPlot.R index 78c501d..efa3661 100644 --- a/tests/testthat/test-staticPlot.R +++ b/tests/testthat/test-staticPlot.R @@ -16,10 +16,10 @@ describe("Static plot & image", { 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)) + # # check saveWidget and so preRenderCombinedWidgets + # tmp_html <- tempfile(fileext = ".html") + # htmlwidgets::saveWidget(c, tmp_html) + # expect_true(file.exists(tmp_html)) }) }) From 00c78510ac1e81d8b0c1d7c61b3d16c685898ee1 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Wed, 15 Nov 2017 11:11:55 +0100 Subject: [PATCH 095/101] update news --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index e1ed964..c92176e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ # 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()`. From 64bc7076a6882cc4bebe3c9252c213d1b513fee8 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Mon, 27 Nov 2017 13:57:48 +0100 Subject: [PATCH 096/101] mwModule() now return controller value, with possibility to use new clear() method --- DESCRIPTION | 4 ++-- NEWS.md | 5 +++++ R/controller.R | 20 +++++++++++++++----- 3 files changed, 22 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4fa62ff..d637de7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: manipulateWidget Type: Package Title: Add Even More Interactivity to Interactive Charts -Version: 0.8.0 -Date: 2017-10-26 +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"), diff --git a/NEWS.md b/NEWS.md index c92176e..60be59e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,10 @@ +# manipulateWidget 0.8.1 (2017-11-27) + +## New features +* `mwModule()` now return `controller` value, with possibility to use new `clear()` method + # manipulateWidget 0.8.0 (2017-10-25) ## New features diff --git a/R/controller.R b/R/controller.R index b1d6917..b2b8ea2 100644 --- a/R/controller.R +++ b/R/controller.R @@ -91,6 +91,10 @@ MWController <- setRefClass( 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 @@ -155,12 +159,15 @@ MWController <- setRefClass( updateChart = function(chartId = 1) { catIfDebug("Update chart", chartId) - 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]]) + 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) } - renderShinyOutput(chartId) + }, returnCharts = function() { @@ -254,6 +261,7 @@ MWController <- setRefClass( getModuleServer = function() { function(input, output, session, ...) { + controller <- .self$clone() reactiveValueList <- list(...) @@ -295,6 +303,8 @@ MWController <- setRefClass( file = con, selfcontained = TRUE) } ) + + return(controller) } } ) From bf53aa562c21c31c6a9f0b4ff9e2b1961b1928d2 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Mon, 27 Nov 2017 13:59:52 +0100 Subject: [PATCH 097/101] typo example --- inst/examples/example-reactive_values.R | 2 +- inst/examples/example-two_mods_one_app.R | 16 ++++++++-------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/inst/examples/example-reactive_values.R b/inst/examples/example-reactive_values.R index 401d718..787f80b 100644 --- a/inst/examples/example-reactive_values.R +++ b/inst/examples/example-reactive_values.R @@ -36,7 +36,7 @@ server <- function(input, output, session) { titre <- reactive({ input$title }) - # + mwModule("ui", c, title = titre, series = reactive(input$series)) } diff --git a/inst/examples/example-two_mods_one_app.R b/inst/examples/example-two_mods_one_app.R index 2aa3029..06bcc6e 100644 --- a/inst/examples/example-two_mods_one_app.R +++ b/inst/examples/example-two_mods_one_app.R @@ -39,14 +39,14 @@ c2 <- manipulateWidget( ui <- navbarPage( "Test manipulateWidget", - tabPanel( - "Module 1", - mwModuleUI("mod1", height = "800px") - ), - tabPanel( - "Module 2", - mwModuleUI("mod2", height = "800px") - ) + tabPanel( + "Module 1", + mwModuleUI("mod1", height = "800px") + ), + tabPanel( + "Module 2", + mwModuleUI("mod2", height = "800px") + ) ) server <- function(input, output, session) { From 950b0141f7341f5aeca3778d2ccb7b0fe596d2e6 Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Mon, 27 Nov 2017 17:31:10 +0100 Subject: [PATCH 098/101] fix bug due to NA Date --- R/inputs.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/inputs.R b/R/inputs.R index c2a64f1..b7fc51d 100644 --- a/R/inputs.R +++ b/R/inputs.R @@ -455,6 +455,7 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ... 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()){ From 180f621c6fd53d7214e5e7100258e0e0709e0eaf Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Mon, 4 Dec 2017 15:29:04 +0100 Subject: [PATCH 099/101] add header and footer arguments to mwModuleUI() --- NEWS.md | 1 + R/module_ui.R | 13 ++++++++++--- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 60be59e..985458d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,7 @@ ## New features * `mwModule()` now return `controller` value, with possibility to use new `clear()` method +* add `header` and `footer` arguments to `mwModuleUI()` # manipulateWidget 0.8.0 (2017-10-25) diff --git a/R/module_ui.R b/R/module_ui.R index a40ed35..1e3b003 100644 --- a/R/module_ui.R +++ b/R/module_ui.R @@ -67,9 +67,12 @@ mwModule <- function(id, controller, ...) { #' units. #' @param width Width of the module UI. #' @param height Height of the module UI. +#' @param header Tag or list of tags to display as a common header above all tabPanels. +#' @param footer Tag or list of tags to display as a common footer below all tabPanels #' @rdname mwModule #' @export -mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin = 0, width = "100%", height = 400) { +mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin = 0, width = "100%", height = 400, + header = NULL, footer = NULL) { ns <- shiny::NS(id) for (i in seq_along(margin)) { margin[i] <- shiny::validateCssUnit(margin[i]) @@ -83,7 +86,9 @@ mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin if(!saveBtn) class <- c(class, "without-save") class <- paste(class, collapse = " ") - res <- shiny::tagList( + 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), @@ -91,7 +96,9 @@ mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin margin), class = class, ...) - }) + }), + footer + ) ) htmldep <- htmltools::htmlDependency( From e62cbf03857038e2fea8f86bab8ad07eac38794e Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Dec 2017 10:57:22 +0100 Subject: [PATCH 100/101] add fluidRow argument to mwModuleUI + fix test --- NEWS.md | 2 +- R/module_ui.R | 52 +++++++++++++++++-------- inst/examples/example-reactive_values.R | 2 +- man/mwModule.Rd | 9 ++++- tests/testthat/test-mwModuleUI.R | 10 ++--- 5 files changed, 51 insertions(+), 24 deletions(-) diff --git a/NEWS.md b/NEWS.md index 985458d..f5114c1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,7 +4,7 @@ ## New features * `mwModule()` now return `controller` value, with possibility to use new `clear()` method -* add `header` and `footer` arguments to `mwModuleUI()` +* add `header`, `footer` and `fluidRow` arguments to `mwModuleUI()` # manipulateWidget 0.8.0 (2017-10-25) diff --git a/R/module_ui.R b/R/module_ui.R index 1e3b003..4def30e 100644 --- a/R/module_ui.R +++ b/R/module_ui.R @@ -69,10 +69,14 @@ mwModule <- function(id, controller, ...) { #' @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) { +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]) @@ -86,20 +90,36 @@ mwModuleUI <- function(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin if(!saveBtn) class <- c(class, "without-save") class <- paste(class, collapse = " ") - 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 - ) - ) + 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", diff --git a/inst/examples/example-reactive_values.R b/inst/examples/example-reactive_values.R index 787f80b..80bf304 100644 --- a/inst/examples/example-reactive_values.R +++ b/inst/examples/example-reactive_values.R @@ -8,7 +8,7 @@ ui <- fillPage( textInput("title", label = "Title", value = "glop"), selectInput("series", "series", choices = c("series1", "series2", "series3")) ), - mwModuleUI("ui", height = "100%") + mwModuleUI("ui", height = "400px") ) ) diff --git a/man/mwModule.Rd b/man/mwModule.Rd index 0b2206e..4bf7a96 100644 --- a/man/mwModule.Rd +++ b/man/mwModule.Rd @@ -8,7 +8,8 @@ mwModule(id, controller, ...) mwModuleUI(id, border = TRUE, okBtn = FALSE, saveBtn = TRUE, margin = 0, - width = "100\%", height = 400) + width = "100\%", height = 400, header = NULL, footer = NULL, + fluidRow = FALSE) } \arguments{ \item{id}{A unique string that identifies the module} @@ -32,6 +33,12 @@ 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 diff --git a/tests/testthat/test-mwModuleUI.R b/tests/testthat/test-mwModuleUI.R index 8f315b1..9357f53 100644 --- a/tests/testthat/test-mwModuleUI.R +++ b/tests/testthat/test-mwModuleUI.R @@ -9,15 +9,15 @@ describe("mwModuleUI function", { # default def_mw_ui <- mwModuleUI(id = "def") expect_is(def_mw_ui, "shiny.tag.list") - expect_equal(def_mw_ui[[1]]$name, "div") - expect_equal(def_mw_ui[[1]]$attribs$id, "def-ui") - expect_true(grepl("border", def_mw_ui[[1]]$attribs$class)) + 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[[1]]$attribs$class)) + 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[[1]]$attribs$style)) + expect_true(grepl("height:100%", def_mw_ui[[2]]$attribs$style)) }) }) From ed9eef0cd129b6856bc758a72afc35639c63122f Mon Sep 17 00:00:00 2001 From: Benoit Thieurmel Date: Tue, 5 Dec 2017 10:57:41 +0100 Subject: [PATCH 101/101] fix valueHasChanged setting input --- R/input_class.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/input_class.R b/R/input_class.R index 76f8faf..75ea9be 100644 --- a/R/input_class.R +++ b/R/input_class.R @@ -147,6 +147,7 @@ Input <- setRefClass( } if (!emptyField(validFunc)) value <<- validFunc(evalValue(newValue, env), getParams()) assign(name, value, envir = env) + valueHasChanged <<- FALSE value },