更改 select 输入选项的字体颜色 R Shiny

Question

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

例如，ID F001、F003、T006 和 T008 将在下拉菜单中显示蓝色字体颜色。 N002、T004 和 F005 将显示为红色。此列表会随着时间不断变化，因此需要具有反应性。

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

示例数据帧：

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

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

UI:

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
        
    })
    
})

Answer 1

您可以保持所选值颜色更新的方法。这里我给大家提供下拉变色的解决方法：

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)

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

Answer 2

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

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)

更改 select 输入选项的字体颜色 R Shiny

Change font color of select input choices R Shiny

css

r

shiny

shinyapps