13

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

enter image description here

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

enter image description here

2
  • 1
    not really Shiny-related (though I can see why it might be thought of that way) and more ggplot-related and a possible duplicate of stackoverflow.com/questions/8784095/…
    – hrbrmstr
    Apr 4, 2014 at 0:34
  • For conditions having form "lower than" you can use the shinyBS package. Apr 6, 2014 at 13:33

3 Answers 3

6

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')
7
  • I am trying to do exactly the same thing in a more complex shiny app where the table is located within a renderUI function with no success. Is it possible that the problem might be that the contents of the table are characters? If this is so, how could you modify the script to convert the characters to numbers?
    – Christos
    Oct 2, 2014 at 12:08
  • Can't you cast your characters into numbers with the as.numeric function ? Oct 2, 2014 at 13:15
  • Maybe you can test before and format them as percentages after the test on numeric values ? Or provide an example of your app. Oct 2, 2014 at 13:21
  • I am afraid that something else must be the issue. I just tried the same example you posted but replaced head(rock, n = 20) with head(rock,c(1,2),as.character), n = 20) and the table is still correctly formatted. Must be something else that is causing the problem.
    – Christos
    Oct 2, 2014 at 13:25
  • head(rock,c(1,2),as.character), n = 20) how can this works ? ~~ I think you should create another post with your own example. Oct 2, 2014 at 13:35
0

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

Output

-1

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.