Create dynamic valueBox colour based on values in shinydashboard

Question

I want to write a shinydashboard app to reflect bed capacity in a hospital. In some of the valueBoxes, I would like the colour of the box to change depending on the number of empty beds (from green-orange-red).

I tried writing a reactive object but can't seem to get the colour to reflect the value the way I wanted to.

library(shiny)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Situation Report"),
  dashboardSidebar(

    menuItem("Night Capacity Report", tabName = "night_report", icon = icon("file-alt"))



  ), #/dashboardSidebar
  dashboardBody(
    tabItems(
      tabItem(tabName = "night_report", h3("Night Capacity Report"),

              fluidRow(
                box(title = "MEDICINE", width = 12,

                    fluidRow(
                      valueBoxOutput("au1_night", width = 3),
                      valueBoxOutput("w13_night", width = 3),
                      valueBoxOutput("w9_night", width = 3)
                    )

                )
              )
      )


    ) #/tabItems
  ) #/dashboardBody
) #/dashboardPage


server <- function(input, output){

  colour_empty_med_ward <- reactive({
    for (i in seq_along(night_medicine)) {


      if(night_medicine[[i, 3]] >= 10){
        colour_med <- "green"
      }else if(night_medicine[[i, 3]] >= 5 & night_medicine[[i, 3]] < 10){
        colour_med <- "orange"
      }else if(night_medicine[[i, 3]] < 5){
        colour_med <- "red"
      }

      return(colour_med)
    }
  })
}

output$au1_night <- renderValueBox({

  valueBox(
    "AU 1", paste0(night_medicine[[1,3]], "/", night_medicine[[1,2]]), icon = icon("bed"),
    color = colour_empty_med_ward()
  )
})

output$w13_night <- renderValueBox({
  valueBox(
    "Ward 13", paste0(night_medicine[[2,3]], "/", night_medicine[[2,2]]), icon = icon("bed"),
    color = colour_empty_med_ward()
  )
})

output$w9_night <- renderValueBox({
  valueBox(
    "Ward 9", paste0(night_medicine[[3,3]], "/", night_medicine[[3,2]]), icon = icon("bed"),
    color = colour_empty_med_ward()
  )
})

shinyApp(ui = ui, server = server)

The object to look up for the bed numbers is imported from an Excel file that is uploaded each time, but I have attached a dput sample here:

> dput(night_medicine)
structure(list(Ward = c("AU1", "13", "9", "22", "23", "32", "33", 
"34", "41", "42", "43", "44", "51", "54", "Total"), Compliment = c("37", 
"12", "7", "20", "26", "23", "10", "16", "22", "24", "30", "30", 
"10", "7", "274"), Empty = c("0", "10", "5", "1", "2", "2", "0", 
"6", "0", "6", "0", "0", "0", "1", "33")), row.names = c(NA, 
-15L), class = c("tbl_df", "tbl", "data.frame"))

I am still fairly new to this and I am struggling to find a way to get around this. I can write separate reactive object for each ward, however there are so many in the actual file, I wonder if I can get around it somehow like using a successful version of colour_empty_med_ward().

Answer 1

Could you make colour_empty_med_ward a plain function that takes an argument with the value to use for color? (In this case, you could simplify and use cut shown here).

colour_empty_med_ward <- function(night_medicine) {
  cut(as.numeric(night_medicine), breaks=c(-Inf, 5, 10, Inf), labels=c("red","orange","green"), right = FALSE)
}

Then in server your output can call the function and send it the appropriate night_medicine value.

server <- function(input, output){

  output$au1_night <- renderValueBox({
    valueBox(
      "AU 1", paste0(night_medicine[[1,3]], "/", night_medicine[[1,2]]), icon = icon("bed"),
      color = colour_empty_med_ward(night_medicine[[1,3]])
    )
  })

  output$w13_night <- renderValueBox({
    valueBox(
      "Ward 13", paste0(night_medicine[[2,3]], "/", night_medicine[[2,2]]), icon = icon("bed"),
      color = colour_empty_med_ward(night_medicine[[2,3]])
    )
  })

  output$w9_night <- renderValueBox({
    valueBox(
      "Ward 9", paste0(night_medicine[[3,3]], "/", night_medicine[[3,2]]), icon = icon("bed"),
      color = colour_empty_med_ward(night_medicine[[3,3]])
    )
  })
}