Displaying commas and conditional highlighting in Rshiny - not compatible

Question

I have a Shiny app rendering a datatable within which I would like to incorporate 2 conditional formatting features

Add commas to numbers greater than 1000
Apply blue background to column 2 values when values column 2 values are >= 1.3x values in column 1. Apply red background when column 2 values are <= .7x values in column 1.

I asked a question about how to incorporate commas in this SO post. I remove the rowcallback argument in the script below, the commas render properly. Similarly, if I comment out the dom and formatCurrency arguments, the highlighting conditional fomatting renders properly, as well.

  js_cont_var_lookup <- reactive({
  JS(
      'function(nRow, aData) {
      for (i=2; i < 3; i++) {
      if (parseFloat(aData[i]) > aData[1]*(1.03)) {
        $("td:eq(" + i + ")", nRow).css("background-color", "aqua");
         }
        }
       for (i=2; i < 3; i++) {
       if (parseFloat(aData[i]) < aData[1]*(.7)) {
        $("td:eq(" + i + ")", nRow).css("background-color", "red");
         }
        }
       }'
      ) # close JS
})

shinyApp(
  ui = fluidPage(
    DTOutput("dummy_data_table")
  ),
  server = function(input, output) {
    output$dummy_data_table <- DT::renderDataTable(
      data.frame(A=c(100000, 200000, 300000), B=c(140000, 80000, 310000)) %>%
        datatable(extensions = 'Buttons',
                  options = list(
                    pageLength = 50,
                    scrollX=TRUE,
                    dom = 'T<"clear">lBfrtip',
                    rowCallback = js_cont_var_lookup()
                  )
        ) %>%
        formatCurrency(1:2, currency = "", interval = 3, mark = ",")
    ) # close renderDataTable
  }
)

However, when I leave both in, the datatable hangs with a 'Processing' message.

ismirsehregal, apologies for the delay. Thank you very much for the work! — matsuo_basho, Nov 15 '18 at 14:47

ismirsehregal · Accepted Answer · 2018-11-12T13:30:19.670

Here is a soution avoiding the rowCallback:

library(shiny)
library(DT)
library(data.table)

shinyApp(
  ui = fluidPage(
    DTOutput("dummy_data_table")
  ),

  server = function(input, output) {

    myDisplayData <- data.table(A=c(100000, 200000, 300000), B=c(140000, 80000, 310000))
    myWorkData <- copy(myDisplayData)
    myWorkData[, colors := ifelse(B >= A*1.03, 'rgb(0,255,255)', 'rgb(255, 255, 255)')]
    myWorkData[colors %in% 'rgb(255, 255, 255)', colors := ifelse(B <= A*.7, 'rgb(255, 0, 0)', 'rgb(255, 255, 255)')]

    output$dummy_data_table <- DT::renderDataTable(
      DT::datatable(
        myDisplayData,
        extensions = 'Buttons',
        options = list(
          pageLength = 50,
          scrollX=TRUE,
          dom = 'T<"clear">lBfrtip'
        )
      ) %>% formatStyle('B', target = 'cell', backgroundColor = styleEqual(myDisplayData$B, myWorkData$colors)) %>% 
        formatCurrency(1:2, currency = "", interval = 3, mark = ",")
    ) # close renderDataTable

  }
)

Edit -------------------------

If you prefer using a data.frame:

library(shiny)
library(DT)

shinyApp(
  ui = fluidPage(
    DTOutput("dummy_data_table")
  ),

  server = function(input, output) {

    myDisplayData <- data.frame(A=c(100000, 200000, 300000), B=c(140000, 80000, 310000))

    MyColors <- vector(mode = 'character', length = 0L)

    for (i in seq(nrow(myDisplayData))) {
      A <- myDisplayData$A[i]
      B <- myDisplayData$B[i]
      if (B >= A * 1.03) {
        MyColors[i] <- 'rgb(0,255,255)'
      } else if (B <= A * .7) {
        MyColors[i] <- 'rgb(255, 0, 0)'
      }
      else{
        MyColors[i] <- 'rgb(255, 255, 255)'
      }
    }

    output$dummy_data_table <- DT::renderDataTable(
      DT::datatable(
        myDisplayData,
        extensions = 'Buttons',
        options = list(
          pageLength = 50,
          scrollX=TRUE,
          dom = 'T<"clear">lBfrtip'
        )
      ) %>% formatStyle('B', target = 'cell', backgroundColor = styleEqual(myDisplayData$B, MyColors)) %>% 
        formatCurrency(1:2, currency = "", interval = 3, mark = ",")
    ) # close renderDataTable

  }
)

