Как динамически стилизовать меню выбора в Shiny

Question

Я хотел бы обновить цвета моего pickerInput на основе ввода из colourInput в приведенном ниже примере.

Этот вопрос следует из этого вопроса и репликации this с pickerInput вместо selectizeInput.

Отлично работает с selectizeInput:

## load iris dataset
data(iris)
cats <- levels(iris$Species)

## colourInput ---- create list of shiny inputs for UI
ids <-  paste0("col", seq(3))
cols <- c("red", "blue", "yellow")
foo <- function(x) {colourInput(ids[x], cats[x], cols[x])}
my_input <- lapply(seq(ids), foo)

## css styling for selectizeInput menu
CSS <- function(values, colors){
  template <- "
.option[data-value=%s], .item[data-value=%s]{
  background: %s !important;
  color: white !important;
}"
  paste0(
    apply(cbind(values, colors), 1, function(vc){
      sprintf(template, vc[1], vc[1], vc[2])
    }),
    collapse = "\n"
  )
}
css <- CSS(cats, cols[seq(cats)])



## ------ shiny app ------
runApp(shinyApp(
  
  ui = fluidPage(
    tabsetPanel(type = "tabs",
                tabPanel("Dataset", id = "data",
                         tags$head(
                           uiOutput("css")
                         ),
                         selectizeInput("species", "Labels",
                                        choices = cats,
                                        multiple = TRUE,
                                        selected = cats),
                         plotOutput("scatter")
                ),
                tabPanel("Colour Menu", id = "colmenu",
                         my_input)
    )
  ),
  
  server = function(input, output, session) {  
    
    ## get coords according to selectizeInput 
    mrkSel <- reactive({
      lapply(input$species,
             function(z) which(iris$Species == z))
    })
    
    ## colours selected by user in colourPicker
    cols_user <- reactive({
      sapply(ids, function(z) input[[z]])
    })
    
    ## update scatter colours
    scattercols <- reactive({
      cols_user()[sapply(input$species, function(z) 
        which(cats == z))]
    })
    
    ## scatter plot is conditional on species selected
    output$scatter <- renderPlot({
      plot(iris$Petal.Length, iris$Petal.Width, pch=21)
      if (!is.null(input$species)) {
        for (i in 1:length(input$species)) {
          points(iris$Petal.Length[mrkSel()[[i]]], iris$Petal.Width[mrkSel()[[i]]], 
                 pch = 19, col = scattercols()[i])
        }
      }
    }) 
    
    ## update colours
    output$css <- renderUI({
      tags$style(HTML(CSS(cats, cols_user())))
    })
    
  }
)
)

Попытка реплицировать с pickerInput

## load iris dataset
data(iris)
cats <- levels(iris$Species)

## colourInput ---- create list of shiny inputs for UI
ids <-  paste0("col", seq(3))
cols <- c("red", "blue", "yellow")
foo <- function(x) {colourInput(ids[x], cats[x], cols[x])}
my_input <- lapply(seq(ids), foo)

## css styling for selectizeInput menu
CSS <- function(values, colors){
  template <- "
.dropdown-menu[data-value=%s] {
  background: %s !important;
  color: white !important;
}"
  paste0(
    apply(cbind(values, colors), 1, function(vc){
      sprintf(template, vc[1], vc[1], vc[2])
    }),
    collapse = "\n"
  )
}
css <- CSS(cats, cols[seq(cats)])



## ------ shiny app ------
runApp(shinyApp(
  
  ui = fluidPage(
    tabsetPanel(type = "tabs",
                tabPanel("Dataset", id = "data",
                         tags$head(
                           uiOutput("css")
                         ),
                         pickerInput("species", "Labels",
                                        choices = cats,
                                        multiple = TRUE,
                                        selected = cats,
                                     options = list(
                                       `actions-box` = TRUE,
                                       size = 10,
                                       `selected-text-format` = "count > 3"
                                     )),
                         plotOutput("scatter")
                ),
                tabPanel("Colour Menu", id = "colmenu",
                         my_input)
    )
  ),
  
  server = function(input, output, session) {  
    
    ## get coords according to selectizeInput 
    mrkSel <- reactive({
      lapply(input$species,
             function(z) which(iris$Species == z))
    })
    
    ## colours selected by user in colourPicker
    cols_user <- reactive({
      sapply(ids, function(z) input[[z]])
    })
    
    ## update scatter colours
    scattercols <- reactive({
      cols_user()[sapply(input$species, function(z) 
        which(cats == z))]
    })
    
    ## scatter plot is conditional on species selected
    output$scatter <- renderPlot({
      plot(iris$Petal.Length, iris$Petal.Width, pch=21)
      if (!is.null(input$species)) {
        for (i in 1:length(input$species)) {
          points(iris$Petal.Length[mrkSel()[[i]]], iris$Petal.Width[mrkSel()[[i]]], 
                 pch = 19, col = scattercols()[i])
        }
      }
    }) 
    
    ## update colours
    output$css <- renderUI({
      tags$style(HTML(CSS(cats, cols_user())))
    })
    
  }
)
)

Я не знаком со стилем css и поэтому могу предположить, что мой код неправильный при попытке стилизовать dropdown-menu.

Может ли кто-нибудь сказать мне, как добиться цветового кодирования капли меню вниз в зависимости от цвета, выбранного на вкладке «Меню цвета»? Бонус, если кто-нибудь знает шпаргалку, которой он может поделиться для css стиля.

Answer 1

CSS <- function(colors){
  template <- "
.dropdown-menu ul li:nth-child(%s) a {
  background: %s !important;
  color: white !important;
}"
  paste0(
    apply(cbind(seq_along(colors), colors), 1, function(vc){
      sprintf(template, vc[1], vc[2])
    }),
    collapse = "\n"
  )
}

и

output$css <- renderUI({
  tags$style(HTML(CSS(cols_user())))
})

Чтобы справиться с CSS, вам следует попробовать инструмент инспектора (щелкните правой кнопкой мыши элемент, затем «Проверить»).