Simplify API to show/hide controls

DESCRIPTION

@@ -19,6 +19,7 @@ Imports:
     shiny,
     miniUI,
     htmlwidgets,
+    lazyeval,
     knitr,
     methods,
     tools,

R/controls.R

@@ -1,7 +1,7 @@
 #Copyright © 2016 RTE Réseau de transport d’électricité
 
 # Private function used to create input generator functions.
-mwControlFactory <- function(type, inputFunction, params, valueVar = NULL) {
+mwControlFactory <- function(type, inputFunction, params, valueVar = NULL, .display = NULL) {
 
   res <- function(params) {
     if (!is.null(valueVar)) {
@@ -17,6 +17,7 @@ mwControlFactory <- function(type, inputFunction, params, valueVar = NULL) {
 
   attr(res, "params") <- params
   attr(res, "type") <- type
+  attr(res, "display") <- lazyeval::expr_find(.display)
   res
 }
 
@@ -35,6 +36,9 @@ mwControlFactory <- function(type, inputFunction, params, valueVar = NULL) {
 #'   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.
+#' @inheritParams mwSlider
 #'
 #' @return
 #'   A function that will generate the input control.
@@ -62,11 +66,12 @@ mwControlFactory <- function(type, inputFunction, params, valueVar = NULL) {
 #'
 #' @export
 #' @family controls
-mwSlider <- function(min, max, value, label = NULL, ...) {
+mwSlider <- function(min, max, value, label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "slider",
     function(...) {tags$div(style = "padding:0 5px;", shiny::sliderInput(...))},
-    list(min = min, max = max, value = value, label = label, ...)
+    list(min = min, max = max, value = value, label = label, ...),
+    .display = .display
   )
 }
 
@@ -94,10 +99,11 @@ mwSlider <- function(min, max, value, label = NULL, ...) {
 #'
 #' @export
 #' @family controls
-mwText <- function(value = "", label = NULL, ...) {
+mwText <- function(value = "", label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "text", shiny::textInput,
-    list(value = value, label = label, ...)
+    list(value = value, label = label, ...),
+    .display = .display
   )
 }
 
@@ -126,10 +132,11 @@ mwText <- function(value = "", label = NULL, ...) {
 #'
 #' @export
 #' @family controls
-mwNumeric <- function(value, label = NULL, ...) {
+mwNumeric <- function(value, label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "numeric", shiny::numericInput,
-    list(value = value, label = label, ...)
+    list(value = value, label = label, ...),
+    .display = .display
   )
 }
 
@@ -162,10 +169,11 @@ mwNumeric <- function(value, label = NULL, ...) {
 #'
 #' @export
 #' @family controls
-mwPassword <- function(value = "", label = NULL, ...) {
+mwPassword <- function(value = "", label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "password", shiny::passwordInput,
-    list(value = value, label = label, ...)
+    list(value = value, label = label, ...),
+    .display = .display
   )
 }
 
@@ -214,11 +222,13 @@ mwPassword <- function(value = "", label = NULL, ...) {
 #'
 #' @export
 #' @family controls
-mwSelect <- function(choices = value, value = NULL, label = NULL, ..., multiple = FALSE) {
+mwSelect <- function(choices = value, value = NULL, label = NULL, ...,
+                     multiple = FALSE, .display = TRUE) {
   mwControlFactory(
     "select", shiny::selectInput,
     list(choices = choices, value = value, label = label, ..., multiple = multiple),
-    valueVar = "selected"
+    valueVar = "selected",
+    .display = .display
   )
 }
 
@@ -248,10 +258,11 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., multiple
 #'
 #' @export
 #' @family controls
-mwCheckbox <- function(value = FALSE, label = NULL, ...) {
+mwCheckbox <- function(value = FALSE, label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "checkbox", shiny::checkboxInput,
-    list(value = value, label = label, ...)
+    list(value = value, label = label, ...),
+    .display = .display
   )
 }
 
@@ -284,11 +295,12 @@ mwCheckbox <- function(value = FALSE, label = NULL, ...) {
 #'
 #' @export
 #' @family controls
-mwRadio <- function(choices, value = NULL, label = NULL, ...) {
+mwRadio <- function(choices, value = NULL, label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "radio", shiny::radioButtons,
     list(choices = choices, value = value, label = label, ...),
-    valueVar = "selected"
+    valueVar = "selected",
+    .display = .display
   )
 }
 
@@ -316,10 +328,11 @@ mwRadio <- function(choices, value = NULL, label = NULL, ...) {
 #'
 #' @export
 #' @family controls
-mwDate <- function(value = NULL, label = NULL, ...) {
+mwDate <- function(value = NULL, label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "date", shiny::dateInput,
-    list(value = value, label = label, ...)
+    list(value = value, label = label, ...),
+    .display = .display
   )
 }
 
@@ -348,11 +361,13 @@ mwDate <- function(value = NULL, label = NULL, ...) {
 #'
 #' @export
 #' @family controls
-mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...) {
+mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...,
+                        .display = TRUE) {
   mwControlFactory(
     "dateRange", shiny::dateRangeInput,
     list(value = value, label = label, ...),
-    valueVar = c("start", "end")
+    valueVar = c("start", "end"),
+    .display = .display
   )
 }
 
@@ -386,11 +401,12 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...
 #'
 #' @export
 #' @family controls
-mwCheckboxGroup <- function(choices, value = c(), label = NULL, ...) {
+mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .display = TRUE) {
   mwControlFactory(
     "checkboxGroup", shiny::checkboxGroupInput,
     list(choices = choices, value = value, label = label, ...),
-    valueVar = "selected"
+    valueVar = "selected",
+    .display = .display
   )
 }
 

R/controlsUtils.R

@@ -25,6 +25,7 @@ getControlDesc <- function(controls) {
  groupLevel <- c()
  multiple <- c()
  params <- list()
+ display <- list()
 
  getControlDescRecursive <- function(x, name = "", level = 0) {
    if (is.function(x)) {
@@ -43,9 +44,16 @@ getControlDesc <- function(controls) {
        attr(x, "params")$label <- name
      }
      params <<- append(params, list(attr(x, "params")))
+     display <<- append(display, list(attr(x, "display")))
    } else if (length(x) == 0) {
      return()
    } else {
+     if (".display" %in% names(x)) {
+       display <<- append(display, list(x$.display))
+       x$.display <- NULL
+     } else {
+       display <<- append(display, list(NULL))
+     }
      inputNames <<- append(inputNames, name)
      initValues <<- append(initValues, list(NULL))
      types <<- append(types, "group")
@@ -64,6 +72,7 @@ getControlDesc <- function(controls) {
    level = groupLevel,
    multiple = multiple,
    params = I(params),
+   display = I(display),
    stringsAsFactors = FALSE
  )
 

R/manipulateWidget.R

@@ -35,13 +35,7 @@
 #' @param .viewer Controls where the gadget should be displayed. \code{"pane"}
 #'   corresponds to the Rstudio viewer, \code{"window"} to a dialog window, and
 #'   \code{"browser"} to an external web browser.
-#' @param .display A named list of conditions that evaluate to TRUE OR FALSE
-#'   indicating when inputs should be displayed. These conditions are
-#'   reevaluated each time a control it modified. By default, each control is
-#'   displayed, but if the name of a control appears in this list, then the
-#'   associated condition is evaluated. If the result is TRUE then the control
-#'   is visible, else it is hidden.
-#' @param .updateInputs This parameter is similar to `.display` and can be used
+#' @param .updateInputs This parameter can be used
 #'  to dynamically update input controls. It must be a named list where names
 #'  correspond to names of input controls and values are named lists of
 #'  expressions where names correspond to arguments of the input generator
@@ -166,8 +160,7 @@
 #'   manipulateWidget(
 #'     myPlot(type, lwd),
 #'     type = mwSelect(c("points", "lines"), "points"),
-#'     lwd = mwSlider(1, 10, 1),
-#'     .display = list(lwd = type == "lines")
+#'     lwd = mwSlider(1, 10, 1, .display = type == "lines")
 #'   )
 #'
 #' }
@@ -209,7 +202,6 @@ manipulateWidget <- function(.expr, ..., .main = NULL, .updateBtn = FALSE,
                              .controlPos = c("left", "top", "right", "bottom", "tab"),
                              .tabColumns = 2,
                              .viewer = c("pane", "window", "browser"),
-                             .display = NULL,
                              .updateInputs = NULL,
                              .compare = NULL,
                              .compareLayout = c("v", "h")) {
@@ -218,7 +210,6 @@ manipulateWidget <- function(.expr, ..., .main = NULL, .updateBtn = FALSE,
   isRuntimeShiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny")
 
   .expr <- substitute(.expr)
-  .display <- substitute(.display)
   .updateInputs <- substitute(.updateInputs)
   .viewer <- match.arg(.viewer)
   .controlPos <- match.arg(.controlPos)
@@ -280,7 +271,7 @@ manipulateWidget <- function(.expr, ..., .main = NULL, .updateBtn = FALSE,
 
   server <- mwServer(.expr, controls, initWidgets,
                      renderFunction,
-                     .display, .updateInputs,
+                     .updateInputs,
                      .compareLayout,
                      .updateBtn)
 

R/mwServer.R

@@ -15,7 +15,7 @@
 #'
 mwServer <- function(.expr, controls, widgets,
                      renderFunction,
-                     .display, .updateInputs, .compareLayout,
+                     .updateInputs, .compareLayout,
                      .updateBtn) {
 
   function(input, output, session) {
@@ -51,7 +51,7 @@ mwServer <- function(.expr, controls, widgets,
 
       # Update inputs and widget of the module
       observe({
-        showHideControls(.display, desc, session, moduleEnv())
+        showHideControls(desc, session, moduleEnv())
 
         # Skip first evaluation, since widgets have already been rendered with
         # initial parameters

R/mwServer_helpers.R

@@ -7,17 +7,15 @@
 #' @param env module environment
 #'
 #' @noRd
-showHideControls <- function(.display, desc, session, env) {
-  displayBool <- eval(.display, envir = env)
-  if (length(displayBool) > 0) {
-    for (n in names(displayBool)) {
-      inputDesc <- subset(desc, name == n)
-      if (nrow(inputDesc) == 1) {
-        shiny::updateCheckboxInput(
-          session,
-          inputId = paste0(inputDesc$inputId, "_visible"),
-          value = displayBool[[n]])
-      }
+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]]
+      )
     }
   }
 }