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之前的最后一段文字开始。

这是修改后的代码：

[info] Test case failed
[info] Test suite completed: 1 played, 1 failed
[info] Playing test case My First TC
[info] Executing: |open | / | |
[error] Could not connect to Selenium Server. Have you started the Selenium Server yet?

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

R Shiny中的DataTable回调行为

2 个答案: