在闪亮的仪表板中为滑块添加不同的静态颜色

Question

我是闪亮的新手。无论闪亮仪表板中选择的范围如何，我都想为滑块提供静态颜色。我想为滑块设置不同的颜色，如下所示，例如：0 到 40 – 红色，40 到 60 – 蓝色，60 到 100 – 绿色。 请帮我解决这个问题。 我的代码，

library(shiny)
library(shinydashboard)

ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "test"),

                  dashboardSidebar(
                    sidebarMenu(
                      menuItem("Complete", tabName = "comp"))),

                    dashboardBody(
                      tabItems(
                        tabItem(tabName = "comp",
                          fluidRow(
                              sliderInput("range_var", "", value = c(90,100), min = 0, max = 100, width = '200%'))))))

server <- function(input, output, session) { 
  observe({
    updateSliderInput(session, "range_var", label = "", value = c(90, 100), min = 0, max = 100)
  })
}
shinyApp(ui, server)

谢谢 巴拉吉

Answer 1

哦，那我误解了你的问题。您也可以通过使用 css-commands 和正确的选择器来实现这一点：

library(shiny)
library(shinydashboard)
library(shinyjs)

ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "test"),
                    dashboardSidebar(
                      sidebarMenu(
                        menuItem("Complete", tabName = "comp"))),
                    dashboardBody(
                      inlineCSS(".irs-line-left { background-color: red; width: 40%;}
                                 .irs-line-mid { background-color: blue; width: 20%; left: 40%;}
                                 .irs-line-right { background-color: green; width: 40%; left: 60%;}
                                "
                                ),

                      shinyjs::useShinyjs(),
                      tabItems(
                        tabItem(tabName = "comp",
                                fluidRow(
                                  sliderInput("range_var", "", value = c(90,100), min = 0, max = 100, width = '200%'))))))

server <- function(input, output, session) { 
}

shinyApp(ui, server)

Answer 2

你检查过这个包 - shinyFeedback 吗？

你可以看到一些例子here。

要使用多个反馈，您应该在一个 observeEvent 中编写所有条件 - 尽管我没有设法使多个反馈起作用。

这里是来自该页面的多个反馈的代码示例：

library(shiny)
library(shinyFeedback)

ui <- fluidPage(
  useShinyFeedback(), # include shinyFeedback

  numericInput(
    "multiFeedbacks",
    "1 is scary 2 is dangerous", 
    value = 1
  )
)

server <- function(input, output) {
  observeEvent(input$multiFeedbacks, {
    feedbackWarning(
      inputId = "multiFeedbacks",
      condition = input$multiFeedbacks >= 1,
      text = "Warning 1 is a lonely number"
    )
    feedbackDanger(
      inputId = "multiFeedbacks",
      condition = input$multiFeedbacks >= 2,
      text = "2+ is danger"
    )
  })
}

shinyApp(ui, server)

另一个选择是使用 shinyjs 包，您可以在其中运行 java-script 并将 css-code 发送到浏览器。您必须将 useShinyjs() 放在dashboardBody 中。 “irs-bar”类用于所有闪亮的滑块，因此如果您只希望某个滑块上的行为，则必须调整 css 选择器（.irs-bar）。 （见下一个例子）。 这是一个小例子哦，您如何实现所需的行为：

library(shiny)
library(shinydashboard)
library(shinyjs)

ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "test"),
                    dashboardSidebar(
                      sidebarMenu(
                        menuItem("Complete", tabName = "comp"))),
                    dashboardBody(
                      shinyjs::useShinyjs(),
                      tabItems(
                        tabItem(tabName = "comp",
                                fluidRow(
                                  sliderInput("range_var", "", value = c(90,100), min = 0, max = 100, width = '200%'))))))

server <- function(input, output, session) { 
  observeEvent(input$range_var, {
    if (input$range_var[1] <= 40) {
      runjs(paste0('$(".irs-bar").css("background-color"," red")'))
    }
    if (input$range_var[1] > 40 & input$range_var[1] < 60) {
      runjs(paste0('$(".irs-bar").css("background-color"," blue")'))
    }
    if (input$range_var[1] > 60 & input$range_var[1] < 100) {
      runjs(paste0('$(".irs-bar").css("background-color"," green")'))
    }
  })
}

shinyApp(ui, server)

以下示例显示了如何仅设置一个特定的滑块输入的样式。滑块输入被放入 2 个带有 id 的 div 中。在 runjs 函数中，css 选择器仅适用于设置第一个滑块输入的样式。

library(shiny)
library(shinydashboard)
library(shinyjs)

ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "test"),
                    dashboardSidebar(
                      sidebarMenu(
                        menuItem("Complete", tabName = "comp"))),
                    dashboardBody(
                      shinyjs::useShinyjs(),
                      tabItems(
                        tabItem(tabName = "comp",
                                fluidRow(
                                  div(id="range_var_css",
                                    sliderInput("range_var", "", value = c(90,100), min = 0, max = 100, width = '200%')
                                    ),
                                  div(id="range_var_css1",
                                    sliderInput("range_var1", "", value = c(90,100), min = 0, max = 100, width = '200%')
                                    )

                                  ))))
)

server <- function(input, output, session) { 
  observeEvent(input$range_var, {
    if (input$range_var[1] <= 40) {
      runjs(paste0('$("#range_var_css .irs-bar").css("background-color"," red")'))
    }
    if (input$range_var[1] > 40 & input$range_var[1] < 60) {
      runjs(paste0('$("#range_var_css .irs-bar").css("background-color"," blue")'))
    }
    if (input$range_var[1] > 60 & input$range_var[1] < 100) {
      runjs(paste0('$("#range_var_css .irs-bar").css("background-color"," green")'))
    }
  })
}

要将滑块输入完全设置为您想要的颜色，您还必须将滑块的边框底部和边框顶部的 css 更改为类似的内容：

    if (input$range_var[1] <= 40) {
      runjs(paste0('$("#range_var_css .irs-bar").css({
"background-color": "red", 
"border-top": "1px solid red", 
"border-bottom": "1px solid red"})'))
}