New function mwGroup to create conditional group of inputs (#33)

NAMESPACE

@@ -8,6 +8,7 @@ export(mwCheckboxGroup)
 export(mwControlsUI)
 export(mwDate)
 export(mwDateRange)
+export(mwGroup)
 export(mwNumeric)
 export(mwPassword)
 export(mwRadio)

R/controls.R

@@ -63,7 +63,6 @@ prepareParams <- function(value, label, ...) {
 #'   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.
@@ -435,3 +434,36 @@ mwCheckboxGroup <- function(choices, value = c(), label = NULL, ..., .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
+}

R/controlsUtils.R

@@ -48,12 +48,7 @@ getControlDesc <- function(controls) {
    } 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))
-     }
+     display <<- append(display, list(attr(x, "display")))
      inputNames <<- append(inputNames, name)
      initValues <<- append(initValues, list(NULL))
      types <<- append(types, "group")
@@ -76,7 +71,6 @@ getControlDesc <- function(controls) {
    stringsAsFactors = FALSE
  )
 
- res <- res[res$type != "group",]
  res
 }
 

R/mwControlsUI.R

@@ -32,7 +32,7 @@ mwControlsUI <- function(controlList, .dir = c("v", "h"), .n = 1, .updateBtn = F
         ctrls <- mwControlsUI(f)
         label <- attr(f, "params")$label
         if (is.null(label)) label <- id
-        id <- gsub(" ", "-", id)
+        id <- gsub("[^a-zA-Z0-9]", "_", id)
         res <- tags$div(
           class="panel panel-default",
           tags$div(
@@ -67,6 +67,7 @@ mwControlsUI <- function(controlList, .dir = c("v", "h"), .n = 1, .updateBtn = F
   )
 
   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"

R/mwServer.R

@@ -41,8 +41,8 @@ mwServer <- function(.expr, controls, widgets,
         input$.update
 
         for (j in seq_len(nrow(desc))) {
-          if (.updateBtn) v <- eval(parse(text = sprintf("isolate(input$%s)", desc$inputId[j])))
-          else v <- eval(parse(text = sprintf("input$%s", desc$inputId[j])))
+          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]]

R/preprocessControls.R

@@ -75,7 +75,7 @@ preprocessControls <- function(controls, compare = NULL, update = NULL, env) {
   # controls description #######################################################
 
   controlsDesc <- getControlDesc(controls)
-  controlsDesc$inputId <- controlsDesc$name
+  controlsDesc$inputId <- gsub("[^a-zA-Z0-9]", "_", controlsDesc$name)
   controlsDesc$mod <- 0
 
   controlsDescShared <- subset(controlsDesc, !name %in% names(compare))
@@ -124,12 +124,13 @@ preprocessControls <- function(controls, compare = NULL, update = NULL, env) {
   # 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 in the '.updateInputs' parameter ?")
+    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]])
     }

tests/testthat/test-mwServer.R

@@ -53,11 +53,11 @@ describe("updateControls", {
         assign("x2", 1L, envir = env)
         expect_output(desc <<- updateControls(desc, NULL, env),
                       "update numeric")
-        expect_equal(desc$currentParams[[1]]$min, 1)
+        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[[1]]$min, 1)
+        expect_equal(desc$currentParams[[2]]$min, 1)
       })
     }
   )