html - 如何在 Shiny 中动态设置 pickerInput 菜单的样式

Question

我想根据下面示例中的pickerInput输入更新我的颜色。colourInput

这个问题是从这个问题开始的，并用而不是复制这个问题。pickerInputselectizeInput

这适用于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样式的备忘单。

标签： htmlcssrshiny

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，您应该尝试检查器工具（右键单击元素，然后“检查”）。