Add different static colors for sliderbar in shiny dashboard

I am new to shiny. I would like to give static color for the slider bar irrespective of the range selected in shiny dashboard. I want to have different color for slider as follows, Ex: 0 to 40 – red, 40 to 60 – blue, 60 to 100 – green. Please help me solve this issue. My code,

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)

Thanks Balaji

2 answers

  • answered 2018-05-16 07:54 SeGa

    Have you checked out this package - shinyFeedback ?

    You can see some examples here.

    To use multiple feedbacks, you should write all the conditions in one observeEvent - although I didnt manage to make multiple feedbacks working.

    Here is the code example from that page for multiple feedbacks:

    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)
    

    Another option would be to use the shinyjs package, where you can run java-script and send css-code to the browser. You have to put useShinyjs() in the dashboardBody. The class "irs-bar" is used for all sliders in shiny, so if you want the behaviour only on a certain slider you would have to adapt the css selector (.irs-bar). (See next example). Here is a little example oh how you could achieve the desired behaviour:

    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)
    

    The following example shows how to style only one specific sliderInput. The sliderInputs are put in 2 divs with ids. In the runjs function the css selector is adapted to only style the first sliderInput.

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

    To fully style the sliderInput to your desired color, you also have to change the css of the border-bottom and border-top of the slider, to something like that:

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

  • answered 2018-05-16 09:57 SeGa

    Oh, then i misinterpreted your question. You can achieve this also by using css-commands and correct selectors:

    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)
    

  • installed shiny and shinydashboard with sudo and now, some of applications does not load

    I am on a server with ubuntu 16.04, R version 3.2.3. I have several shiny applications hosted. I updated shiny package and shiny dashboard package in R with sudo. Now, some of the applications work properly (as before) but some of them load with an error and this is the log:

    Listening on http://127.0.0.1:43323 Error in loadNamespace(i, c(lib.loc, .libPaths()), versionCheck = vI[[i]]) : there is no package called ‘promises’ Warning: Error in : package or namespace load failed for ‘shinydashboard’ Stack trace (innermost first): 41: library 1: runApp Error: An error has occurred. Check your logs or contact the app author for clarification.

    Execution halted

    I have updated the "promises" package with sudo, but nothing has changed. here is the sessionInfo():

    sessionInfo() R version 3.2.3 (2015-12-10) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 16.04.4 LTS

    locale: [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8 [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8 [7] LC_PAPER=en_US.UTF-8 LC_NAME=C [9] LC_ADDRESS=C
    LC_TELEPHONE=C [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C

    attached base packages: [1] stats graphics grDevices utils
    datasets methods base

    Even if I select one the working apps and copy the whole directory into a new one, the new copied application does not come up! there is no problem with applications, but I do not know what is the problem! please help

  • Shinydashboard: How to paste filtration in navbar instead of title?

    I want to paste filtration instead of title in navbar. How is it possible to do?

    In question here the filtration is placed right from the title. But in that case a button which collapses sidebar disappears. In this code I placed filtration instead of title but I still don't see the full list of items in widget.

    CustomHeader <- dashboardHeader()
    CustomHeader$children[[2]]$children <- list(
      div(style="padding: 7px; height: 30px;",
          selectInput("select1", NULL, c("a","b","c"))))
    
    ui <- dashboardPage(
      CustomHeader,
      dashboardSidebar(),
      dashboardBody(textOutput("text1"))
    )
    
    server <- function(input, output, session) {
      output$text1 <- renderText({input$select1})
    
    }
    
    shinyApp(ui, server)
    

    enter image description here