Skip to content

Commit

Permalink
Important refactoring to prepare solution for #23
Browse files Browse the repository at this point in the history
  • Loading branch information
@FrancoisGuillem
FrancoisGuillem committed Jan 13, 2017
1 parent f583e1a commit 4831405
Show file tree
Hide file tree
Showing 3 changed files with 132 additions and 127 deletions.
151 changes: 60 additions & 91 deletions R/controls.R
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,22 @@
#Copyright © 2016 RTE Réseau de transport d’électricité

mwControlFactory <- function(type, inputFunction, params, postProcessing = I,
valueVar = NULL) {

res <- function(params) {
if (!is.null(valueVar)) {
params[[valueVar]] <- params$value
params$value <- NULL
}
if (is.null(params$label)) params$label <- params$inputId
postProcessing(do.call(inputFunction, params))
}

attr(res, "params") <- params
attr(res, "type") <- type
res
}

#' Add a Slider to a manipulateWidget gadget
#'
#' @param min
Expand Down Expand Up @@ -43,19 +60,11 @@
#' @export
#' @family controls
mwSlider <- function(min, max, value, label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
tags$div(
style = "padding:0 5px;",
sliderInput(id, label, min, max, value, width = width, ...)
)
}

attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "slider"

res
mwControlFactory(
"slider", sliderInput,
list(min = min, max = max, value = value, label = label, ...),
function(x) {tags$div(style = "padding:0 5px;", x)}
)
}

