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