How to dynamically style a pickerInput menu in Shiny

问题

I would like to update the colours of my pickerInput based on input from the colourInput in the below example.

This questions follows on from this question and replicating this with pickerInput instead of selectizeInput.

This works great with 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())))
    })
    
  }
)
)

An attempt to replicate with 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())))
    })
    
  }
)
)

I am not familiar with css styling and so I can assume my code is wrong when trying to style dropdown-menu.

Can someone tell me how to achieve colour coding of the drop down menu based on the colour selected in the Colour Menu tab? Bonus, if anyone knows of a cheatsheet they can share for css styling.

回答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"
  )
}

and

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

To deal with CSS, you should try the inspector tool (right-click on an element, then "Inspect").

来源：https://stackoverflow.com/questions/63268923/how-to-dynamically-style-a-pickerinput-menu-in-shiny