闪亮的下拉输入，带有用图标装饰的组

Question

在对此答案的评论中，@Vlad 询问了一种在 Shiny 应用程序中获取带有用图标装饰的组的下拉输入的方法。没有给出答案，所以我提出这个问题。

Answer 1

这是使用shinySelect包的解决方案。

library(shiny)
library(shinySelect)
library(fontawesome)
library(bslib)

states <- HTMLgroupedChoices(
  groups = mapply(
    function(x, icon){
      tags$h2(
        fa_i(icon), x, 
        style="text-decoration: underline; color: darkred;"
      )
    },
    list("East Coast", "West Coast", "Midwest"), 
    list("hamburger", "pizza-slice", "fish"),
    SIMPLIFY = FALSE
  ),
  labels = list(
    lapply(list("NY", "NJ", "CT"), function(x){
      tags$span(HTML("&bull;"), x, style="color: red;")
    }),
    lapply(list("WA", "OR", "CA"), function(x){
      tags$span(HTML("&bull;"), x, style="color: green;")
    }),
    lapply(list("MN", "WI", "IA"), function(x){
      tags$span(HTML("&bull;"), x, style="color: blue;")
    })
  ),
  values = list(
    list("NY", "NJ", "CT"),
    list("WA", "OR", "CA"),
    list("MN", "WI", "IA")
  )
)

ui <- fluidPage(
  theme = bs_theme(version = 4),
  titlePanel("Groups with icons example"),
  sidebarLayout(
    sidebarPanel(
      selectControlInput(
        "select",
        label = tags$h3("Choose some states", style="color: crimson;"),
        containerClass = NULL,
        choices = states,
        selected = c("NY", "OR"),
        multiple = TRUE,
        animated = TRUE
      )
    ),
    mainPanel(
      verbatimTextOutput("textOutput")
    )
  )
)

server <- function(input, output, session) {
  output[["textOutput"]] <- renderPrint({
    sprintf("You selected: %s.", toString(input[["select"]]))
  })
}

shinyApp(ui, server)