DataTable callback behaviour in R Shiny

问题:

I have an issue for which I do not find any solution. I want to show a table in my shiny app with DT::datatable. In this tab, I want to color some cells which are defined by their coordinates. Here is an example of code where the colored cells corresponds to NA values :

test.table <- data.frame(lapply(1:8, function(x) {1:1000}))
test.table[c(2,3,7), c(2,7,6)] <- NA
id <- which(is.na(test.table))


datatable(test.table,
options = list(drawCallback=JS(
paste("function(row, data) {",
paste(sapply(1:ncol(test.table),function(i)
paste( "$(this.api().cell(",id %% nrow(test.table)-1,",",trunc(id / nrow(test.table))+1,").node()).css({'background-color': 'lightblue'});")
),collapse = "\n"),"}" ))
))

This code works fine when run in a R console (RStudio) but when I implement this in my shiny app, there is a little bug : on the first page, the colored cells are at the right place but when I click on the next button to view the other pages,it seems that the colored cells do nout update and they are still colored even is there are no NA anymore. Here is a working example on that problem:

shinyApp(
ui = fluidPage(
    fluidRow(
        column(12,
        dataTableOutput('table')
       )
)
),
server = function(input, output) {
  test.table <- data.frame(lapply(1:8, function(x) {1:1000}))
  test.table[c(2,3,7), c(2,7,6)] <- NA
  id <- which(is.na(test.table))

    output$table <- renderDataTable(
        datatable(test.table,
                   options = list(drawCallback=JS(
                           paste("function(row, data) {",
                               paste(sapply(1:ncol(test.table),function(i)
                                 paste( "$(this.api().cell(",id %% nrow(test.table)-1,",",trunc(id / nrow(test.table))+1,").node()).css({'background-color': 'lightblue'});")
                                  ),collapse = "\n"),"}" ))
        )))

}
)

I will be very happy if someone can help me for that problem

Regards

Sam

回答1:

I was able to make it work with server side processing set to false. Take a look at this link. Under the 1. topic the last piece of text before topic 2. starts.

This is the modified code:

shinyApp(
            ui = fluidPage(
                    fluidRow(
                            column(12,
                                   dataTableOutput('table')
                            )
                    )
            ),
            server = function(input, output) {
                    test.table <- data.frame(lapply(1:8, function(x) {1:1000}))
                    test.table[c(2,3,7), c(2,7,6)] <- NA
                    id <- which(is.na(test.table))

                    output$table <- renderDataTable(
                            test.table,
                                      options = list(drawCallback=JS(
                                              paste("function(row, data) {",
                                                    paste(sapply(1:ncol(test.table),function(i)
                                                            paste( "$(this.api().cell(",id %% nrow(test.table)-1,",",trunc(id / nrow(test.table))+1,").node()).css({'background-color': 'lightblue'});")
                                                    ),collapse = "\n"),"}" ))
                                      ), server = FALSE)

            }
    )

回答2:

I find the way you use for the Javascript code is complicated. I would rather pass the code below to the option rowCallback:

function(row, data) {
var value=data[1]; if (value===null) $(this.api().cell(row, 1).node()).css({'background-color':'lightblue'})
var value=data[2]; if (value===null) $(this.api().cell(row, 2).node()).css({'background-color':'lightblue'})
var value=data[3]; if (value===null) $(this.api().cell(row, 3).node()).css({'background-color':'lightblue'})
...

This code is generated like this (for 8 columns):

jscode <- paste("function(row, data) {",  
                paste0(sprintf("var value=data[%s]; if (value===null) $(this.api().cell(row, %s).node()).css({'background-color':'lightblue'})", 
                               1:8, 1:8), collapse = "\n"), "}", sep="\n")

And it works in the shiny app:

shinyApp(
  ui = fluidPage(
    fluidRow(
      column(12,
             DT::dataTableOutput('table')
      )
    )
  ),
  server = function(input, output) {
    test.table <- data.frame(lapply(1:8, function(x) {1:1000}))
    test.table[c(2,3,7), c(2,7,6)] <- NA

    output$table <- DT::renderDataTable(
      datatable(test.table,
                options = list(rowCallback=JS(jscode))
      )
    )
  }
)