如何在 R Shiny 中对数据帧进行条件格式设置？
Posted
技术标签:
【中文标题】如何在 R Shiny 中对数据帧进行条件格式设置？【英文标题】：How to have conditional formatting of data frames in R Shiny? 【发布时间】：2014-05-16 01:04:34 【问题描述】：使用 Excel，您可以轻松地对单元格应用条件格式：
你有没有机会用 Shiny 做这样的事情？我已经通过tutorials，但这显然没有涵盖。
例如，我想有条件地为runExample("02_text") 中的perm 行着色：
【问题讨论】：
不是真正的 Shiny 相关（尽管我知道为什么会这样想）和更多ggplot-related 和 ***.com/questions/8784095/… 的可能副本
对于“低于”形式的条件，您可以使用 shinyBS 包。
【参考方案1】：
您可以使用 jQuery 为表格设置条件格式。
例如：
library(shiny)
library(datasets)
script <- "$('tbody tr td:nth-child(5)').each(function()
var cellValue = $(this).text();
if (cellValue > 50)
$(this).css('background-color', '#0c0');
else if (cellValue <= 50)
$(this).css('background-color', '#f00');
)"
runApp(list(
ui = basicPage(
tags$head(tags$script(html('Shiny.addCustomMessageHandler("jsCode", function(message) eval(message.value); );'))),
tableOutput("view")
),
server = function(input, output, session)
session$onFlushed(function()
session$sendCustomMessage(type='jsCode', list(value = script))
)
output$view <- renderTable(
head(rock, n = 20)
)
))
在tbody tr td:nth-child(5) 中，我精确到nth-child(5) 仅循环第5 列的每个td（perms）。
我们需要session$onFlushed(function()
session$sendCustomMessage(type='jsCode', list(value = script))
)，因为如果您将脚本放在头部，它将在表格输出呈现之前执行，然后什么都不会格式化。
如果您想要更多格式，我建议您创建 css 类并使用addClass：
### In the UI :
tags$head(tags$style(
".greenCell
background-color: #0c0;
.redCell
background-color: #f00;
"))
### In th script
### use .addClass instead of .css(...)
$(this).addClass('greenCell')
【讨论】：
我试图在一个更复杂的闪亮应用程序中做同样的事情，其中表位于 renderUI 函数中，但没有成功。问题是否可能是表格的内容是字符？如果是这样，您如何修改脚本以将字符转换为数字？ 你不能用as.numeric函数把你的字符转换成数字吗？
也许您可以在数值测试之前测试并在测试之后将它们格式化为百分比？或提供您的应用示例。
恐怕还有别的问题。我刚刚尝试了您发布的相同示例，但将 head(rock, n = 20) 替换为 head(rock,c(1,2),as.character), n = 20) 并且表格的格式仍然正确。一定是导致问题的其他原因。
head(rock,c(1,2),as.character), n = 20) 这是怎么回事？ ~~ 我认为你应该用你自己的例子创建另一个帖子。【参考方案2】：
看看this related thread，它提供了带有截止点的条件格式选项（similar approach 到Julien's answer to this question）。
Cross-posting from that thread：要实现基于单元格值的渐变条件格式（例如，在数据表中生成热图），您可以将上述方法与approach taken in this Jquery blog post 结合使用。
请注意，此示例要求您手动定义最大值和最小值，但您也可以创建一个包含所有值的数组并动态查找数据的最小值和最大值：请参阅 step 1 in this post。
借用jdharrison's self contained example:
library(shiny)
library(datasets)
script <- "
// Set min and max for gradient
var min = 0;
var max = 100;
var n = max-min
// Define the min colour, which is white
xr = 255; // Red value
xg = 255; // Green value
xb = 255; // Blue value
// Define the max colour #2ca25f
yr = 44; // Red value
yg = 162; // Green value
yb = 95; // Blue value
$('tbody tr td:nth-child(5)').each(function()
var val = parseInt($(this).text());
// Catch exceptions outside of range
if (val > max)
var val = max;
else if (val < min)
var val = min;
// Find value's position relative to range
var pos = ((val-min) / (n-1));
// Generate RGB code
red = parseInt((xr + (( pos * (yr - xr)))).toFixed(0));
green = parseInt((xg + (( pos * (yg - xg)))).toFixed(0));
blue = parseInt((xb + (( pos * (yb - xb)))).toFixed(0));
clr = 'rgb('+red+','+green+','+blue+')';
// Apply to cell
$(this).css('background-color', clr);
)"
runApp(list(server = function(input, output, session)
session$onFlushed(function()
session$sendCustomMessage(type='jsCode', list(value = script))
, FALSE)
output$view <- renderTable(
head(rock, n = 20)
)
output$Test1 <- renderUI(
list(
tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode", function(message) eval(message.value); );')))
, tableOutput("view")
)
)
, ui = fluidPage(
tabsetPanel(
tabPanel("Test1",uiOutput("Test1")),
tabPanel("Test2")
)
))
)
【讨论】：
【参考方案3】：我在 Shiny DataTables 中获得了单元格着色，我相信它是 jQuery 的底层，使用下面的代码作为 renderDataTable 调用的 options 部分：
options = list(fnRowCallback = I(colouring_datatables(do_colouring=do_colouring,c("regular","strict","strict","regular","strict","regular","regular","regular"),c(8,9,10,11,12,13,14,15))), bSortClasses = TRUE, aaSorting=list(list(3, "desc")), aLengthMenu = list(c(10, 25, 50, 100, -1), c('10', '25', '50', '100', 'All')),
"sDom" = 'RMDT<"cvclear"C><"clear">lfrtip',
"oTableTools" = list(
"sSwfPath" = "copy_csv_xls.swf",
"aButtons" = list(
"copy",
"print",
list("sExtends" = "collection",
"sButtonText" = "Save",
"aButtons" = list("xls","csv")
)
)
)
)
我定义了一个颜色范围列表，例如“常规”、“严格”等，并将它们放在下面的 colouring_datatables 函数中：
colouring_datatables = function(do_colouring = TRUE, apply_ranges,apply_columns)
string = ''
callback_init = ""
callback_ends = ""
function_init = 'function(nRow, aData, iDisplayIndex, iDisplayIndexFull) '
function_ends = ''
# highviz
#regular$colour = c("#FF0000","#FF3800","#FF7100","#FFAA00","#FFE200","#E2FF00","#AAFF00","#71FF00","#38FF00","#00FF00")
# Semaphore: only three colours
semaphore = list()
semaphore$from = c(0.000 ,0.500 ,0.750 )
semaphore$to = c(0.500 ,0.750 ,1.100 )
semaphore$colour = c("#F7977A","#FFF79A","#82CA9D")
# Strict: ten colours with most granularity around 0.900 and 1.000
strict = list()
strict$from = c(0.000 ,0.500 ,0.800 ,0.900 ,0.960 ,0.970 ,0.975 ,0.980 ,0.985 ,0.990 )
strict$to = c(0.500 ,0.800 ,0.900 ,0.960 ,0.970 ,0.975 ,0.980 ,0.985 ,0.990 ,1.100 )
strict$colour = c("#F7977A","#F3AC7B","#F0C07C","#ECD27D","#E8E27E","#D8E47F","#C3E180","#B0DD80","#9FD981","#8FD581")
# Regular: ten colours with most granularity between 0.800 and 0.900
regular = list()
regular$from = c(0.000 ,0.500 ,0.700 ,0.800 ,0.860 ,0.870 ,0.875 ,0.880 ,0.885 ,0.890 )
regular$to = c(0.500 ,0.700 ,0.800 ,0.860 ,0.870 ,0.875 ,0.880 ,0.885 ,0.890 ,1.100 )
regular$colour = c("#F7977A","#F3AC7B","#F0C07C","#ECD27D","#E8E27E","#D8E47F","#C3E180","#B0DD80","#9FD981","#8FD581")
# Linear: twenty colours with linear scale from 0.000 to 1.000
linear = list()
linear$from = c(0.000 ,0.050 ,0.100 ,0.150 ,0.200 ,0.250 ,0.300 ,0.350 ,0.400 ,0.450 ,0.500 ,0.550 ,0.600 ,0.650 ,0.700 ,0.750 ,0.800 ,0.850 ,0.900 ,0.950 )
linear$to = c(0.050 ,0.100 ,0.150 ,0.200 ,0.250 ,0.300 ,0.350 ,0.400 ,0.450 ,0.500 ,0.550 ,0.600 ,0.650 ,0.700 ,0.750 ,0.800 ,0.850 ,0.900 ,0.950 ,1.100 )
linear$colour = c("#F7967A","#F4A47A","#F2B17B","#EFBE7C","#EDC97C","#EBD47D","#E8DF7D","#E4E67E","#D6E47F","#C9E17F","#BCDF7F","#B1DC80","#A5DA80","#9BD880","#91D581","#87D381","#81D184","#81CE8D","#81CC95","#82CA9D")
# Twenty: twenty colours with most granularity between 0.700 and 1.000
twenty = list()
twenty$from = c(0.000 ,0.200 ,0.300 ,0.400 ,0.500 ,0.700 ,0.720 ,0.740 ,0.760 ,0.780 ,0.800 ,0.820 ,0.840 ,0.860 ,0.880 ,0.900 ,0.920 ,0.940 ,0.960 ,0.980 )
twenty$to = c(0.200 ,0.300 ,0.400 ,0.500 ,0.700 ,0.720 ,0.740 ,0.760 ,0.780 ,0.800 ,0.820 ,0.840 ,0.860 ,0.880 ,0.900 ,0.920 ,0.940 ,0.960 ,0.980 ,1.100 )
twenty$colour = c("#F7967A","#F4A47A","#F2B17B","#EFBE7C","#EDC97C","#EBD47D","#E8DF7D","#E4E67E","#D6E47F","#C9E17F","#BCDF7F","#B1DC80","#A5DA80","#9BD880","#91D581","#87D381","#81D184","#81CE8D","#81CC95","#82CA9D")
ranges = list()
ranges[["semaphore"]] = semaphore
ranges[["strict"]] = strict
ranges[["regular"]] = regular
ranges[["linear"]] = linear
ranges[["twenty"]] = twenty
string = paste0(string, callback_init)
string = paste0(string, function_init)
if (do_colouring)
for (i in 1:length(apply_columns))
for (idx in 1:length(ranges[[apply_ranges[i]]]$from))
this = list()
this$column = apply_columns[i]
this$from = ranges[[apply_ranges[i]]]$from[idx]
this$to = ranges[[apply_ranges[i]]]$to[idx]
this$colour = ranges[[apply_ranges[i]]]$colour[idx]
string = paste0(string,'if (parseFloat(aData[',this$column,']) >= ',this$from,' && parseFloat(aData[',this$column,']) < ',this$to,') $("td:eq(',this$column,')", nRow).css("background-color", "',this$colour,'"); ')
string = paste0(string, function_ends)
string = paste0(string, callback_ends)
return(string)
【讨论】：
以上是关于如何在 R Shiny 中对数据帧进行条件格式设置？的主要内容，如果未能解决你的问题，请参考以下文章
在 R Shiny Server 中对文本进行样式化或格式化
如何在Shiny中对radioButtons的数据进行不同的处理？