Dynamically change the class of a bslib value box in Shiny

Question

I use a value_box from the bslib-package to display values in a Shiny dashboard. The shown value depends on user input via various selectors which requires me to dynamically update the value box. This works well for the title and value using the approach outlined here.

However, I also want to change the class of the value box depending on the value: E.g. if the value is below a certain threshold, show a red value box, if it's high show a green one.

Here's an MWE to illustrate my approach:

library(tidyverse)
library(shiny)
library(bslib)

test_df <- tibble(id = 1:2, 
                  title = c("low value","high value"), 
                  value = c(30, 80))

ui <- page_fixed(
  selectInput("select_id", "Selected ID", choices = 1:2, selected = 1),
  value_box(title = textOutput("vbox_title"),
            value = textOutput("vbox_value"),
            class = textOutput("vbox_class")
  ),
)

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

  subset_df <- reactive({
    test_df %>%
      filter(id == input$select_id)
  })
  
  output$vbox_title <- renderText({
    subset_df() %>%
      pull(title)
  })

  output$vbox_value <- renderText({
    subset_df() %>%
      pull(value)
  })
  
  output$vbox_class <- renderText({
    value <- subset_df() %>%
      pull(value)
  
    ifelse(value > 50, "bg-success", "bg-warning")
  })
}

shinyApp(ui, server)

Unfortunately, the text output for the class gets processed as div list(id = "vbox_class", class = "shiny-text-output") list() and I cannot figure out how to just pass the raw string to the class argument. I have already tried using verbatimTextOutput() and transforming the output with as.character(), both unsuccessfully.

I realize it would be easier to just create the value boxes inside the server function with the appropriate class. But in my real application I actually need the value box to persist since it contains other elements that are not updated.

Is there a way to remove the container from textOutput() to make this work? Or does changing the class require the use of style tags?

Answer 1

One easy solution to dynamically change the css class would be to use shinyjs. To use this, you would need to:

1. call useShinyjs in the UI
2. add an id to your card
3. get a reactive of the value : ie value
4. update the css in the server

It would look something like that:

library(shinyjs)

test_df <- tibble(id = 1:2, 
                  title = c("low value","high value"), 
                  value = c(30, 80))

ui <- page_fixed(
  # invoce Shinyjs:
  useShinyjs(), 
  selectInput("select_id", "Selected ID", choices = 1:2, selected = 1),
  value_box(id = "card1", # set an ID
            title = textOutput("vbox_title"),
            value = textOutput("vbox_value"),
            class = NULL
  )
)

server <- function(input, output, session) {
  
  subset_df <- reactive({
    test_df %>%
      filter(id == input$select_id)
  })
  # Pull reactive here:
  value <- reactive({subset_df() %>% pull(value)})
  
  output$vbox_value <- renderText({
    value()
  })
  
  output$vbox_title <- renderText({
    subset_df() %>%
      pull(title)
  })

  #update CSS class
  observeEvent(value(),{
    if (value() > 50) {
      removeCssClass(id = "card1", class = "bg-warning")
      addCssClass(id = "card1",class = "bg-success")
    }else if(value() <= 50){
      removeCssClass(id = "card1", class = "bg-success")
      addCssClass(id = "card1",class = "bg-warning")
    }
  })

}
shinyApp(ui, server)

Another easy solution to the problem would be using renderUIand rendering the whole thing on the server. This would look somthing like that:

ui <- page_fixed(
  selectInput("select_id", "Selected ID", choices = 1:2, selected = 1),
  uiOutput("vbox")
)

server <- function(input, output, session) {
  
  subset_df <- reactive({
    test_df %>%
      filter(id == input$select_id)
  })
  output$vbox <- renderUI({
    value_box(
      title = subset_df()$title,
      value = subset_df()$value,
      class = ifelse(subset_df()$value > 50, "bg-success", "bg-warning")
    )
  })

}

shinyApp(ui, server)