R闪亮的renderTable - 条件格式

Question

寻求一些帮助，将条件格式添加到 R Shiny 中的 renderTable。我使用renderTable 而不是DT 包renderDataTable 因为我有一个超过400 列的数据框。 DT 渲染时卡住了，但 renderTable 似乎工作得很快。

这是一个例子：

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

根据numFruit 中的值，更新 按钮会将值>= input$numFruit 的所有单元格的背景变为绿色。

Answer 1

这是一种方法，通过我的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

另一种选择是使用两个 for 循环来查看表格并在 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)
}