如何通过updateSliderTextInput更新滑块时修改其颜色？

updateSliderTextInput函数本身并不支持color参数，直接在更新时传入该参数是无效的。要实现更新选项的同时修改滑块颜色，需要通过自定义CSS结合DOM操作来实现，下面提供两种可行方案：

方案一：使用shinyjs切换CSS类 #

通过定义不同颜色的CSS样式类，在切换选项时动态给滑块添加/移除对应类，实现颜色变化。

完整可运行代码 #

if (interactive()) {
  library("shiny")
  library("shinyWidgets")
  library("shinyjs")
  
  ui <- fluidPage(
    useShinyjs(), # 初始化shinyjs
    # 定义滑块颜色的CSS类
    tags$style(HTML("
      /* 红色滑块样式 */
      .slider-red .irs-bar, 
      .slider-red .irs-bar-edge, 
      .slider-red .irs-slider {
        background-color: red !important;
        border-color: red !important;
      }
      /* 蓝色滑块样式（示例用） */
      .slider-blue .irs-bar, 
      .slider-blue .irs-bar-edge, 
      .slider-blue .irs-slider {
        background-color: blue !important;
        border-color: blue !important;
      }
    ")),
    br(),
    sliderTextInput(
      inputId = "mySlider",
      label = "Pick a month :",
      choices = month.abb,
      selected = "Jan"
    ),
    verbatimTextOutput(outputId = "res"),
    radioButtons(
      inputId = "up",
      label = "Update choices:",
      choices = c("Abbreviations", "Full names")
    )
  )
  
  server <- function(input, output, session) {
    output$res <- renderPrint(str(input$mySlider))
    
    observeEvent(input$up, {
      # 更新滑块选项
      choices <- switch(
        input$up,
        "Abbreviations" = month.abb,
        "Full names" = month.name
      )
      updateSliderTextInput(
        session = session,
        inputId = "mySlider",
        choices = choices
      )
      
      # 根据选项切换滑块颜色
      if(input$up == "Abbreviations"){
        removeClass("mySlider", "slider-blue")
        addClass("mySlider", "slider-red")
      } else {
        removeClass("mySlider", "slider-red")
        addClass("mySlider", "slider-blue")
      }
    }, ignoreInit = TRUE)
  }
  
  shinyApp(ui = ui, server = server)
}

方案二：直接用自定义JS修改样式 #

如果不想依赖shinyjs包，可以通过Shiny的自定义消息机制，直接发送JS代码修改滑块样式：

完整可运行代码 #

if (interactive()) {
  library("shiny")
  library("shinyWidgets")
  
  ui <- fluidPage(
    br(),
    sliderTextInput(
      inputId = "mySlider",
      label = "Pick a month :",
      choices = month.abb,
      selected = "Jan"
    ),
    verbatimTextOutput(outputId = "res"),
    radioButtons(
      inputId = "up",
      label = "Update choices:",
      choices = c("Abbreviations", "Full names")
    ),
    # 添加处理颜色更新的JS
    tags$script(HTML("
      Shiny.addCustomMessageHandler('setSliderColor', function(data) {
        // 定位滑块的容器元素
        var sliderContainer = $('#' + data.id).closest('.irs');
        // 修改滑块相关元素的颜色
        sliderContainer.find('.irs-bar, .irs-bar-edge, .irs-slider').css({
          'background-color': data.color,
          'border-color': data.color
        });
      });
    "))
  )
  
  server <- function(input, output, session) {
    output$res <- renderPrint(str(input$mySlider))
    
    observeEvent(input$up, {
      choices <- switch(
        input$up,
        "Abbreviations" = month.abb,
        "Full names" = month.name
      )
      # 更新滑块选项
      updateSliderTextInput(
        session = session,
        inputId = "mySlider",
        choices = choices
      )
      
      # 发送消息修改颜色
      targetColor <- if(input$up == "Abbreviations") "red" else "blue"
      session$sendCustomMessage(
        type = "setSliderColor",
        message = list(id = "mySlider", color = targetColor)
      )
    }, ignoreInit = TRUE)
  }
  
  shinyApp(ui = ui, server = server)
}

原理说明 #

sliderTextInput的外观由irs类的元素控制，核心需要修改的是.irs-bar（滑块已选区域）、.irs-bar-edge（滑块边缘）和.irs-slider（拖动按钮）的背景色与边框色，通过CSS或JS直接操作这些元素即可实现颜色变更。

内容的提问来源于stack exchange，提问作者RRuiz