Add <optgroup> support to selectInput()/selectizeInput()

R/bootstrap.R

@@ -584,43 +584,25 @@ checkboxGroupInput <- function(inputId, label, choices, selected = NULL, inline
   if (!is.null(selected))
     selected <- validateSelected(selected, choices, inputId)
 
-  # Create tags for each of the options
-  ids <- paste0(inputId, seq_along(choices))
-
-  checkboxes <- mapply(ids, choices, names(choices),
-    SIMPLIFY = FALSE, USE.NAMES = FALSE,
-    FUN = function(id, value, name) {
-      inputTag <- tags$input(type = "checkbox",
-                             name = inputId,
-                             id = id,
-                             value = value)
-
-    if (value %in% selected)
-      inputTag$attribs$checked <- "checked"
-
-    tags$label(class = if (inline) "checkbox inline" else "checkbox",
-               inputTag,
-               tags$span(name))
-    }
-  )
+  options <- generateOptions(inputId, choices, selected, inline)
 
   # return label and select tag
   tags$div(id = inputId,
            class = "control-group shiny-input-checkboxgroup",
            controlLabel(inputId, label),
-           checkboxes)
+           options)
 }
 
 # Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
 # refers to values. Below is a function for backward compatibility.
 validateSelected <- function(selected, choices, inputId) {
   # drop names, otherwise toJSON() keeps them too
   selected <- unname(selected)
-  if (is.list(choices)) {
-    # <optgroup> is not there yet
-    if (any(sapply(choices, length) > 1)) return(selected)
-    choices <- unlist(choices)
-  }
+  # if you are using shiny > 0.10.0, you are supposed to know that `selected`
+  # must be a value instead of a label
+  if (needOptgroup(choices)) return(selected)
+  if (is.list(choices)) choices <- unlist(choices)
+
   nms <- names(choices)
   # labels and values are identical, no need to validate
   if (identical(nms, unname(choices))) return(selected)
@@ -638,6 +620,29 @@ validateSelected <- function(selected, choices, inputId) {
   selected
 }
 
+# generate options for radio buttons and checkbox groups (type = 'checkbox' or
+# 'radio')
+generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox') {
+  # create tags for each of the options
+  ids <- paste0(inputId, seq_along(choices))
+  # generate a list of <input type=? [checked] />
+  mapply(
+    ids, choices, names(choices),
+    FUN = function(id, value, name) {
+      inputTag <- tags$input(
+        type = type, name = inputId, id = id, value = value
+      )
+      if (value %in% selected)
+        inputTag$attribs$checked <- "checked"
+      tags$label(
+        class = paste(type, if (inline) "inline"),
+        inputTag, tags$span(name)
+      )
+    },
+    SIMPLIFY = FALSE, USE.NAMES = FALSE
+  )
+}
+
 #' Create a help text element
 #'
 #' Create help text which can be added to an input form to provide additional
