Обратное поведение DataTable в R Shiny

Question

У меня проблема, для которой я не нашел никакого решения. Я хочу показать таблицу в моем блестящем приложении с DT :: datatable. На этой вкладке я хочу покрасить некоторые ячейки, которые определяются их координатами. Ниже приведен пример кода, где цветные ячейки соответствуют значениям NA:

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"),"}")) 
)) 

Этого код прекрасно работает при запуске в R консоли (RStudio), но когда я реализую это в моем блестящем приложении, есть небольшая ошибка : на первой странице цветные ячейки находятся в нужном месте, но когда я нажимаю на следующую кнопку для просмотра других страниц, кажется, что цветные ячейки не обновляют, и они все еще окрашены, даже если нет NA. Вот рабочий пример по этой проблеме:

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"),"}")) 
     ))) 

} 
) 

я буду очень рад, если кто-то может помочь мне с этой проблемой

С уважением

Сэм

Answer 1

я был в состоянии сделать это работа с обработкой на стороне сервера установлена ​​на false. Взгляните на это link. В разделе 1. тема начинается последний фрагмент текста перед темой 2.

Это модифицированный код:

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) 

      } 
    ) 

Answer 2

Я найти способ использования для кода Javascript сложно. Я предпочел бы пройти код ниже опции 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'}) 
... 

Этот код генерируется, как это (для 8 столбцов):

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") 

И это работает в блестящей приложение:

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)) 
    ) 
    ) 
    } 
)