Shiny: use styleColorBar with data from two data frames

Question

I am trying to display a table in Shiny, where numbers will be displayed from one data.frame (or data.table), but the size of bars will be taken from another data.frame. For instance, absolute values will be displayed, but -log(p-values) from another table (identically arranged) will determine the width of color bars.

This is my mock code:

  output$pivot_table = DT::renderDataTable(
    dt <- datatable(

      {
        a <- data.frame(matrix(1, 20, 5))
        pval_data <- data.frame(matrix(rnorm(n = 100), 20, byrow = T))
        print(pval_data)
        a
      }

    ) %>% formatStyle(names(a),
                      background = styleColorBar(range(pval_data), 'lightblue'),
                      backgroundSize = '98% 88%',
                      backgroundRepeat = 'no-repeat',
                      backgroundPosition = 'center')
  )

printed pval_data:

            X1          X2          X3           X4          X5
1   0.968418606 -1.87152557  0.61937740 -0.143097511  0.65508855
2  -0.007557229  0.08118509  0.15390863  1.375011375  0.52879595
3  -0.310230367  0.24825819 -0.61521934  0.994227019  0.99756573
4  -0.347770895 -0.91282709  0.79575280  0.234287011 -1.24957553
5   1.699646126 -0.22895201  0.15979995  0.223626312 -1.61600316
6  -0.490930813  0.32298741 -0.81244643  0.474731264  0.09482891
7  -1.118480311  0.42816708 -1.60837688  0.923083220 -0.18504939
8  -0.613107600  0.85641186  0.50027453 -0.682282617  0.78146768
9  -1.191377934 -0.65435824  1.18932459 -0.698629523 -0.06541897
10 -1.149737780  2.47072440 -0.06468906 -0.150334405  1.23995530
11  0.877889198 -0.58012128  0.69443433  2.180587121 -1.32090173
12 -0.323477829 -1.46837648  1.38017226 -1.223060038  1.92034573
13 -1.016861096 -0.62798484  0.22159954 -1.601450990 -0.25184806
14  0.392432490 -0.42233004 -0.64490950 -1.491724171 -0.71931626
15 -1.270341425  0.79922671  0.82034852 -0.109127778 -0.73276775
16  0.713192323  1.01199542  1.08499699  0.328685928  0.98869534
17 -1.491903472 -0.40431848  0.47478220 -1.856996096  1.67946815
18 -0.089676087 -1.16068035 -0.69258182 -0.002303751 -1.39804362
19  0.504820216  0.88694633 -0.52855791  0.330452562 -1.57425961
20  0.899474044 -0.41477379 -0.34950206 -0.062604686  2.26622730

My table looks like this now:

Instead, I want it the bars to be proportional to pval_data, like this (but with ones instead of the pval_data numbers in the table):

Thanks!

P.S. The other question is: if I wanted the colors to be conditional, e.g., if I wanted the color to turn red if the corresponding pval is below N, how would I do that?

Answer 1

The problem here is that the styleColorBar function creates some Javascript code to make the background based on the range(pval_data), but that code is applied to the values of the datatable that is drawn, in this case a.

One trick could be to cbind a and pval_data, and pass that to the output so that all the data necessary to do what you went is passed to the browser.

You could then color the background of the first five columns (a in this case) according to the values in the five last columns (pval_data) and hide the last 5 columns if you don't want them displayed.

Here's an example:

library(DT)
library(shiny)
    server <- function(input, output) {

  a<-reactive({
    data.frame(matrix(1, nrow=input$obs, ncol=5))
  })

  pval_data <- reactive({
    data.frame(matrix(rnorm(n = input$obs*5), ncol=5))
  })

  output$pivot_table = DT::renderDataTable(
    datatable(cbind(a(),pval_data()), options = list(columnDefs = list(list(targets = 6:10, visible = FALSE)),rowCallback = JS(
  paste0("function(row, data) {

        for (i = 1; i < 6; i++) {
           value = data[i+5]
           if (value < ",input$cutoff,") backgroundValue =",styleColorBar(range(pval_data()), 'lightblue')[1],"
           else backgroundValue =",styleColorBar(range(pval_data()), 'red')[1],"
           $('td', row).eq(i).css('background',backgroundValue);
           $('td', row).eq(i).css('background-repeat','no-repeat');
           $('td', row).eq(i).css('background-position','center');
           $('td', row).eq(i).css('background-size','98% 88%')
         }
         }"))
)))

}

ui <- shinyUI(fluidPage(
  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Number of observations:", min = 5, max = 20, value = 10),
      sliderInput("cutoff", "Cutoff:", min = -5, max = 5, value = 0,step=0.5)
    ),
    mainPanel(dataTableOutput('pivot_table')
  )
)))

shinyApp(ui = ui, server = server)

In the options part of the datatable, columnDefs is used to hide the last 5 columns, and rowCallback to color the background. With this code, the background will be lightblue if the values is less than 0 and red if it is above 0.