@@ -664,18 +669,26 @@ controlLabel <- function(controlName, label) {
 choicesWithNames <- function(choices) {
   if (is.null(choices)) return(choices)  # ignore NULL
 
+  # if choices is a list with certain child elements of length > 1, recursively
+  # apply choicesWithNames() on its child elements
+  if (needOptgroup(choices)) {
+    nms <- names(choices)
+    if (length(nms) == 0L || any(nms == ""))
+      stop('"choices" must be a named list')
+    return(lapply(choices, choicesWithNames))
+  }
   # get choice names
   choiceNames <- names(choices)
   if (is.null(choiceNames))
     choiceNames <- character(length(choices))
 
   # default missing names to choice values
   missingNames <- choiceNames == ""
+  if (!any(missingNames)) return(choices)
   choiceNames[missingNames] <- paste(choices)[missingNames]
   names(choices) <- choiceNames
 
-  # return choices
-  return (choices)
+  choices
 }
 
 #' Create a select list input control
@@ -715,21 +728,11 @@ selectInput <- function(inputId, label, choices, selected = NULL,
 
   # default value if it's not specified
   if (is.null(selected)) {
-    if (!multiple) selected <- choices[[1]]
+    if (!multiple) selected <- firstChoice(choices)
   } else selected <- validateSelected(selected, choices, inputId)
 
-  # Create tags for each of the options
-  options <- HTML(paste("<option value=\"",
-    htmlEscape(choices),
-    "\"",
-    ifelse(choices %in% selected, " selected", ""),
-    ">",
-    htmlEscape(names(choices)),
-    "</option>",
-    sep = "", collapse = "\n"));
-
   # create select tag and add options
-  selectTag <- tags$select(id = inputId, options)
+  selectTag <- tags$select(id = inputId, HTML(selectOptions(choices, selected)))
   if (multiple)
     selectTag$attribs$multiple <- "multiple"
 
@@ -739,6 +742,40 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   selectizeIt(inputId, res, NULL, width, nonempty = !multiple && !("" %in% choices))
 }
 
+firstChoice <- function(choices) {
+  choice <- choices[[1]]
+  if (is.list(choice)) firstChoice(choice) else choice[1]
+}
+
+# Create tags for each of the options; use <optgroup> if necessary
+selectOptions <- function(choices, selected, labels = names(choices)) {
+  if (length(choices) == 0) return()
+  if (needOptgroup(choices)) {
+    n      <- length(choices)
+    html   <- character(n)
+    labels <- names(choices)
+    for (i in seq_len(n)) {
+      html[i] <- sprintf(
+        '<optgroup label="%s">\n%s\n</optgroup>',
+        htmlEscape(labels[i]),
+        selectOptions(choices[[i]], selected)
+      )
+    }
+    return(paste(html, collapse = '\n'))
+  }
+  paste(sprintf(
+    '<option value="%s"%s>%s</option>',
+    htmlEscape(choices),
+    ifelse(choices %in% selected, ' selected', ''),
+    htmlEscape(labels)
+  ), collapse = '\n')
+}
+
+# need <optgroup> when choices is a list of sub elements that are not scalars
+needOptgroup <- function(choices) {
+  is.list(choices) && any(sapply(choices, function(x) is.list(x) || length(x) > 1))
+}
+
 #' @rdname selectInput
 #' @param ... Arguments passed to \code{selectInput()}.
 #' @param options A list of options. See the documentation of \pkg{selectize.js}
@@ -820,33 +857,14 @@ radioButtons <- function(inputId, label, choices, selected = NULL, inline = FALS
   selected <- if (is.null(selected)) choices[[1]] else {
     validateSelected(selected, choices, inputId)
   }
+  if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
 
-  # Create tags for each of the options
-  ids <- paste0(inputId, seq_along(choices))
-
-  inputTags <- mapply(ids, choices, names(choices),
-    SIMPLIFY = FALSE, USE.NAMES = FALSE,
-    FUN = function(id, value, name) {
-      inputTag <- tags$input(type = "radio",
-                             name = inputId,
-                             id = id,
-                             value = value)
-
-      if (identical(value, selected))
-        inputTag$attribs$checked = "checked"
-
-      # Put the label text in a span
-      tags$label(class = if (inline) "radio inline" else "radio",
-                inputTag,
-                tags$span(name)
-      )
-    }
-  )
+  options <- generateOptions(inputId, choices, selected, inline, type = 'radio')
 
   tags$div(id = inputId,
     class = 'control-group shiny-input-radiogroup',
     label %AND% tags$label(class = "control-label", `for` = inputId, label),
-    inputTags)
+    options)
 }
 
 #' Create a submit button

R/update-input.R

@@ -256,13 +256,32 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
   session$sendInputMessage(inputId, message)
 }
 