Edit -------------------------

Here is a multi-column approach making the assumption, that all other columns are refering to column "A":

library(shiny)
library(DT)
library(data.table)

shinyApp(
  ui = fluidPage(
    DTOutput("dummy_data_table")
  ),

  server = function(input, output) {

    myDisplayData <- data.table(replicate(15,sample(round(runif(20,0,300000)), 20, rep=TRUE)))
    names(myDisplayData) <- LETTERS[1:15]
    referenceCol <- "A"
    targetColumns <- names(myDisplayData)[!names(myDisplayData) %in% referenceCol]
    myDisplayData[, index := seq(.N)]

    rowUniqueCols <- paste0("rowUnique", targetColumns)

    for(i in seq(rowUniqueCols)){
      myDisplayData[, (rowUniqueCols[i]) := do.call(paste,c(.SD, sep = "_")), .SDcols=c("index", targetColumns[i])]
    }

    myWorkData <- melt.data.table(myDisplayData, id.vars=c("index", referenceCol), measure.vars = rowUniqueCols)
    myDisplayData[, index := NULL]
    HideCols <- which(names(myDisplayData) %in% rowUniqueCols)
    setnames(myWorkData, "value", "rowUniqueValue")
    myWorkData[, value := as.numeric(sapply(strsplit(rowUniqueValue, "_"), "[[", 2))]
    myWorkData[, variable := NULL]
    myWorkData[, colors := ifelse(value >= .SD*1.3, 'rgb(0,255,255)', 'rgb(255, 255, 255)'), .SDcols=referenceCol]
    myWorkData[colors %in% 'rgb(255, 255, 255)', colors := ifelse(value <= .SD*.7, 'rgb(255, 0, 0)', 'rgb(255, 255, 255)'), .SDcols=referenceCol]

    output$dummy_data_table <- DT::renderDataTable(
      DT::datatable(
        myDisplayData,
        extensions = 'Buttons',
        options = list(
          pageLength = 50,
          scrollX=TRUE,
          dom = 'T<"clear">lBfrtip', 
          columnDefs = list(list(visible=FALSE, targets=HideCols))
        )
      ) %>% formatStyle(columns = targetColumns, valueColumns = rowUniqueCols, target = 'cell', backgroundColor = styleEqual(myWorkData$rowUniqueValue, myWorkData$colors)) %>% 
        formatCurrency(1:15, currency = "", interval = 3, mark = ",")
    ) # close renderDataTable

  }
)

Result:

This is great, thank you. One important point - I may have up to 15 columns (I just included 2 in my example for simplicity). So I would need to retain the for loop as in my example. How would that look? — matsuo_basho, Nov 10 '18 at 00:58
Are all other columns still refering to the first column regarding the color assignment? — ismirsehregal, Nov 10 '18 at 07:32
Btw: in your question you are mentioning 1.3x but in your JS function it's 1.03. I made it 1.3 in my code now. — ismirsehregal, Nov 10 '18 at 12:36
Just saw there is a problem with the color mapping for the multi-col solution. The displayed values need to be row-unique for this to work otherwise a previously defined color is assigned. Will have another look when back at PC. — ismirsehregal, Nov 10 '18 at 13:48
Just updated my 2. Edit. Now the colors are refering to row-unique helper columns. It's now fully working - please check. — ismirsehregal, Nov 12 '18 at 13:32
Accept the answer if it helped you, so it can help others! :) — noobed, Nov 15 '18 at 13:26
@ismirsehregal, I'm finally getting to your answer in order to integrate it into the actual app. I don't know datatable syntax so it's a bit challenging for me to modify the code. The reference column is always column 3 (but it's name is dynamic), the conditional formatting columns are from 4 onwards. How would the code change to account for that? Thanks! — matsuo_basho, Nov 21 '18 at 19:48
Just change my example to: `referenceCol <- names(myDisplayData)[3]` and `targetColumns <- names(myDisplayData)[4:length(names(myDisplayData))]` — ismirsehregal, Nov 21 '18 at 20:08

Displaying commas and conditional highlighting in Rshiny - not compatible

1 Answers1