Nothing
#' @importFrom htmltools htmlDependency
html_dependency_virtualselect <- function() {
htmlDependency(
name = "virtual-select",
version = "1.0.41",
src = c(file = system.file("packer", package = "shinyWidgets")),
script = "virtual-select.js",
all_files = FALSE
)
}
#' Prepare choices for [virtualSelectInput()]
#'
#' @param .data An object of type [data.frame()].
#' @param label Variable to use as labels (displayed to user).
#' @param value Variable to use as values (retrieved server-side).
#' @param group_by Variable identifying groups to use option group feature.
#' @param description Optional variable allowing to show a text under the labels.
#' @param alias Optional variable containing text to use with search feature.
#' @param classNames Optional variable containing class names to customize specific options.
#'
#' @return A `list` to use as `choices` argument of [virtualSelectInput()].
#' @export
#'
#' @importFrom rlang enexprs eval_tidy is_null
#'
#' @example inst/examples/virtual-select/prepare-choices/app.R
prepare_choices <- function(.data,
label,
value,
group_by = NULL,
description = NULL,
alias = NULL,
classNames = NULL) {
args <- lapply(
X = enexprs(
label = label,
value = value,
group_by = group_by,
description = description,
alias = alias,
classNames = classNames
),
FUN = eval_tidy,
data = as.data.frame(.data)
)
args <- dropNulls(args)
if (!is_null(args$group_by)) {
type <- "transpose_group"
groups <- args$group_by
args$group_by <- NULL
args <- lapply(
X = unique(groups),
FUN = function(group) {
list(
label = group,
options = lapply(args, `[`, groups == group)
)
}
)
} else {
type <- "transpose"
}
structure(list(choices = args, type = type), class = c("list", "vs_choices"))
}
#' @title Virtual Select Input
#'
#' @description A select dropdown widget made for performance,
#' based on [virtual-select](https://github.com/sa-si-dev/virtual-select) JavaScript library.
#'
#' @param choices List of values to select from.
#' You can use:
#' * `vector` use a simple vector for better performance.
#' * `named list` / `named vector` in the same way as with [shiny::selectInput()]
#' * custom formatted `list` allowing to use more options, must correspond to [virtual-select specifications](https://sa-si-dev.github.io/virtual-select/#/properties)
#' * output of [prepare_choices()]
#' @inheritParams shiny::selectInput
#' @param search Enable search feature.
#' @param hideClearButton Hide clear value button.
#' @param autoSelectFirstOption Select first option by default on load.
#' @param showSelectedOptionsFirst Show selected options at the top of the dropbox.
#' @param showValueAsTags Show each selected values as tags with remove icon.
#' @param optionsCount No.of options to show on viewport.
#' @param noOfDisplayValues Maximum no.of values to show in the tooltip for multi-select.
#' @param allowNewOption Allow to add new option by searching.
#' @param disableSelectAll Disable select all feature of multiple select.
#' @param disableOptionGroupCheckbox Disable option group title checkbox.
#' @param disabled Disable entire dropdown.
#' @param ... Other arguments passed to JavaScript method, see
#' [virtual-select documentation](https://sa-si-dev.github.io/virtual-select/#/properties) for a full list of options.
#' @param stateInput Activate or deactivate the special input value `input$<inputId>_open` to know if the menu is opened or not, see details.
#' @param updateOn When to update the input value server-side : on each changes or when the menu is closed.
#' @param html Allow usage of HTML in choices.
#' @param inline Display inline with label or not.
#'
#' @return A `shiny.tag` object that can be used in a UI definition.
#'
#' @note State of the menu (open or close) is accessible server-side through the input value:
#' `input$<inputId>_open`, which can be `TRUE` (opened) or `FALSE` (closed) or `NULL` (when initialized).
#'
#' @note For arguments that accept a function (`onServerSearch`, `labelRenderer`), only a string with a function name
#' is accepted. The function must be defined outside of any `$(document).ready({...})` javascript block. For examples, see the
#' documentation for [onServerSearch](https://sa-si-dev.github.io/virtual-select/#/examples?id=server-search)
#' and [labelRenderer](https://sa-si-dev.github.io/virtual-select/#/examples?id=add-imageicon).
#'
#' @seealso
#' * [demoVirtualSelect()] for demo apps
#' * [updateVirtualSelect()] for updating from server
#'
#' @export
#'
#' @importFrom htmltools tags css validateCssUnit HTML
#' @importFrom shiny restoreInput
#' @importFrom jsonlite toJSON
#'
#' @example inst/examples/virtual-select/default/app.R
#' @example examples/virtual-select-funcs.R
virtualSelectInput <- function(inputId,
label,
choices,
selected = NULL,
multiple = FALSE,
search = FALSE,
hideClearButton = !multiple,
autoSelectFirstOption = !multiple,
showSelectedOptionsFirst = FALSE,
showValueAsTags = FALSE,
optionsCount = 10,
noOfDisplayValues = 50,
allowNewOption = FALSE,
disableSelectAll = !multiple,
disableOptionGroupCheckbox = !multiple,
disabled = FALSE,
...,
stateInput = TRUE,
updateOn = c("change", "close"),
html = FALSE,
inline = FALSE,
width = NULL) {
selected <- restoreInput(id = inputId, default = selected)
updateOn <- match.arg(updateOn)
choices <- process_choices(choices)
data <- list(
stateInput = stateInput,
options = toJSON(choices, auto_unbox = FALSE, json_verbatim = TRUE),
config = dropNulls(list(
multiple = multiple,
search = search,
selectedValue = selected,
hideClearButton = hideClearButton,
autoSelectFirstOption = autoSelectFirstOption,
showSelectedOptionsFirst = showSelectedOptionsFirst,
showValueAsTags = showValueAsTags,
optionsCount = optionsCount,
noOfDisplayValues = noOfDisplayValues,
allowNewOption = allowNewOption,
disableSelectAll = disableSelectAll,
disableOptionGroupCheckbox = disableOptionGroupCheckbox,
disabled = disabled,
...
))
)
data <- toJSON(data, auto_unbox = TRUE, json_verbatim = TRUE)
if (isTRUE(html))
data <- HTML(data)
if (!inline) {
div_css <- css(
width = "100%",
maxWidth = "none",
display = "block"
)
} else {
div_css <- css(
display = "inline-block"
)
}
tags$div(
class = "form-group shiny-input-container",
class = if (isTRUE(inline)) "shiny-input-container-inline",
style = css(width = validateCssUnit(width)),
label_input(inputId, label),
tags$div(
id = inputId,
class = "virtual-select",
style = div_css,
`data-update` = updateOn,
tags$script(
type = "application/json",
`data-for` = inputId,
data
)
),
html_dependency_virtualselect()
)
}
#' @title Update virtual select from server
#'
#' @description
#' Update a [virtualSelectInput()] from the server.
#'
#'
#' @inheritParams virtualSelectInput
#' @inheritParams shiny::updateSelectInput
#' @param disable Disable (`TRUE`) or enable (`FALSE`) the select menu.
#' @param disabledChoices List of disabled option's values.
#' @param open Open (`TRUE`) or close (`FALSE`) the dropdown.
#'
#' @return No value.
#'
#' @seealso [virtualSelectInput()] for creating a widget in the UI.
#'
#' @export
#'
#' @importFrom shiny getDefaultReactiveDomain
#' @importFrom htmltools doRenderTags
#'
#' @example inst/examples/virtual-select/update/app.R
updateVirtualSelect <- function(inputId,
label = NULL,
choices = NULL,
selected = NULL,
disable = NULL,
disabledChoices = NULL,
open = NULL,
session = shiny::getDefaultReactiveDomain()) {
if (!is.null(label))
label <- doRenderTags(label)
if (!is.null(choices)) {
choices <- process_choices(choices)
choices <- toJSON(choices, auto_unbox = FALSE, json_verbatim = TRUE)
}
message <- dropNulls(list(
label = label,
options = choices,
value = selected,
disable = disable,
disabledChoices = list1(disabledChoices),
open = open
))
session$sendInputMessage(inputId, message)
}
#' Demo for [virtualSelectInput()]
#'
#' @param name Name of the demo app to launch.
#'
#' @return No value.
#' @export
#'
#' @importFrom shiny runApp shinyAppFile
#'
#' @examples
#' \dontrun{
#'
#' # Default usage
#' demoVirtualSelect("default")
#'
#' # Update widget from server
#' demoVirtualSelect("update")
#'
#' # Differents ways of specifying choices
#' demoVirtualSelect("choices-format")
#'
#' # Prepare choices from a data.frame
#' demoVirtualSelect("prepare-choices")
#'
#' # Theming with bslib
#' demoVirtualSelect("bslib-theming")
#'
#' }
demoVirtualSelect <- function(name = c("default", "update", "choices-format", "prepare-choices", "bslib-theming")) {
name <- match.arg(name )
runApp(
shinyAppFile(
appFile = system.file("examples", "virtual-select", name, "app.R", package = "shinyWidgets")
),
display.mode = "showcase"
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.