如何根据列Rshiny中的条件更改可数据行背景颜色 [英] How to change Datatable row background colour based on the condition in a column, Rshiny

问题描述

我有一个实时日志文件运行，监听数据库，并在最上面的最近更新渲染一个数据。然而，花了一段时间后，它坚持如何改变背景颜色与if语句，因为我不熟悉Javascript。

I have a real-time log file running, that listens to the database and renders a datatable of the most recent updates on top. However after spending sometime on it im stuck on how to change the background colour with an if statement, as I am not familiar with Javascript.

1） a）当我的测试列为通过时，如何将背景颜色更改为绿色。
b）当它的Aggrc）为红色，而其Bad为灰色。我查看了 R闪光颜色数据帧
和如何在R Shiny中使用条件格式化数据框？和我可以修改scipt为这样

1) a) How can I change the background colour to green whenever my "Test" Column is "Pass". b) To red when its "Aggr" c) and grey when its "Bad". I have looked at R shiny colour dataframe and How to have conditional formatting of data frames in R Shiny? and I can modify the scipt to something like so

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闪亮：突出显示一些单元格，但是库给我一个错误错误：无法加载包'ReporteRsjars'，我也无法安装该包。

But this only does it once. I also looked into this r shiny: highlight some cells however the library gives me an error Error: package ‘ReporteRsjars’ could not be loaded and I cannot install that package to go this way either.

可能的解决方案：

i）我可以将我的日志表更改为textoutput和更改颜色，使用 shinyBS 库或其他工具，这里是一个很好的例子的Rshiny图库中的 ChatRoom 。

i) I can change my Log table into the textoutput and change colours there using shinyBS library or some other tools, theres a great example here of the ChatRoom in Rshiny gallery.

ii）我可以使用 googlevis 包，但是我会面临重新打印表的问题和它在这里做的一样，但它不是明显的）。

ii) I can go with googlevis package, however I would be facing issues with reprinting the table every iteration (same as its done here, however its not as 'noticeable').

2）仅当添加新点时，如何渲染我的数据输出。例如。

2) How can I render my datatable output only when new point is added to it. E.g. I dont want to reprint the datatable again if nothing changed?

提前感谢...

我想要重新打印日期表示例代码如下

My sample code is below

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

推荐答案

您可以添加自定义消息，您可以使用 session $ onFlushed 方法调用该消息。为了保持示例简洁，我删除了格式和额外的选项卡。首先是脚本和调用闪亮。 Notices我们等于Pass，而不是Pass等等，因为xtable似乎添加额外的间距： p>

You can add a custom message which you can call using the session$onFlushed method. To keep the example succinct I have removed formatting and extra tabs. First the script and call to shiny. Notuce we equate to " Pass " rather then "Pass" etc. as xtable seems to add extra spacing:

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

当您在格式化和其他选项卡中添加回来时：

When you add back in the formatting and extra tabs it looks like:

>

这篇关于如何根据列Rshiny中的条件更改可数据行背景颜色的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！