+updateInputOptions <- function(
+  session, inputId, label = NULL, choices = NULL, selected = NULL,
+  inline = FALSE, type = 'checkbox', options = NULL, ...
+) {
+
+  choices <- choicesWithNames(choices)
+  if (!is.null(selected))
+    selected <- validateSelected(selected, choices, inputId)
+
+  # if you have not prepared an HTML string for `options` yet
+  if (is.null(options)) {
+    options <- if (length(choices))
+      format(tagList(
+        generateOptions(inputId, choices, selected, inline, type = type)
+      ))
+  }
+
+  message <- dropNulls(list(label = label, options = options, value = selected, ...))
+
+  session$sendInputMessage(inputId, message)
+}
 
 #' Change the value of a checkbox group input on the client
 #'
 #' @template update-input
-#' @param choices A named vector or named list of options. For each item, the
-#'   name will be used as the label, and the value will be used as the value.
-#' @param selected A vector or list of options (values) which will be selected.
+#' @inheritParams checkboxGroupInput
 #'
 #' @seealso \code{\link{checkboxGroupInput}}
 #'
@@ -294,28 +313,17 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #' })
 #' }
 #' @export
-updateCheckboxGroupInput <- function(session, inputId, label = NULL,
-  choices = NULL, selected = NULL) {
-
-  choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
-
-  options <- if (length(choices))
-    columnToRowData(list(value = choices, label = names(choices)))
-
-  message <- dropNulls(list(label = label, options = options, value = selected))
-
-  session$sendInputMessage(inputId, message)
+updateCheckboxGroupInput <- function(
+  session, inputId, label = NULL, choices = NULL, selected = NULL, inline = FALSE
+) {
+  updateInputOptions(session, inputId, label, choices, selected, inline)
 }
 
 
 #' Change the value of a radio input on the client
 #'
 #' @template update-input
-#' @param choices A named vector or named list of options. For each item, the
-#'   name will be used as the label, and the value will be used as the value.
-#' @param selected A vector or list of options (values) which will be selected.
+#' @inheritParams radioButtons
 #'
 #' @seealso \code{\link{radioButtons}}
 #'
@@ -345,15 +353,19 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' })
 #' }
 #' @export
-updateRadioButtons <- updateCheckboxGroupInput
+updateRadioButtons <- function(
+  session, inputId, label = NULL, choices = NULL, selected = NULL, inline = FALSE
+) {
+  # you must select at least one radio button
+  if (is.null(selected) && !is.null(choices)) selected <- choices[[1]]
+  updateInputOptions(session, inputId, label, choices, selected, inline, type = 'radio')
+}
 
 
 #' Change the value of a select input on the client
 #'
 #' @template update-input
-#' @param choices A named vector or named list of options. For each item, the
-#'   name will be used as the label, and the value will be used as the value.
-#' @param selected A vector or list of options (values) which will be selected.
+#' @inheritParams selectInput
 #'
 #' @seealso \code{\link{selectInput}}
 #'
@@ -386,10 +398,19 @@ updateRadioButtons <- updateCheckboxGroupInput
 #' })
 #' }
 #' @export
-updateSelectInput <- updateCheckboxGroupInput
+updateSelectInput <- function(
+  session, inputId, label = NULL, choices = NULL, selected = NULL
+) {
+  updateSelectInput2(session, inputId, label, choices, selected)
+}
+# the reason for constructing this function is to assign a default value to the
+# `options` argument of updateInputOptions(), and we want the evaluation of this
+# argument to be delayed until `choices` has been named and `selected` validated
+updateSelectInput2 <- updateInputOptions
+formals(updateSelectInput2)['options'] <- alist(options = selectOptions(choices, selected))
 
 #' @rdname updateSelectInput
-#' @param options a list of options (see \code{\link{selectizeInput}})
+#' @inheritParams selectizeInput
 #' @param server whether to store \code{choices} on the server side, and load
 #'   the select options dynamically on searching, instead of writing all
 #'   \code{choices} into the page at once (i.e., only use the client-side
@@ -407,7 +428,7 @@ updateSelectizeInput <- function(
       `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
       HTML(toJSON(res$options))
     )
-    session$sendInputMessage(inputId, list(newOptions = as.character(cfg)))
+    session$sendInputMessage(inputId, list(config = as.character(cfg)))
   }
   if (!server) {
     return(updateSelectInput(session, inputId, label, choices, selected))