#' Add a text input to a manipulateWidget gadget
Expand Down Expand Up @@ -83,14 +92,10 @@ mwSlider <- function(min, max, value, label = NULL, ...) {
#' @export
#' @family controls
mwText <- function(value = "", label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
textInput(id, label, value, width = width, ...)
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "text"
res
mwControlFactory(
"text", textInput,
list(value = value, label = label, ...)
)
}

#' Add a numeric input to a manipulateWidget gadget
Expand Down Expand Up @@ -119,14 +124,10 @@ mwText <- function(value = "", label = NULL, ...) {
#' @export
#' @family controls
mwNumeric <- function(value, label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
numericInput(id, label, value, width = width, ...)
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "numeric"
res
mwControlFactory(
"numeric", numericInput,
list(value = value, label = label, ...)
)
}

#' Add a password to a manipulateWidget gadget
Expand Down Expand Up @@ -159,14 +160,10 @@ mwNumeric <- function(value, label = NULL, ...) {
#' @export
#' @family controls
mwPassword <- function(value = "", label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
passwordInput(id, label, value, width = width, ...)
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "password"
res
mwControlFactory(
"password", passwordInput,
list(value = value, label = label, ...)
)
}

#' Add a Select list input to a manipulateWidget gadget
Expand Down Expand Up @@ -215,19 +212,11 @@ mwPassword <- function(value = "", label = NULL, ...) {
#' @export
#' @family controls
mwSelect <- function(choices = value, value = NULL, label = NULL, ..., multiple = FALSE) {
res <- function(id, value, label, width, choices) {
if (is.null(label)) label <- id
selectInput(id, label, choices, value, width = width, ..., multiple = multiple)
}
if (is.null(value)) {
value <- if (multiple) character(0) else choices[1]
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "select"
attr(res, "multiple") <- multiple
attr(res, "choices") <- choices
res
mwControlFactory(
"select", selectizeInput,
list(choices = choices, value = value, label = label, ..., multiple = FALSE),
valueVar = "selected"
)
}

#' Add a checkbox to a manipulateWidget gadget
Expand Down Expand Up @@ -257,14 +246,10 @@ mwSelect <- function(choices = value, value = NULL, label = NULL, ..., multiple
#' @export
#' @family controls
mwCheckbox <- function(value = FALSE, label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
checkboxInput(id, label, value, width = width, ...)
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "checkbox"
res
mwControlFactory(
"checkbox", checkboxInput,
list(value = value, label = label, ...)
)
}

#' Add radio buttons to a manipulateWidget gadget
Expand Down Expand Up @@ -297,15 +282,11 @@ mwCheckbox <- function(value = FALSE, label = NULL, ...) {
#' @export
#' @family controls
mwRadio <- function(choices, value = NULL, label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
radioButtons(id, label, choices, value, width = width, ...)
}
if (is.null(value)) value <- choices[1]
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "radio"
res
mwControlFactory(
"radio", radioButtons,
list(choices = choices, value = value, label = label, ...),
valueVar = "selected"
)
}

#' Add a date picker to a manipulateWidget gadget
Expand Down Expand Up @@ -333,14 +314,10 @@ mwRadio <- function(choices, value = NULL, label = NULL, ...) {
#' @export
#' @family controls
mwDate <- function(value = NULL, label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
dateInput(id, label, value, width = width, ...)
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "date"
res
mwControlFactory(
"date", dateInput,
list(value = value, label = label, ...)
)
}

#' Add a date range picker to a manipulateWidget gadget
Expand Down Expand Up @@ -369,14 +346,10 @@ mwDate <- function(value = NULL, label = NULL, ...) {
#' @export
#' @family controls
mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...) {
res <- function(id, value, label, width) {
if (is.null(label)) label <- id
dateRangeInput(id, label, start = value[1], end = value[2], width = width, ...)
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "dateRange"
res
mwControlFactory(
"dateRange", dateRangeInput,
list(value = value, label = label, ...)
)
}

#' Add a group of checkboxes to a manipulateWidget gadget
Expand Down Expand Up @@ -410,13 +383,9 @@ mwDateRange <- function(value = c(Sys.Date(), Sys.Date() + 1), label = NULL, ...
#' @export
#' @family controls
mwCheckboxGroup <- function(choices, value = c(), label = NULL, ...) {
res <-function(id, value, label, width) {
if (is.null(label)) label <- id
checkboxGroupInput(id, label, choices, value, width = width, ...)
}
attr(res, "value") <- value
attr(res, "label") <- label
attr(res, "type") <- "checkboxGroup"
res
mwControlFactory(
"checkboxGroup", checkboxGroupInput,
list(choices = choices, value = value, label = label, ...)
)
}

91 changes: 67 additions & 24 deletions R/controlsUtils.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,14 +19,14 @@ getControlDesc <- function(controls) {

getControlDescRecursive <- function(x, name = "", level = 0) {
if (is.function(x)) {
value <- list(attr(x, "value"))
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, "multiple"))) NA else attr(x, "multiple")
m <- if (is.null(attr(x, "params")$multiple)) NA else attr(x, "params")$multiple
multiple <<- append(multiple, m)
choices <<- append(choices, list(attr(x, "choices")))
choices <<- append(choices, list(attr(x, "params")$choices))
} else if (length(x) == 0) {
return()
} else mapply(getControlDescRecursive, x=x, name = names(x), level = level + 1)
Expand Down Expand Up @@ -75,8 +75,10 @@ addSuffixToControls <- function(controls, suffix) {
if (is.list(x[[n]])) {
x[[n]] <- addSuffixToControlsRecursive(x[[n]])
}
if (is.null(attr(x[[n]], "label"))) {
attr(x[[n]], "label") <- 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)
Expand All @@ -85,39 +87,80 @@ addSuffixToControls <- function(controls, suffix) {
addSuffixToControlsRecursive(controls)
}

initValue <- function(x) {
if (!is.null(attr(x, "params")$value) & initValueIsValid(x)) {
return(x)
}

type <- attr(x, "type")
params <- attr(x, "params")
multiple <- params$multiple

if (type == "radio" || (type == "select" && !multiple)) {
attr(x, "params")$value <- attr(x, "params")$choices[1]
return(x)
}

if (type == "checkboxGroup" || (type == "select" && multiple)) {
attr(x, "params")$value <- intersect(params$value, params$choices)
return(x)
}

if (type == "slider") {
attr(x, "params")$value <- params$min
return(newValue)
}

stop("Can not find initial value")
}

initValueIsValid <- function(x) {
type <- attr(x, "type")
params <- attr(x, "params")

if (type %in% c("radio", "select", "checkboxGroup")) {
return(all(params$value %in% params$choices))
}

if (type == "slider") {
return(all(params$value >= params$min & params$value <= params$min) )
}

TRUE
}

# Private function that resets the initial values of some controls
resetInitValues <- function(controls, values, choices = NULL) {
resetInitValues <- function(controls, values, newParams = NULL) {
if (length(controls) == 0) return(controls)
resetInitValuesRecursive <- function(x) {
for (n in names(x)) {
if (is.list(x[[n]])) {
x[[n]] <- resetInitValuesRecursive(x[[n]])
} else {
if (n %in% names(values) && ! is.null(values[[n]])) {
attr(x[[n]], "value") <- values[[n]]
}
if (n %in% names(choices) && !is.null(choices[[n]])) {
attr(x[[n]], "choices") <- choices[[n]]
if (attr(x[[n]], "multiple")) {
attr(x[[n]], "value") <- intersect(attr(x[[n]], "value"), choices[[n]])
} else {
if (is.null(attr(x[[n]], "value")) || ! attr(x[[n]], "value") %in% choices[[n]]) {
attr(x[[n]], "value") <- choices[[n]][[1]]
}
# Update parameters if necessary
if (n %in% names(newParams)) {
for (p in names(newParams[[n]])) {
attr(x[[n]], "params")[[p]] <- newParams[[n]][[p]]
}
}
# Update value if necessary
if (n %in% names(values)) {
attr(x[[n]], "params")$value <- values[[n]]
}
# Check init value and reset it if necessary
x[[n]] <- initValue(x[[n]])
}
}
return(x)
}
resetInitValuesRecursive(controls)
}

# Private function that returns a list woth three elements:
# Private function that returns a list with three elements:
# - common: list of common controls
# - ind: list of individual controls for the first chart to compare
# - ind2: list of individual controls for the seconde chart to compare
comparisonControls <- function(controls, compare, choices = NULL) {
comparisonControls <- function(controls, compare, updateInputs = NULL) {
common <- filterControls(controls, names(compare), drop = TRUE)
ind <- filterControls(controls, names(compare))
ind2 <- ind
Expand All @@ -127,12 +170,12 @@ comparisonControls <- function(controls, compare, choices = NULL) {
initValues2 <- lapply(compare, function(x) {if(is.null(x)) x else x[[2]]})

# Reset initial values of input controls
choices1 <- eval(choices, list2env(initValues1, parent = parent.frame()))
choices2 <- eval(choices, list2env(initValues2, parent = parent.frame()))
newParams1 <- eval(updateInputs, list2env(initValues1, parent = parent.frame()))
newParams2 <- eval(updateInputs, list2env(initValues2, parent = parent.frame()))

ind <- resetInitValues(ind, initValues1, choices1)
ind2 <- resetInitValues(ind2, initValues2, choices2)
common <- resetInitValues(common, NULL, choices1)
ind <- resetInitValues(ind, initValues1, newParams1)
ind2 <- resetInitValues(ind2, initValues2, newParams2)
common <- resetInitValues(common, NULL, newParams1)
# Add a "2" at the end of the names of the inputs of the second chart
ind2 <- addSuffixToControls(ind2, "2")

Expand Down
Loading

0 comments on commit 4831405

Please sign in to comment.