javascript - 如何根据列中的条件更改数据表行背景颜色，Rshiny

Question

我有一个实时日志文件在运行，它监听数据库并在顶部呈现最近更新的数据表。然而，在花了一些时间之后，我卡在了如何使用 if 语句更改背景颜色上，因为我不熟悉 Javascript。

1) a) 当我的“测试”列为“通过”时，如何将背景颜色更改为绿色。 b) 当它的“Aggr”时为红色 c) 当它的“Bad”时为灰色。我看过R shiny colour dataframe和 How to have conditional formatting of data frames in R Shiny?我可以将 scipt 修改为类似这样的内容

script <- "$('tbody tr td:nth-child(1)').each(function() {

          var cellValue = $(this).text();

          if (cellValue == "Pass") {
            $(this).parent().css('background-color', 'green');
          }
          else if (cellValue == "Aggr") {
            $(this).parent().css('background-color', 'red');
          }
          else if (cellValue == "Bad") {
            $(this).parent().css('background-color', 'grey');
          }

        })"

但这只会执行一次。我也调查了这个 r shiny: highlight some cells但是库给了我一个错误 Error: package ‘ReporteRsjars’ could not be loaded 并且我也无法安装那个包来走这条路。

可能的解决方案:

i) 我可以使用 shinyBS 将我的日志表更改为文本输出并在那里更改颜色库或其他一些工具，这里有一个很好的例子 ChatRoom在 Rshiny 画廊。

ii) 我可以使用 googlevis 包，但是我会面临每次迭代都重新打印表格的问题(与此处所做的相同，但它并不“引人注目”)。

2) 如何仅在添加新点时呈现我的数据表输出。例如。如果没有任何变化，我不想再次重新打印数据表？

提前致谢...

我的示例代码如下

rm(list = ls())
library(shiny)
options(digits.secs=3) 

test_table <- cbind(rep(as.character(Sys.time()),2),rep('a',2),rep('b',2),rep('b',2),rep('c',2),rep('c',2),rep('d',2),rep('d',2),rep('e',2),rep('e',2))
colnames(test_table) <- c("Time","Test","T3","T4","T5","T6","T7","T8","T9","T10")

ui =navbarPage(inverse=TRUE,title = "Real-Time Logs",
               tabPanel("Logs",icon = icon("bell"),
                        mainPanel(htmlOutput("logs"))),
               tabPanel("Logs 2",icon = icon("bell")),
               tabPanel("Logs 3",icon = icon("bell")),
               tags$head(tags$style("#logs {height:70vh;width:1000px;!important;text-align:center;font-size:12px;}")),
               tags$style(type="text/css", "#logs td:nth-child(1) {height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(2) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(3) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(4) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(5) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(6) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(7) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(8) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(9) {width:70px;height:20px;font-size:12px;text-align:center}"),
               tags$style(type="text/css", "#logs td:nth-child(10) {width:70px;height:20px;font-size:12px;text-align:center}")
)
server <- (function(input, output, session) {
  autoInvalidate1 <- reactiveTimer(1000,session)

  my_test_table <- reactive({
    autoInvalidate1()
    other_data <- rbind(c(as.character(Sys.time()),(sample(c("Pass","Aggr","Bad"))[1]),round(c(rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1)),2)),  
                        (c(as.character(Sys.time()),(sample(c("Pass","Aggr","Bad"))[1]),round(c(rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1)),2))))
    test_table <<- rbind(apply(other_data, 2, rev),test_table)
    as.data.frame(test_table) 
  })
  output$logs <- renderTable({my_test_table()},include.rownames=FALSE)

})

runApp(list(ui = ui, server = server))

Answer 1

您可以添加自定义消息，您可以使用 session$onFlushed 方法调用该消息。为了使示例简洁，我删除了格式和额外的标签。首先是脚本并调用 shiny。注意我们等同于 "Pass " 而不是 "Pass" 等，因为 xtable 似乎添加了额外的间距:

library(shiny)
options(digits.secs=3) 
script <- "
els = $('#logs tbody tr td:nth-child(2)');
console.log(els.length);
els.each(function() {
          var cellValue = $(this).text();
          if (cellValue == \" Pass \") {
            $(this).parent().css('background-color', 'green');
          }
          else if (cellValue == \" Aggr \") {
            $(this).parent().css('background-color', 'red');
          }
          else if (cellValue == \" Bad \") {
            $(this).parent().css('background-color', 'grey');
          }
        });"
test_table <- cbind(rep(as.character(Sys.time()),2),rep('a',2),rep('b',2),rep('b',2),rep('c',2),rep('c',2),rep('d',2),rep('d',2),rep('e',2),rep('e',2))
colnames(test_table) <- c("Time","Test","T3","T4","T5","T6","T7","T8","T9","T10")

和应用

ui =navbarPage(inverse=TRUE,title = "Real-Time Logs",
               tabPanel("Logs",icon = icon("bell"),
                        mainPanel(
                          htmlOutput("logs"))
                        , tags$script(sprintf('
                          Shiny.addCustomMessageHandler("myCallback",
                            function(message) {
                                 %s
                            });
                          ', script)
                        )
                        )
)
server <- (function(input, output, session) {
  autoInvalidate1 <- reactiveTimer(3000,session)
  my_test_table <- reactive({
    autoInvalidate1()
    other_data <- rbind(c(as.character(Sys.time()),(sample(c("Pass","Aggr","Bad"))[1]),round(c(rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1)),2)),  
                        (c(as.character(Sys.time()),(sample(c("Pass","Aggr","Bad"))[1]),round(c(rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1)),2))))
    test_table <<- rbind(apply(other_data, 2, rev),test_table)
    session$onFlushed(function(){
      session$sendCustomMessage(type = "myCallback", "some message")
    })
    as.data.frame(test_table) 
  })
  output$logs <- renderTable({my_test_table()},include.rownames=FALSE)
})

runApp(list(ui = ui, server = server))

当您重新添加格式和额外的标签时，它看起来像: