mirror of
https://github.com/rstudio/shiny.git
synced 2026-02-05 12:15:14 -05:00
106 lines
3.3 KiB
R
106 lines
3.3 KiB
R
controlLabel <- function(controlName, label) {
|
|
label %AND% tags$label(class = "control-label", `for` = controlName, label)
|
|
}
|
|
|
|
|
|
# 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 you are using optgroups, you're using shiny > 0.10.0, and you should
|
|
# already 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)
|
|
# when selected labels instead of values
|
|
i <- (selected %in% nms) & !(selected %in% choices)
|
|
if (any(i)) {
|
|
warnFun <- if (all(i)) {
|
|
# replace names with values
|
|
selected <- unname(choices[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') {
|
|
# generate a list of <input type=? [checked] />
|
|
options <- mapply(
|
|
choices, names(choices),
|
|
FUN = function(value, name) {
|
|
inputTag <- tags$input(
|
|
type = type, name = inputId, value = value
|
|
)
|
|
if (value %in% selected)
|
|
inputTag$attribs$checked <- "checked"
|
|
|
|
# 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(name))
|
|
} else {
|
|
tags$div(class = type,
|
|
tags$label(inputTag, tags$span(name))
|
|
)
|
|
}
|
|
},
|
|
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.
|
|
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)))
|
|
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
|
|
}
|