[英]How to change Datatable row background colour based on the condition in a column, Rshiny
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.
但是花了一些时间在它上面我坚持如何用if语句改变背景颜色,因为我不熟悉Javascript。
1) a) How can I change the background colour to green whenever my "Test" Column is "Pass". 1) a)每当我的“测试”列为“通过”时,如何将背景颜色更改为绿色。 b) To red when its "Aggr" c) and grey when its "Bad".
b)当它的“Aggr”c)为红色而当它为“坏”时为灰色。 I have looked at R shiny colour dataframe and How to have conditional formatting of data frames in R Shiny?
我看过R闪亮的颜色数据帧和如何在R Shiny中对数据帧进行条件格式化? and I can modify the scipt to something like so
我可以将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');
}
})"
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. 我也调查了这个r闪亮:突出显示一些单元但是库给我一个错误
Error: package 'ReporteRsjars' could not be loaded
,我无法安装该包也是这样。
Possible solutions: 可能的解决方案:
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. i)我可以将我的Log表更改为textoutput并使用shinyBS库或其他工具更改颜色,这里是Rshiny gallery中ChatRoom的一个很好的例子。
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'). ii)我可以使用
googlevis
软件包,但是我会googlevis
每次迭代重新打印表格的问题(与此处完成相同,但不像'明显'那样)。
2) How can I render my datatable output only when new point is added to it. 2)如何仅在添加新点时才渲染我的数据表输出。 Eg I dont want to reprint the datatable again if nothing changed?
例如,如果没有改变,我不想再次重新打印数据表?
Thank you in advance... 先感谢您...
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))
You can add a custom message which you can call using the session$onFlushed
method. 您可以使用
session$onFlushed
方法添加可以调用的自定义消息。 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: Notuce我们等同于
" 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")
and the app 和应用程序
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: 当您在格式化和额外选项卡中添加回来时,它看起来像:
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.