From 00276abfa73bc7b4ef740ca2fccac8cb09dd6dd2 Mon Sep 17 00:00:00 2001 From: Barbara Borges Ribeiro Date: Thu, 29 Dec 2016 16:31:03 +0000 Subject: [PATCH] working but ugly --- R/input-radiobuttons.R | 60 ++++++++++++++++++++++++++++++++++-------- R/input-utils.R | 49 +++++++++++++++++++++++++++++----- 2 files changed, 92 insertions(+), 17 deletions(-) diff --git a/R/input-radiobuttons.R b/R/input-radiobuttons.R index 72407f443..b978953cd 100644 --- a/R/input-radiobuttons.R +++ b/R/input-radiobuttons.R @@ -11,11 +11,15 @@ #' #' @inheritParams textInput #' @param choices List of values to select from (if elements of the list are -#' named then that name rather than the value is displayed to the user) +#' named then that name rather than the value is displayed to the user). If +#' this argument is provided, then \code{choiceNames} and \code{choiceValues} +#' must not be provided, and vice-versa. #' @param selected The initially selected value (if not specified then -#' defaults to the first value) +#' defaults to the first value) #' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally) #' @return A set of radio buttons that can be added to a UI definition. +#' @param choicesValues +#' @param choicesNames List #' #' @family input elements #' @seealso \code{\link{updateRadioButtons}} @@ -49,25 +53,59 @@ #' shinyApp(ui, server) #' } #' @export -radioButtons <- function(inputId, label, choices, selected = NULL, - inline = FALSE, width = NULL) { +radioButtons <- function(inputId, label, choices = NULL, selected = NULL, + inline = FALSE, width = NULL, choicesValues = NULL, choicesNames = NULL) { - # resolve names - choices <- choicesWithNames(choices) + lenNames <- length(choicesNames) + lenVals <- length(choicesValues) + useChoices <- FALSE + + if (is.null(choices)) { + if (lenNames == 0 || lenVals == 0) { + stop("Please specify a non-empty vector for `choices` (or, + alternatively, for both `choicesNames` and `choicesValues`).") + } + if (lenNames != lenVals) { + stop("`choicesNames` and `choicesValues` must have the same length.") + } + if (!is.null(names(choicesNames)) || !is.null(names(choicesValues))) { + stop("`choicesNames` and `choicesValues` must not be named.") + } + } else { + if (lenNames != 0 || lenVals != 0) { + warning("Using `choices` argument; ignoring `choicesNames` and + `choicesValues`.") + } + # resolve names + useChoices <- TRUE + choices <- choicesWithNames(choices) + } selected <- restoreInput(id = inputId, default = selected) # default value if it's not specified - selected <- if (is.null(selected)) choices[[1]] else { - validateSelected(selected, choices, inputId) + selected <- if (is.null(selected)) { + if (useChoices) choices[[1]] else choicesValues[[1]] + } else { + if (useChoices) validateSelected(selected, choices, inputId) + else validateSelected2(selected, choicesNames, choicesValues, inputId) } + if (length(selected) > 1) stop("The 'selected' argument must be of length 1") - options <- generateOptions(inputId, choices, selected, inline, type = 'radio') + #print(choicesNames) + #print(choicesValues) + + options <- if (useChoices) + generateOptions(inputId, choices, selected, inline, type = 'radio') + else + generateOptions(inputId, NULL, selected, inline, type = 'radio', + choicesNames, choicesValues) + + #print(options) divClass <- "form-group shiny-input-radiogroup shiny-input-container" - if (inline) - divClass <- paste(divClass, "shiny-input-container-inline") + if (inline) divClass <- paste(divClass, "shiny-input-container-inline") tags$div(id = inputId, style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"), diff --git a/R/input-utils.R b/R/input-utils.R index 65eb70bd1..81dd8a906 100644 --- a/R/input-utils.R +++ b/R/input-utils.R @@ -35,12 +35,49 @@ validateSelected <- function(selected, choices, inputId) { } +validateSelected2 <- function(selected, choicesValues, choicesNames, inputId) { + selected <- as.character(selected) + if (needOptgroup(choicesValues)) return(selected) + + if (is.list(choicesValues)) choicesValues <- unlist(choicesValues) + if (is.list(choicesNames)) choicesNames <- unlist(choicesNames) + + # labels and values are identical, no need to validate + if (identical(choicesNames, choicesValues)) return(selected) + # when selected labels instead of values + i <- (selected %in% choicesNames) & !(selected %in% choicesValues) + if (any(i)) { + warnFun <- if (all(i)) { + # replace names with values + selected <- choicesValues[[which(choicesNames == selected)]] + warning + } else stop # stop when it is ambiguous (some labels == values) + warnFun("'selected' must be the values instead of names of 'choices' ", + "for the input '", inputId, "'") + } + selected +} + + # generate options for radio buttons and checkbox groups (type = 'checkbox' or # 'radio') -generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox') { +generateOptions <- function(inputId, choices = NULL, selected, inline, + type = 'checkbox', choicesNames = NULL, + choicesValues = NULL) { + + session <- getDefaultReactiveDomain() + + if (is.null(choices)) { + nms <- choicesNames + vals <- choicesValues + } else { + nms <- names(choices) + vals <- choices + } + # generate a list of options <- mapply( - choices, names(choices), + vals, nms, FUN = function(value, name) { inputTag <- tags$input( type = type, name = inputId, value = value @@ -50,12 +87,12 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox # If inline, there's no wrapper div, and the label needs a class like # checkbox-inline. + nm <- processDeps(name, session)$html + if (inline) { - tags$label(class = paste0(type, "-inline"), inputTag, tags$span(name)) + tags$label(class = paste0(type, "-inline"), inputTag, tags$span(nm)) } else { - tags$div(class = type, - tags$label(inputTag, tags$span(name)) - ) + tags$div(class = type, tags$label(inputTag, tags$span(nm))) } }, SIMPLIFY = FALSE, USE.NAMES = FALSE