R shiny renderTable - conditional formatting

Question

Looking for some help adding conditional formatting to a renderTable in R Shiny. I'm using renderTable instead of DT package renderDataTable because I have a dataframe of over 400 columns. DT was choking on the rendering, but renderTable seems to work very quickly.

Here is an example:

if (interactive()) {
  library(DT)
  
  fruit <- c("Apple", "Orange", "Pear", "Banana")
  num <- c(54, 25, 51, 32)
  Oct2020 <- c(10, 15, 20, 25)
  Nov2020 <- c(5, 7, 10, 15)
  Dec2020 <- c(7, 9, 12, 17)
  Jan2021 <- c(6, 9, 2, 0)
  Feb2021 <- c(15, 30, 12, 2)
  Mar2021 <- c(6, 7, 8, 10)
  
  data <- data.frame(fruit, num, Oct2020, Nov2020, Dec2020, Jan2021, Feb2021, Mar2021)
  
  ui <- fluidPage(
    fluidRow(
      column(width = 1, numericInput("numFruit", "Number of Fruit", value = 10)),
      column(width = 1, div(style = "margin-top: 25px", actionButton("btnUpdate", "Update")))
    ),
    
    fluidRow(
      div(style = 'height: 200px; width: 500px; overflow: scroll; font-size: 90%', align = "left", tableOutput("dt_Fruit"))  
    )
  )
  
  server <- function(input, output, session) {
    output$dt_Fruit <- renderTable(data, striped = TRUE, hover = TRUE, bordered = TRUE)
  }
  shinyApp(ui, server)
}

Depending on the value in numFruit, the Update button will shade the background of all the cells green where the value is >= input$numFruit.

Answer 1

Here is a way, improving by my old answer here.

library(shiny)
library(xtable)

colortable <- function(htmltab, css){
  CSSclass <- gsub("^[\\s+]|\\s+$", "", gsub("\\{.+", "", css))
  CSSclassPaste <- gsub("^\\.", "", CSSclass)
  CSSclass2 <- paste0(" ", CSSclass)
  classes <- paste0("<td class='", CSSclassPaste, "'")
  tmp <- strsplit(gsub("</td>", "</td>\n", htmltab), "\n")[[1]] 
  for(i in 1:length(CSSclass)){
    locations <- grep(CSSclass[i], tmp)
    tmp[locations] <- gsub("<td", classes[i], tmp[locations])
    tmp[locations] <- gsub(CSSclass2[i], "", tmp[locations], fixed = TRUE)
  }
  htmltab <- paste0(tmp, collapse="\n")
  Encoding(htmltab) <- "UTF-8"
  HTML(htmltab)
}

yellowify <- function(tbl, threshold){
  indices <- which(tbl >= threshold, arr.ind = TRUE)
  tbl[indices] <- paste0(tbl[indices], " .bgyellow")
  tbl
}

HTMLtbl <- function(tbl, threshold){
  print(
    xtable(yellowify(tbl, threshold)), type ="html", 
    html.table.attributes = c("border=1 class='table-condensed table-bordered'"), 
    print.results = FALSE, comment = FALSE
  )
}

# Shiny app ####

css <- c(
  ".bgred {background-color: #FF0000;}",
  ".bgblue {background-color: #0000FF;}",
  ".bgyellow {background-color: #FFFF00;}"
)

ui <- fluidPage(
  tags$head(
    tags$style(HTML(css))
  ),
  br(),
  sidebarLayout(
    sidebarPanel(
      sliderInput("threshold", "Threshold", min=0, max=5, value=2.5, step=0.1)
    ),
    mainPanel(
      uiOutput("coloredTable")
    )
  )
)

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

  tbl <- as.matrix(iris[1:6, 1:3])
  
  output[["coloredTable"]] <- renderUI({
    colortable(HTMLtbl(tbl, input[["threshold"]]), css)
  })
  
}

shinyApp(ui, server)

Answer 2

Another option for you using two for loops to look through the table and style the relevant cells with a green background in html

if (interactive()) {
  library(DT)
  
  fruit <- c("Apple", "Orange", "Pear", "Banana")
  num <- c(54, 25, 51, 32)
  Oct2020 <- c(10, 15, 20, 25)
  Nov2020 <- c(5, 7, 10, 15)
  Dec2020 <- c(7, 9, 12, 17)
  Jan2021 <- c(6, 9, 2, 0)
  Feb2021 <- c(15, 30, 12, 2)
  Mar2021 <- c(6, 7, 8, 10)
  
  data <- data.frame(fruit, num, Oct2020, Nov2020, Dec2020, Jan2021, Feb2021, Mar2021)
  
  ui <- fluidPage(
    fluidRow(
      column(width = 1, numericInput("numFruit", "Number of Fruit", value = 10)),
      column(width = 1, div(style = "margin-top: 25px", actionButton("btnUpdate", "Update")))
    ),
    
    fluidRow(
      tableOutput("dt_Fruit")
    )
  )
  
  server <- function(input, output, session) {
    
    values <- reactiveValues(data = data, data2 = data)
    
    observeEvent(input$btnUpdate, {
      
      data2 <- values$data
      num_lim <- input$numFruit
      for (r in 1:nrow(data)){
        for (c in 3:ncol(data)){
          if(data[r,c] > num_lim){
            data2[r,c] <- paste0('<div style="background-color: green;"><span>', data[r,c], '</span></div>')
          }
        }
      }
      values$data2 <- data2
      
    })
    output$dt_Fruit <- renderTable({values$data2 }, sanitize.text.function = function(x) x)
  }
  shinyApp(ui, server)
}