1shinyInputLabel <- function(inputId, label = NULL) {
2  tags$label(
3    label,
4    class = "control-label",
5    class = if (is.null(label)) "shiny-label-null",
6    # `id` attribute is required for `aria-labelledby` used by screen readers:
7    id = paste0(inputId, "-label"),
8    `for` = inputId
9  )
10}
11
12# This function takes in either a list or vector for `choices` (and
13# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
14# in a list or vector for both `choiceNames` and `choiceValues` (and
15# `choices` is passed as NULL) and returns a list of two elements:
16#    - `choiceNames` is a vector or list that holds the options names
17#      (each element can be arbitrary UI, or simple text)
18#    - `choiceValues` is a vector or list that holds the options values
19#       (each element must be simple text)
20normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
21  mustExist = TRUE) {
22  # if-else to check that either choices OR (choiceNames + choiceValues)
23  # were correctly provided
24  if (is.null(choices)) {
25    if (is.null(choiceNames) || is.null(choiceValues)) {
26      if (mustExist) {
27        stop("Please specify a non-empty vector for `choices` (or, ",
28             "alternatively, for both `choiceNames` AND `choiceValues`).")
29      } else {
30        if (is.null(choiceNames) && is.null(choiceValues)) {
31          # this is useful when we call this function from `updateInputOptions()`
32          # in which case, all three `choices`, `choiceNames` and `choiceValues`
33          # may legitimately be NULL
34          return(list(choiceNames = NULL, choiceValues = NULL))
35        } else {
36          stop("One of `choiceNames` or `choiceValues` was set to ",
37               "NULL, but either both or none should be NULL.")
38        }
39      }
40    }
41    if (length(choiceNames) != length(choiceValues)) {
42      stop("`choiceNames` and `choiceValues` must have the same length.")
43    }
44    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
45      stop("`choiceNames` and `choiceValues` must not be named.")
46    }
47  } else {
48    if (!is.null(choiceNames) || !is.null(choiceValues)) {
49      warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
50    }
51    choices <- choicesWithNames(choices) # resolve names if not specified
52    choiceNames <- names(choices)
53    choiceValues <- unname(choices)
54  }
55
56  return(list(choiceNames = as.list(choiceNames),
57              choiceValues = as.list(as.character(choiceValues))))
58}
59
60# generate options for radio buttons and checkbox groups (type = 'checkbox' or
61# 'radio')
62generateOptions <- function(inputId, selected, inline, type = 'checkbox',
63                            choiceNames, choiceValues,
64                            session = getDefaultReactiveDomain()) {
65  # generate a list of <input type=? [checked] />
66  options <- mapply(
67    choiceValues, choiceNames,
68    FUN = function(value, name) {
69      inputTag <- tags$input(
70        type = type, name = inputId, value = value
71      )
72      if (value %in% selected)
73        inputTag$attribs$checked <- "checked"
74
75      # in case, the options include UI code other than text
76      # (arbitrary HTML using the tags() function or equivalent)
77      pd <- processDeps(name, session)
78
79      # If inline, there's no wrapper div, and the label needs a class like
80      # checkbox-inline.
81      if (inline) {
82        tags$label(class = paste0(type, "-inline"), inputTag,
83                   tags$span(pd$html, pd$deps))
84      } else {
85        tags$div(class = type, tags$label(inputTag,
86                 tags$span(pd$html, pd$deps)))
87      }
88    },
89    SIMPLIFY = FALSE, USE.NAMES = FALSE
90  )
91
92  div(class = "shiny-options-group", options)
93}
94
95# True when a choice list item represents a group of related inputs.
96isGroup <- function(choice) {
97  is.list(choice) ||
98    !is.null(names(choice)) ||
99    length(choice) > 1 ||
100    length(choice) == 0
101}
102
103# True when choices is a list and contains at least one group of related inputs.
104hasGroups <- function(choices) {
105  is.list(choices) && any(vapply(choices, isGroup, logical(1)))
106}
107
108# Assigns empty names to x if it's unnamed, and then fills any empty names with
109# the corresponding value coerced to a character(1).
110setDefaultNames <- function(x) {
111  x <- asNamed(x)
112  emptyNames <- names(x) == ""
113  names(x)[emptyNames] <- as.character(x)[emptyNames]
114  x
115}
116
117# Makes a character vector out of x in a way that preserves names.
118asCharacter <- function(x) {
119  stats::setNames(as.character(x), names(x))
120}
121
122# Processes a "flat" set of choices, or a collection of choices not containing
123# any named groups. choices should be a list without any list children, or an
124# atomic vector. choices may be named or unnamed. Any empty names are replaced
125# with the corresponding value coerced to a character.
126processFlatChoices <- function(choices) {
127  choices <- setDefaultNames(asCharacter(choices))
128  as.list(choices)
129}
130
131# Processes a "nested" set of choices, or a collection of choices that contains
132# one or more named groups of related choices and zero or more "flat" choices.
133# choices should be a named list, and any choice group must have a non-empty
134# name. Empty names of remaining "flat" choices are replaced with that choice's
135# value coerced to a character.
136processGroupedChoices <- function(choices) {
137  # We assert choices is a list, since only a list may contain a group.
138  stopifnot(is.list(choices))
139  # The list might be unnamed by this point. We add default names of "" so that
140  # names(choices) is not zero-length and mapply can work. Within mapply, we
141  # error if any group's name is ""
142  choices <- asNamed(choices)
143  choices <- mapply(function(name, choice) {
144    choiceIsGroup <- isGroup(choice)
145    if (choiceIsGroup && name == "") {
146      # If the choice is a group, and if its name is empty, produce an error. We
147      # error here because the composite nature of the choice prevents us from
148      # meaningfully automatically naming it. Note that while not documented,
149      # groups are not necessarily lists (aka generic vectors) but can also be
150      # any named atomic vector, or any atomic vector of length > 1.
151      stop('All sub-lists in "choices" must be named.')
152    } else if (choiceIsGroup) {
153      # The choice is a group, but it is named. Process it using the same
154      # function we use for "top level" choices.
155      processFlatChoices(choice)
156    } else {
157      # The choice was not named and is not a group; it is a "leaf".
158      as.character(choice)
159    }
160  }, names(choices), choices, SIMPLIFY = FALSE)
161  # By this point, any leaves in the choices list might still have empty names,
162  # so we're sure to automatically name them.
163  setDefaultNames(choices)
164}
165
166# Takes a vector/list/factor, and adds names (same as the value) to any entries
167# without names. Coerces all leaf nodes to `character`.
168choicesWithNames <- function(choices) {
169  if (hasGroups(choices)) {
170    processGroupedChoices(choices)
171  } else {
172    processFlatChoices(choices)
173  }
174}
175