0

Following on from this question can someone please tell me how to change the background colour of checkbox items according to the dynamic colour picker (as per the below example) in shiny using css please?

Example:

## load iris dataset
data(iris)
cats <- levels(iris$Species)

## colourInput ---- create list of shiny inputs for UI
ids <-  paste0("col", seq(3))
cols <- c("red", "blue", "yellow")
foo <- function(x) {colourInput(ids[x], cats[x], cols[x])}
my_input <- lapply(seq(ids), foo)

## css styling for selectizeInput menu
CSS <- function(values, colors){
  template <- "
.checkbox[data-value=%s] {
  background: %s !important;
  color: white !important;
  padding: 5px;
  margin-bottom: 10px;
}"
  paste0(
    apply(cbind(values, colors), 1, function(vc){
      sprintf(template, vc[1], vc[1], vc[2])
    }),
    collapse = "\n"
  )
}
css <- CSS(cats, cols[seq(cats)])



## ------ shiny app ------
runApp(shinyApp(
  
  ui = fluidPage(
    tabsetPanel(type = "tabs",
                tabPanel("Dataset", id = "data",
                         tags$head(
                           uiOutput("css")
                         ),
                         checkboxGroupButtons(
                           inputId = "species",
                           label = "Labels",
                           choices = cats,
                           justified = TRUE,
                           direction ="vertical",
                           checkIcon = list(
                             yes = icon("ok", 
                                        lib = "glyphicon"))
                         ),
                         plotOutput("scatter")
                ),
                tabPanel("Colour Menu", id = "colmenu",
                         my_input)
    )
  ),
  
  server = function(input, output, session) {  
    
    ## get coords according to selectizeInput 
    mrkSel <- reactive({
      lapply(input$species,
             function(z) which(iris$Species == z))
    })
    
    ## colours selected by user in colourPicker
    cols_user <- reactive({
      sapply(ids, function(z) input[[z]])
    })
    
    ## update scatter colours
    scattercols <- reactive({
      cols_user()[sapply(input$species, function(z) 
        which(cats == z))]
    })
    
    ## scatter plot is conditional on species selected
    output$scatter <- renderPlot({
      plot(iris$Petal.Length, iris$Petal.Width, pch=21)
      if (!is.null(input$species)) {
        for (i in 1:length(input$species)) {
          points(iris$Petal.Length[mrkSel()[[i]]], iris$Petal.Width[mrkSel()[[i]]], 
                 pch = 19, col = scattercols()[i])
        }
      }
    }) 
    
    ## update colours
    output$css <- renderUI({
      tags$style(HTML(CSS(cats, cols_user())))
    })
    
  }
)
)
> sessionInfo()
R version 4.0.0 (2020-04-24)
Platform: x86_64-apple-darwin17.0 (64-bit)
Running under: macOS High Sierra 10.13.6

Matrix products: default
BLAS:   /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib

locale:
[1] en_GB.UTF-8/en_GB.UTF-8/en_GB.UTF-8/C/en_GB.UTF-8/en_GB.UTF-8

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

other attached packages:
 [1] rsconnect_0.8.16    shinyWidgets_0.5.3  dendextend_1.13.4  
 [4] tidyr_1.1.0         patchwork_1.0.1     ggplot2_3.3.1      
 [7] shinyhelper_0.3.2   colorspace_1.4-1    colourpicker_1.0   
[10] shinythemes_1.1.2   DT_0.13             shiny_1.4.0.2      
[13] dplyr_1.0.0         MSnbase_2.14.2      ProtGenerics_1.20.0
[16] S4Vectors_0.26.1    mzR_2.22.0          Rcpp_1.0.4.6       
[19] Biobase_2.48.0      BiocGenerics_0.34.0
lmsimp
  • 882
  • 7
  • 22

1 Answers1

2
CSS <- function(colors){
  template <- "
.checkboxGroupButtons div.btn-group:nth-child(%s) button {
  background: %s !important;
  color: white !important;
}"
  paste0(
    apply(cbind(seq_along(colors), colors), 1, function(vc){
      sprintf(template, vc[1], vc[2])
    }),
    collapse = "\n"
  )
}


output$css <- renderUI({
  tags$style(HTML(CSS(cols_user())))
})
Stéphane Laurent
  • 75,186
  • 15
  • 119
  • 225
  • this worked brilliantly for well over a year, but now no longer works! I assuming there has been some package updates to `shinyWidgets` or `shinyjs` but I can't figure it out. Any help you can give, I would be so grateful! – lmsimp Jan 24 '22 at 11:37
  • Now fixed - I'll update the answer (or if you could please). `shinyWidgets` changed the class name from `checkboxGroupButtons` to `checkbox-group-buttons` in [this commit](https://github.com/dreamRs/shinyWidgets/commit/64282a25f4a833620ef1fff67239e2253f37d5ac#diff-d0bcbea96ece6220a9d1c8b569807cac3a3817c2a29cbf5c719f8a47a7bd3e28L66) – lmsimp Jan 24 '22 at 11:44
  • This doesn't seem to be working at present. – jzadra Oct 04 '22 at 15:56
  • Does this not require a uiOutput or renderUI in the ui()? – jzadra Oct 05 '22 at 21:50