#' Create dropdown Semantic UI component
#'
#' This creates a default *dropdown_input* using Semantic UI styles with Shiny input.
#' Dropdown is already initialized and available under input[[input_id]].
#'
#' @param input_id Input name. Reactive value is available under input[[input_id]].
#' @param choices All available options one can select from.
#' @param choices_value What reactive value should be used for corresponding
#' choice.
#' @param default_text Text to be visible on dropdown when nothing is selected.
#' @param value Pass value if you want to initialize selection for dropdown.
#' @param type Change depending what type of dropdown is wanted.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' library(shiny)
#' library(shiny.semantic)
#' ui <- semanticPage(
#' title = "Dropdown example",
#' dropdown_input("simple_dropdown", LETTERS, value = "A"),
#' p("Selected letter:"),
#' textOutput("dropdown")
#' )
#' server <- function(input, output) {
#' output$dropdown <- renderText(input[["simple_dropdown"]])
#' }
#'
#' shinyApp(ui = ui, server = server)
#' }
#'
#' @export
dropdown_input <- function(input_id, choices, choices_value = choices,
default_text = "Select", value = NULL, type = "selection fluid") {
if (!is.null(value)) {
value <- paste(as.character(value), collapse = ",")
}
shiny::div(
id = input_id, class = paste("ui", type, "dropdown semantic-select-input"),
tags$input(type = "hidden", name = input_id, value = value),
icon("dropdown"),
shiny::div(class = "default text", default_text),
menu(
if (is.null(names(choices))) {
purrr::map2(
choices, choices_value,
~ shiny::div(class = "item", `data-value` = .y, .x)
)
} else {
purrr::map(
seq_len(length(choices)), ~ {
shiny::tagList(
menu_header(names(choices)[.x], is_item = FALSE),
menu_divider(),
purrr::map2(
choices[[.x]], choices_value[[.x]],
~ shiny::div(class = "item", `data-value` = .y, .x)
)
)
}
)
}
)
)
}
#' Create a select list input control
#'
#' Create a select list that can be used to choose a single or multiple items from a list of values.
#'
#' @param inputId The input slot that will be used to access the value.
#' @param label Display label for the control, or NULL for no label.
#' @param choices List of values to select from. If elements of the list are named,
#' then that name — rather than the value — is displayed to the user.
#' @param selected The initially selected value (or multiple values if multiple = TRUE).
#' If not specified then defaults to the first value for single-select lists and no
#' values for multiple select lists.
#' @param multiple Is selection of multiple items allowed?
#' @param width The width of the input.
#' @param ... Arguments passed to \link{dropdown_input}.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' library(shiny.semantic)
#'
#' # basic example
#' shinyApp(
#' ui = semanticPage(
#' selectInput("variable", "Variable:",
#' c("Cylinders" = "cyl",
#' "Transmission" = "am",
#' "Gears" = "gear")),
#' tableOutput("data")
#' ),
#' server = function(input, output) {
#' output$data <- renderTable({
#' mtcars[, c("mpg", input$variable), drop = FALSE]
#' }, rownames = TRUE)
#' }
#' )
#' }
#'
#' @export
selectInput <- function(inputId, label, choices, selected = NULL, multiple = FALSE, width = NULL, ...) {
args <- list(...)
args_names <- names(args)
if ("selectize" %in% args_names) {
message("'selectize' is shiny::selectInput specific parameter")
args$selectize <- NULL
}
if ("size" %in% args_names) {
message("'size' is shiny::selectInput specific parameter")
args$size <- NULL
}
if (!("type" %in% args_names))
args$type <- "fluid selection"
if (multiple)
args$type <- paste(args$type, "multiple")
if (is.null(selected) && !multiple)
selected <- choices[1]
if (!("default_text" %in% args_names))
args$default_text <- ""
args$input_id <- inputId
named_choices <- !is.null(attr(choices, "names"))
args$choices <- if (named_choices) names(choices) else choices
args$choices_value <- unname(choices)
args$value <- selected
shiny::div(
class = "ui form",
style = if (!is.null(width)) glue::glue("width: {shiny::validateCssUnit(width)};"),
shiny::div(class = "field",
if (!is.null(label)) tags$label(label, `for` = inputId),
do.call(dropdown_input, args)
)
)
}
#' Update dropdown Semantic UI component
#'
#' Change the value of a \code{\link{dropdown_input}} input on the client.
#'
#' @param session The \code{session} object passed to function given to \code{shinyServer}.
#' @param input_id The id of the input object
#' @param choices All available options one can select from. If no need to update then leave as \code{NULL}
#' @param choices_value What reactive value should be used for corresponding choice.
#' @param value A value to update dropdown to. Defaults to \code{NULL}.
#' \itemize{
#' \item a value from \code{choices} updates the selection
#' \item \code{character(0)} and \code{""} clear the selection
#' \item \code{NULL}:
#' \itemize{
#' \item clears the selection if \code{choices} is provided
#' \item otherwise, \code{NULL} does not change the selection
#' }
#' \item a value not found in \code{choices} does not change the selection
#' }
#'
#' @examples
#' if (interactive()) {
#' library(shiny)
#' library(shiny.semantic)
#'
#' ui <- semanticPage(
#' title = "Dropdown example",
#' dropdown_input("simple_dropdown", LETTERS[1:5], value = "A", type = "selection multiple"),
#' p("Selected letter:"),
#' textOutput("selected_letter"),
#' shiny.semantic::actionButton("simple_button", "Update input to D")
#' )
#'
#' server <- function(input, output, session) {
#' output$selected_letter <- renderText(paste(input[["simple_dropdown"]], collapse = ", "))
#'
#' observeEvent(input$simple_button, {
#' update_dropdown_input(session, "simple_dropdown", value = "D")
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
update_dropdown_input <- function(session, input_id, choices = NULL, choices_value = choices, value = NULL) {
msg <- list()
if (!is.null(value)) {
msg$value <- paste(as.character(value), collapse = ",") # NOTE: paste() converts character(0) to ""
}
if (!is.null(choices)) {
msg$choices <- jsonlite::toJSON(list(values = data.frame(name = choices, text = choices, value = choices_value)))
}
session$sendInputMessage(input_id, msg)
}
#' Change the value of a select input on the client
#'
#' Update selecInput widget
#'
#' @param session The session object passed to function given to shinyServer.
#' @param inputId The id of the input object.
#' @param label The label to set for the input object.
#' @param choices List of values to select from. If elements of the list are named,
#' then that name — rather than the value — is displayed to the user.
#' @param selected The initially selected value (or multiple values if multiple = TRUE).
#' If not specified then defaults to the first value for single-select lists and no
#' values for multiple select lists.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- semanticPage(
#' p("The checkbox group controls the select input"),
#' multiple_checkbox("checkboxes", "Input checkbox",
#' c("Item A", "Item B", "Item C")),
#' selectInput("inSelect", "Select input",
#' c("Item A", "Item B"))
#' )
#'
#' server <- function(input, output, session) {
#' observe({
#' x <- input$checkboxes
#'
#' # Can use character(0) to remove all choices
#' if (is.null(x))
#' x <- character(0)
#'
#' # Can also set the label and select items
#' updateSelectInput(session, "inSelect",
#' label = paste(input$checkboxes, collapse = ", "),
#' choices = x,
#' selected = tail(x, 1)
#' )
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
updateSelectInput <- function(session, inputId, label = NULL, choices = NULL, selected = NULL) {
if (!is.null(selected)) selected <- paste(as.character(selected), collapse = ",") else selected <- NULL
if (!is.null(choices)) {
choices_text <- names(choices)
if (identical(choices_text, NULL))
choices_text <- choices
options <- jsonlite::toJSON(list(values = data.frame(name = choices_text, text = choices_text, value = choices)))
} else {
options <- NULL
}
message <- list(label = label, choices = options, value = selected)
message <- message[!vapply(message, is.null, FUN.VALUE = logical(1))]
session$sendInputMessage(inputId, message)
}
#' Themes changer dropdown
#'
#' @param input_id Id of dropdown. \code{input[[input_id]]} returns the currently selected theme.
#' @param label Dropdown label.
#'
#' @examples
#'
#' if (interactive()) {
#' library(shiny)
#' library(shiny.semantic)
#' ui <- semanticPage(
#' theme = "superhero",
#' actionButton("action_button", "Press Me!"),
#' textOutput("button_output"),
#' theme_selector(),
#' textOutput("theme")
#' )
#' server <- function(input, output, session) {
#' output$button_output <- renderText(as.character(input$action_button))
#' output$theme <- renderText(as.character(input$theme))
#' }
#' shinyApp(ui, server)
#' }
#'
#' @export
theme_selector <- function(input_id = "theme", label = "Choose theme") {
dropdown_content <- dropdown_input(
"theme", choices = c("default", semantic.assets::SUPPORTED_THEMES),
choices_value = c("", semantic.assets::SUPPORTED_THEMES),
type = "selection fluid themes-dropdown"
)
shiny::div(
class = "ui form theme",
shiny::div(class = "field",
if (!is.null(label)) tags$label(label, `for` = input_id),
dropdown_content
)
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.