更改选择输入选项的字体颜色 R Shiny答案

【问题标题】：Change font color of select input choices R Shiny更改选择输入选项的字体颜色 R Shiny
【发布时间】：2021-11-14 14:27:32
【问题描述】：

如果在 values 数据框中检测到我的选择输入选项中的 ID，我想在下拉菜单中更改项目的字体颜色。

例如，ID F001、F003、T006 和 T008 将在下拉菜单中显示蓝色字体颜色。 N002、T004 和 F005 将显示为红色。这个列表会随着时间不断变化，所以它需要是被动的。

我得到的最接近的是在我的 case_when 语句中使用 input$selectVariable。但是，当下拉列表展开时，每个项目都不会显示其各自的字体颜色，因为它只是选择输入。如何更改下拉菜单中的字体颜色，而不仅仅是选定的输入？

示例数据框：

df<- data.frame("ID" = c("F001","N002","F003","T004","F005")) 

values <- data.frame("AnimalID"= c("F001","F003","T006", "T008"))`

用户界面：

library(shiny)

shinyUI(navbarPage(
  tabPanel("Analysis",
           sidebarLayout(
             sidebarPanel(width = 10,
                          uiOutput('background_change'),
                          
                          selectInput("selectVariable", "Select an ID:",
                                      choices =  unique(df$ID)),
                          ), 
             mainPanel(dataTableOutput("Table1")))
  )) )

服务器：

library(shiny)

library(shiny)
library(move)
library(amt) 
library(tibble)
library(dplyr)
library(htmltools)
library(dygraphs)
library(ggplot2)
library(plotly)
library(shinythemes)
library(shinydashboard)
library(datetime)
library(shinyTime)
shinyServer(function(input, output, session) {
    

    
    bg <- reactive({
        
        #choices<- sort(unique(df$ID))
        case_when(input$selectVariable %in% values$AnimalID ~ 
                  '#selectVariable ~  .selectize-dropdown, .options, .item {
                  color: blue ;
                } ',
                  
                  TRUE  ~ '#selectVariable ~  .selectize-dropdown, .options, .item{
                  color: red ;
                }')
    })
    
    output$background_change <- renderUI({
        tags$head(tags$style(HTML(bg())))
    })
    
    
    output$Table1 <- renderDataTable({
        
        values
        
    })
    
})

【问题讨论】：

标签： css r shiny shinyapps

【解决方案1】：

这是一种没有响应式 CSS 的方法。选择输入是在服务器中创建的，这很容易允许使用响应式数据帧。

library(shiny) 
library(jsonlite)

ui = fluidPage(
  tags$head(
    tags$style(
      HTML(
        "
        .red {color: red;}
        .blue {color: blue;}
        "
      )
    )
  ),
  br(),
  uiOutput("slctzUI")
)

server <- function(input, output, session){
  
  df <- data.frame("ID" = c("F001","N002","F003","T004","F005")) 
  
  values <- data.frame("AnimalID" = c("F001","F003","T006", "T008"))
  
  choices <- unique(df[["ID"]])
  
  colors <- ifelse(choices %in% values[["AnimalID"]], "blue", "red")
  names(colors) <- choices
  colors <- toJSON(as.list(colors))
  
  output[["slctzUI"]] <- renderUI({
    selectizeInput(
      "slctz", "Select something:",
      choices = choices, 
      options = list( 
        render = I(sprintf("{
        item: function(item, escape) { 
          var colors = %s;
          var color = colors[item.label];
          return '<span class=\"' + color + '\">' + item.label + '</span>'; 
        },
        option: function(item, escape) { 
          var colors = %s;
          var color = colors[item.label];
          return '<span class=\"' + color + '\">' + item.label + '</span>'; 
        }
      }", colors, colors))
      )
    )
    
  })
  
}

shinyApp(ui, server)

【讨论】：

这真的很有帮助！是否可以使下拉选择垂直而不是水平？我不熟悉 selectizeInput 选项。
@JNN 我认为您必须将 span 替换为 div。

【解决方案2】：

您可以保留所选值颜色更新的方法。在这里我为您提供下拉颜色变化的解决方案：

library(shiny)
library(dplyr)
df<- data.frame("ID" = c("F001","N002","F003","T004","F005")) 
values <- data.frame("AnimalID"= c("F001","F003","T006", "T008"))
blue_numbers <- which(df$ID %in% values$AnimalID)
red_numbers <- which(!df$ID %in% values$AnimalID)

styles <- paste0(
    paste0('#selectVariable  + .selectize-control .selectize-dropdown-content .option:nth-of-type(', blue_numbers, ')', collapse = ','),
    '{color: blue;}\n',
    paste0('#selectVariable  + .selectize-control .selectize-dropdown-content .option:nth-of-type(', red_numbers, ')', collapse = ','),
    '{color: red;}'
)
ui <- navbarPage(
    tabPanel("Analysis",
             sidebarLayout(
                 sidebarPanel(width = 10,
                              uiOutput('background_change'),
                              tags$style(styles),
                              selectInput("selectVariable", "Select an ID:",
                                          choices =  unique(df$ID)),
                 ), 
                 mainPanel(dataTableOutput("Table1")))
    )
) 

server <- function(input, output, session) {
    bg <- reactive({
        case_when(input$selectVariable %in% values$AnimalID ~ 
                      '#selectVariable ~  .selectize-dropdown, .options, .item {
                  color: blue ;
                } ',
                  
                  TRUE  ~ '#selectVariable ~  .selectize-dropdown, .options, .item{
                  color: red ;
                }')
    })
    
    output$background_change <- renderUI({
        tags$head(tags$style(HTML(bg())))
    })
    
    
}
shinyApp(ui, server)

我删除了不需要的代码，只留下代码来重现问题。您可以将代码添加回您的真实应用中。

【讨论】：