How to have conditional formatting of data frames

问题:

With Excel, you can easily apply conditional formatting over cells:

Is there any chance you can do something like this with Shiny? I've gone through the tutorials, but this apparently is not covered.

For instance, I'd like to conditionally colour the perm row in runExample("02_text"):

回答1:

You can conditionnal formatting your table using jQuery.

For example :

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

In tbody tr td:nth-child(5) I precise nth-child(5) To loop on each td of the 5th column only (perms).

We need session$onFlushed(function() { session$sendCustomMessage(type='jsCode', list(value = script)) }) because if you put the script in the head, it will be executed before the table output rendered and then nothing will be formatting.

If you want more formatting I suggest you to create css classes and use 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')

回答2:

Take a look at this related thread, which provides options for conditional formatting with cutoff points (with a similar approach to Julien's answer to this question).

Cross-posting from that thread: To achieve conditional formatting with gradients based on cell values (for instance, to produce a heat map within a data table) you can combined the above approach with the approach taken in this Jquery blog post.

Note that this example asks you to define a max and min manually, but you can also create an array of all of your values and dynamically find the min and max for your data: see step 1 in this post.

Borrowing from 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:

I got cell colouring in Shiny DataTables, which I believe is jQuery under the hood, using this code below for the options part of the renderDataTable call:

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

I defined a list of colour ranges, like "regular", "strict", etc and had them in this colouring_datatables function below:

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