Compare group of inputs (#39)

R/controlsUtils.R

@@ -23,17 +23,21 @@ getControlDesc <- function(controls) {
  initValues <- list()
  types <- c()
  groupLevel <- c()
+ group <- c()
  multiple <- c()
  params <- list()
  display <- list()
 
- getControlDescRecursive <- function(x, name = "", level = 0) {
+ 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)
-     inputNames <<- append(inputNames, name)
      initValues <<- append(initValues, value)
      types <<- append(types, attr(x, "type"))
-     groupLevel <<- append(groupLevel, level)
      m <- if (is.null(attr(x, "params")$multiple)) NA else eval(attr(x, "params")$multiple)
      multiple <<- append(multiple, m)
 
@@ -44,18 +48,14 @@ 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 {
-     display <<- append(display, list(attr(x, "display")))
-     inputNames <<- append(inputNames, name)
      initValues <<- append(initValues, list(NULL))
      types <<- append(types, "group")
-     groupLevel <<- append(groupLevel, level)
      multiple <<- append(multiple, NA)
      params <<- append(params, list(NULL))
-     mapply(getControlDescRecursive, x=x, name = names(x), level = level + 1)
+     mapply(getControlDescRecursive, x=x, name = names(x), parent = name, level = level + 1)
    }
  }
  getControlDescRecursive(controls, ".root")
@@ -65,6 +65,7 @@ getControlDesc <- function(controls) {
    initValue = I(initValues),
    type = types,
    level = groupLevel,
+   group = group,
    multiple = multiple,
    params = I(params),
    display = I(display),

R/manipulateWidget.R

@@ -225,18 +225,12 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE,
   .expr <- substitute(.expr)
   .viewer <- match.arg(.viewer)
   .env <- parent.frame()
-  compareMode <-
   .compareOpts <- do.call(compareOptions, .compareOpts)
 
   if (is.null(.compare)) {
       .compareOpts$ncharts <- 1
   } else {
     if (is.character(.compare)) {
-      .compare <- match.arg(
-        .compare,
-        names(list(...)),
-        several.ok = TRUE
-      )
       .compare <- sapply(.compare, function(x) NULL,
                          simplify = FALSE, USE.NAMES = TRUE)
     }
@@ -254,8 +248,6 @@ manipulateWidget <- function(.expr, ..., .updateBtn = FALSE,
     eval(.expr, envir = e)
   })
 
-  controlDesc <- getControlDesc(controls[c("common", "ind")])
-
   # Get shiny output and render functions
   if (is(initWidgets[[1]], "htmlwidget")) {
     cl <- class(initWidgets[[1]])[1]

R/preprocessControls.R

@@ -70,6 +70,18 @@ preprocessControls <- function(controls, compare = NULL, env, ncharts) {
   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))) {

tests/testthat/test-preprocessControls.R

@@ -104,6 +104,22 @@ describe("preprocessControls", {
         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", {