如何在R Shiny中对数据帧进行条件格式化？

时间：2014-04-03 23:02:44

标签： r formatting conditional shiny

使用Excel，您可以轻松地在单元格上应用条件格式：

enter image description here

你有没有机会用Shiny做这样的事情？我已经浏览了tutorials，但这显然没有被覆盖。

例如，我想有条件地为perm中的runExample("02_text")行着色：

enter image description here

3 个答案:

答案 0 :(得分：5)

您可以使用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（烫发）。

我们需要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')

答案 1 :(得分：0)

查看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")
    )
  ))
  )

Output

答案 2 :(得分：-1)

我在Shiny DataTables中进行了单元格着色，我认为这是jQuery的底层，使用下面的代码进行options调用的renderDataTable部分：

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

我定义了一个颜色范围列表，例如“regular”，“strict”等，并在下面的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)
}
相关问题
最新问题