Wsrtjtyk

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]

    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: