1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
controlLabel <- function(controlName, label) {
label %AND% tags$label(class = "control-label", `for` = controlName, label)
}
# This function takes in either a list or vector for `choices` (and
# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
# in a list or vector for both `choiceNames` and `choiceValues` (and
# `choices` is passed as NULL) and returns a list of two elements:
# - `choiceNames` is a vector or list that holds the options names
# (each element can be arbitrary UI, or simple text)
# - `choiceValues` is a vector or list that holds the options values
# (each element must be simple text)
normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
mustExist = TRUE) {
# if-else to check that either choices OR (choiceNames + choiceValues)
# were correctly provided
if (is.null(choices)) {
if (is.null(choiceNames) || is.null(choiceValues)) {
if (mustExist) {
stop("Please specify a non-empty vector for `choices` (or, ",
"alternatively, for both `choiceNames` AND `choiceValues`).")
} else {
if (is.null(choiceNames) && is.null(choiceValues)) {
# this is useful when we call this function from `updateInputOptions()`
# in which case, all three `choices`, `choiceNames` and `choiceValues`
# may legitimately be NULL
return(list(choiceNames = NULL, choiceValues = NULL))
} else {
stop("One of `choiceNames` or `choiceValues` was set to ",
"NULL, but either both or none should be NULL.")
}
}
}
if (length(choiceNames) != length(choiceValues)) {
stop("`choiceNames` and `choiceValues` must have the same length.")
}
if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
stop("`choiceNames` and `choiceValues` must not be named.")
}
} else {
if (!is.null(choiceNames) || !is.null(choiceValues)) {
warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
}
choices <- choicesWithNames(choices) # resolve names if not specified
choiceNames <- names(choices)
choiceValues <- unname(choices)
}
return(list(choiceNames = as.list(choiceNames),
choiceValues = as.list(as.character(choiceValues))))
}
# generate options for radio buttons and checkbox groups (type = 'checkbox' or
# 'radio')
generateOptions <- function(inputId, selected, inline, type = 'checkbox',
choiceNames, choiceValues,
session = getDefaultReactiveDomain()) {
# generate a list of <input type=? [checked] />
options <- mapply(
choiceValues, choiceNames,
FUN = function(value, name) {
inputTag <- tags$input(
type = type, name = inputId, value = value
)
if (value %in% selected)
inputTag$attribs$checked <- "checked"
# in case, the options include UI code other than text
# (arbitrary HTML using the tags() function or equivalent)
pd <- processDeps(name, session)
# If inline, there's no wrapper div, and the label needs a class like
# checkbox-inline.
if (inline) {
tags$label(class = paste0(type, "-inline"), inputTag,
tags$span(pd$html, pd$deps))
} else {
tags$div(class = type, tags$label(inputTag,
tags$span(pd$html, pd$deps)))
}
},
SIMPLIFY = FALSE, USE.NAMES = FALSE
)
div(class = "shiny-options-group", options)
}
# Takes a vector or list, and adds names (same as the value) to any entries
# without names. Coerces all leaf nodes to `character`.
choicesWithNames <- function(choices) {
# Take a vector or list, and convert to list. Also, if any children are
# vectors with length > 1, convert those to list. If the list is unnamed,
# convert it to a named list with blank names.
listify <- function(obj) {
# If a list/vector is unnamed, give it blank names
makeNamed <- function(x) {
if (is.null(names(x))) names(x) <- character(length(x))
x
}
res <- lapply(obj, function(val) {
if (is.list(val))
listify(val)
else if (length(val) == 1 && is.null(names(val)))
as.character(val)
else
makeNamed(as.list(val))
})
makeNamed(res)
}
choices <- listify(choices)
if (length(choices) == 0) return(choices)
# Recurse into any subgroups
choices <- mapply(choices, names(choices), FUN = function(choice, name) {
if (!is.list(choice)) return(choice)
if (name == "") stop('All sub-lists in "choices" must be named.')
choicesWithNames(choice)
}, SIMPLIFY = FALSE)
# default missing names to choice values
missing <- names(choices) == ""
names(choices)[missing] <- as.character(choices)[missing]
choices
}
|
