Added Slim select

NAMESPACE

@@ -62,6 +62,7 @@ export(pickerGroupUI)
 export(pickerInput)
 export(pickerOptions)
 export(prepare_choices)
+export(prepare_slim_choices)
 export(prettyCheckbox)
 export(prettyCheckboxGroup)
 export(prettyRadioButtons)
@@ -85,6 +86,7 @@ export(showDropMenu)
 export(show_alert)
 export(show_toast)
 export(sliderTextInput)
+export(slimSelectInput)
 export(spectrumInput)
 export(statiCard)
 export(switchInput)
@@ -119,6 +121,7 @@ export(updateProgressBar)
 export(updateRadioGroupButtons)
 export(updateSearchInput)
 export(updateSliderTextInput)
+export(updateSlimSelect)
 export(updateSpectrumInput)
 export(updateStatiCard)
 export(updateSwitchInput)

R/slim-select.R

@@ -0,0 +1,264 @@
+
+#' @importFrom htmltools htmlDependency
+html_dependency_slimselect <- function() {
+  htmlDependency(
+    name = "slim-select",
+    version = "2.8.2",
+    src = c(file = system.file("packer", package = "shinyWidgets")),
+    script = "slim-select.js",
+    all_files = FALSE
+  )
+}
+
+
+#' Prepare choices for [slimSelectInput()]
+#'
+#' @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 html Alternative HTML to be displayed instaed of label.
+#' @param selected Is the option must be selected ?
+#' @param display Allows to hide elements of selected values.
+#' @param disabled Allows the ability to disable the select dropdown as well as individual options.
+#' @param mandatory When using multi select you can set a mandatory on the option to prevent capability
+#'  to deselect particular option. Note options with mandatory flag is not selected by default, you need select them yourselfs.
+#' @param class Add CSS classes.
+#' @param style Add custom styles to options.
+#' @param .by Variable identifying groups to use option group feature.
+#' @param selectAll Enable select all feature for options groups.
+#' @param closable Allow to close options groups, one of: 'off', 'open', 'close'.
+#'
+#' @return A `list` to use as `choices` argument of [slimSelectInput()].
+#' @export
+#'
+#' @example examples/prepare_slim_choices.R
+prepare_slim_choices <- function(.data,
+                                 label,
+                                 value,
+                                 html = NULL,
+                                 selected = NULL,
+                                 display = NULL,
+                                 disabled = NULL,
+                                 mandatory = NULL,
+                                 class = NULL,
+                                 style = NULL,
+                                 .by = NULL,
+                                 selectAll = NULL,
+                                 closable = NULL) {
+  args <- lapply(
+    X = enexprs(
+      text = label,
+      value = value,
+      html = html,
+      selected = selected,
+      display = display,
+      disabled = disabled,
+      mandatory = mandatory,
+      class = class,
+      style = style,
+      .by = .by,
+      selectAll = selectAll,
+      closable = closable
+    ),
+    FUN = eval_tidy,
+    data = as.data.frame(.data)
+  )
+  args <- dropNulls(args)
+  if (!is.null(args$selectAll))
+    args$selectAll <- rep_len(args$selectAll, length.out = nrow(.data))
+  if (!is.null(args$closable))
+    args$closable <- rep_len(args$closable, length.out = nrow(.data))
+  if (!is_null(args$.by)) {
+    groups <- args$.by
+    args$.by <- NULL
+    args <- lapply(
+      X = unique(groups),
+      FUN = function(group) {
+        selectAll <- args$selectAll[groups == group][1]
+        args$selectAll <- NULL
+        closable <- args$closable[groups == group][1]
+        args$closable <- NULL
+        options <- lapply(args, `[`, groups == group)
+        dropNulls(list(
+          label = group,
+          selectAll = selectAll,
+          closable = closable,
+          options = lapply(
+            X = seq_along(options[[1]]),
+            FUN = function(i) {
+              lapply(options, `[`, i)
+            }
+          )
+        ))
+      }
+    )
+  } else {
+    args$selectAll <- NULL
+    args$closable <- NULL
+    args <- lapply(
+      X = seq_along(args[[1]]),
+      FUN = function(i) {
+        lapply(args, `[`, i)
+      }
+    )
+  }
+  I(args)
+}
+
+
+#' @title Slim Select Input
+#'
+#' @description An advanced select dropdown,
+#'  based on [slim-select](https://github.com/brianvoe/slim-select) JavaScript library.
+#'
+#' @param choices List of values to select from.
+#' You can use:
+#'  * `vector` a simple vector.
+#'  * `named list` / `named vector` in the same way as with [shiny::selectInput()]
+#'  * cuxtom choices prepared with [prepare_slim_choices()].
+#' @inheritParams shiny::selectInput
+#' @param search Enable search feature.
+#' @param placeholder Placeholder text.
+#' @param allowDeselect This will allow you to deselect a value on a single/multiple select dropdown.
+#' @param closeOnSelect A boolean value in which determines whether or not to close the content area upon selecting a value.
+#' @param keepOrder If `TRUE` will maintain the order in which options are selected.
+#' @param alwaysOpen If `TRUE` keep the select open at all times.
+#' @param contentPosition Will set the css position to either relative or absolute.
+#' @param ... Other settings passed to Slim Select JAvaScript method.
+#' @param inline Display the widget inline.
+#'
+#' @return A `shiny.tag` object that can be used in a UI definition.
+#' @export
+#'
+#' @example inst/examples/slim-select/basic/app.R
+slimSelectInput <- function(inputId,
+                            label,
+                            choices,
+                            selected = NULL,
+                            multiple = FALSE,
+                            search = TRUE,
+                            placeholder = NULL,
+                            allowDeselect = NULL,
+                            closeOnSelect = !multiple,
+                            keepOrder = NULL,
+                            alwaysOpen = NULL,
+                            contentPosition = NULL,
+                            ...,
+                            inline = FALSE,
+                            width = NULL) {
+  selected <- restoreInput(id = inputId, default = selected)
+  data <- dropNulls(list(
+    data = if (inherits(choices, "AsIs")) {
+      if (!isTRUE(multiple) & isTRUE(allowDeselect)) {
+        c(list(list(placeholder = TRUE, text = placeholder, value = NULL)), list(as.list(choices)))
+      } else {
+        as.list(choices)
+      }
+    } else {
+      if (!isTRUE(multiple) & isTRUE(allowDeselect)) {
+        c(list(list(placeholder = TRUE, text = placeholder, value = NULL)), make_slim_data(choicesWithNames(choices)))
+      } else {
+        make_slim_data(choicesWithNames(choices))
+      }
+    },
+    selected = selected,
+    settings = dropNulls(list(
+      showSearch = search,
+      placeholderText = placeholder,
+      allowDeselect = allowDeselect,
+      closeOnSelect = closeOnSelect,
+      keepOrder = keepOrder,
+      alwaysOpen = alwaysOpen,
+      contentPosition = contentPosition,
+      ...
+    ))
+  ))
+  tag_select <- tags$select(
+    id = inputId,
+    class = "slim-select",
+    tags$script(
+      type = "application/json",
+      `data-for` = inputId,
+      toJSON(data, auto_unbox = TRUE, json_verbatim = TRUE)
+    )
+  )
+  if (multiple)
+    tag_select$attribs$multiple <- "multiple"
+  tags$div(
+    class = "form-group shiny-input-container",
+    class = if (isTRUE(inline)) "shiny-input-container-inline",
+    style = css(width = validateCssUnit(width), height = "auto"),
+    label_input(inputId, label),
+    tag_select,
+    tags$div(id = paste0(inputId, "-placeholder"), style = css(height = "auto")),
+    html_dependency_slimselect()
+  )
+}
+
+
+make_slim_data <- function(choices) {
+  lapply(
+    X = seq_along(choices),
+    FUN = function(i) {
+      label <- names(choices)[i]
+      choice <- choices[[i]]
+      if (is.list(choice)) {
+        list(
+          label = label,
+          options = make_slim_data(choice)
+        )
+      } else {
+        list(text = label, value = choice)
+      }
+    }
+  )
+}
+
+
+
+#' @title Update slim select from server
+#'
+#' @description
+#' Update a [slimSelectInput()] from the server.
+#'
+#'
+#' @inheritParams slimSelectInput
+#' @inheritParams shiny::updateSelectInput
+#' @param disable Disable (`TRUE`) or enable (`FALSE`) the select menu.
+#' @param open Open (`TRUE`) or close (`FALSE`) the dropdown.
+#'
+#' @return No value.
+#'
+#' @seealso [slimSelectInput()] for creating a widget in the UI.
+#'
+#' @export
+#'
+#' @importFrom shiny getDefaultReactiveDomain
+#' @importFrom htmltools doRenderTags
+#'
+#' @example inst/examples/slim-select/update/app.R
+updateSlimSelect <- function(inputId,
+                             label = NULL,
+                             choices = NULL,
+                             selected = NULL,
+                             disable = NULL,
+                             open = NULL,
+                             session = shiny::getDefaultReactiveDomain()) {
+  if (!is.null(label))
+    label <- doRenderTags(label)
+  data <- if (!is.null(choices)) {
+    if (inherits(choices, "AsIs")) {
+      as.list(choices)
+    } else {
+      make_slim_data(choicesWithNames(choices))
+    }
+  }
+  message <- dropNulls(list(
+    label = label,
+    data = data,
+    selected = selected,
+    disable = disable,
+    open = open
+  ))
+  session$sendInputMessage(inputId, message)
+}

