Change font color of select input choices R Shiny

Question

If an ID in my select input choices is detected in the values data frame, I want to change the item's font color in the drop-down menu.

For example, IDs F001, F003, T006, and T008 would display a blue font color in the drop-down menu. N002, T004, and F005 would show as red. This list is continuously changing over time, so it would need to be reactive.

The closest I've gotten is using the input$selectVariable in my case_when statement. However, when the drop-down list is expanded, each item does not display its respective font color because it's only selecting the input. How can I change the font colors in the drop-down menu too and not just the selected input?

Example dataframes:

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

Server:

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

Here is a way without reactive CSS. The select input is created in the server, this easily allows to use reactive dataframes.

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)

Answer 2

You can keep your methods for the selected value color update. Here I provide you the solution with the dropdown color change:

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)

I removed not needed code and only leave the code to reproduce the problem. You may add the code back in your real app.