can now pass value as expr (and can depend of sharedValue or current …

…variable) + fix dateRange control
rte-antares-rpackage · Sep 5, 2017 · fc5740c · fc5740c
1 parent abbb1f4
commit fc5740c
Show file tree

Hide file tree

Showing 4 changed files with 144 additions and 14 deletions.
diff --git 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
@@ -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
@@ -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,17 +445,28 @@ 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),
     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)
-
+      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
@@ -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")
     })