examples/prepare_slim_choices.R

@@ -0,0 +1,81 @@
+
+library(shiny)
+library(shinyWidgets)
+
+state_data <- data.frame(
+  name = state.name,
+  abb = state.abb,
+  region = state.region,
+  division = state.division
+)
+
+ui <- fluidPage(
+  tags$h2("Slim Select examples"),
+  fluidRow(
+    column(
+      width = 3,
+      slimSelectInput(
+        inputId = "slim1",
+        label = "Disable some choices:",
+        choices = prepare_slim_choices(
+          state_data,
+          label = name,
+          value = abb,
+          disabled = division == "Mountain"
+        ),
+        width = "100%"
+      ),
+      verbatimTextOutput("res1")
+    ),
+    column(
+      width = 3,
+      slimSelectInput(
+        inputId = "slim2",
+        label = "Custom styles:",
+        choices = prepare_slim_choices(
+          state_data,
+          label = name,
+          value = abb,
+          style = ifelse(
+            division == "Mountain",
+            "color: blue;",
+            "color: red;"
+          )
+        ),
+        multiple = TRUE,
+        placeholder = "Select a state",
+        width = "100%"
+      ),
+      verbatimTextOutput("res2")
+    ),
+    column(
+      width = 3,
+      slimSelectInput(
+        inputId = "slim3",
+        label = "Options groups with options:",
+        choices = prepare_slim_choices(
+          state_data,
+          label = name,
+          value = abb,
+          .by = region,
+          selectAll = TRUE,
+          closable = "close"
+        ),
+        multiple = TRUE,
+        width = "100%"
+      ),
+      verbatimTextOutput("res3")
+    )
+  )
+)
+
+server <- function(input, output, session) {
+  output$res1 <- renderPrint(input$slim1)
+
+  output$res2 <- renderPrint(input$slim2)
+
+  output$res3 <- renderPrint(input$slim3)
+}
+
+if (interactive())
+  shinyApp(ui, server)