Myujth

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

1. Add commas to numbers greater than 1000


2. 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 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.

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

 
)

1. 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

 
)

2. 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]

 targetColumns <- names(myDisplayData)[!names(myDisplayData) %in% "A"]

 myWorkData <- melt.data.table(myDisplayData, id.vars="A", measure.vars=targetColumns)
 myWorkData[, variable := NULL]
 myWorkData[, colors := ifelse(value >= A*1.3, 'rgb(0,255,255)', 'rgb(255, 255, 255)')]
 myWorkData[colors %in% 'rgb(255, 255, 255)', colors := ifelse(value <= 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(targetColumns, target = 'cell', backgroundColor = styleEqual(myWorkData$value, myWorkData$colors)) %>% 
 formatCurrency(seq(ncol(myDisplayData)), currency = "", interval = 3, mark = ",")
 ) # close renderDataTable

 
)

Result: