DT：根据 R闪亮应用程序中另一列的选择输入动态更改列值

Question

我正在尝试创建一个表（使用 DT，请不要使用 rhandsontable），该表几乎没有现有列，一个 selectinput 列（其中每行都有可供选择的选项），最后是另一列，该列将根据用户进行填充从每行的 selectinput 下拉列表中选择。

在我的示例中，“反馈”列是用户下拉选择列。 我无法更新“分数”列，该列将基于“反馈”列下拉列表中的选择。

if(interactive()){
  library(DT)
  library(shiny)
  tbl1 <- data.frame(A = c(1:10), B = LETTERS[1:10], C = c(11:20), D = LETTERS[1:10])
  ui <- fluidPage(
    DT::dataTableOutput(outputId = 'my_table')
  )
  server <- function(input, output, session) {
    rv <- reactiveValues(tbl = tbl1)
    observe({
      for (i in 1:nrow(rv$tbl)) {
        rv$tbl$Feedback[i] <- as.character(selectInput(paste0("sel", i), "",
                                                       choices = c(1,2,3,4)
        ))
        
        if(!is.null(input[[paste0("sel", i)]])) {
          if(input[[paste0("sel", i)]] == 1) {
            rv$tbl$Score[i] <- 10
          } else if(input[[paste0("sel", i)]] == 2) {
            rv$tbl$Score[i] <- 20
          } else if(input[[paste0("sel", i)]] == 3) {
            rv$tbl$Score[i] <- 25
          } else if(input[[paste0("sel", i)]] == 4) {
            rv$tbl$Score[i] <- 30
          }
        }
      }
    })
          
          output$my_table = DT::renderDataTable({
            
            datatable(
              rv$tbl, escape = FALSE, selection = 'none', rownames = F,
              options = list( paging = FALSE, ordering = FALSE, scrollx = T, dom = "t",
                              preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                              drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
              )
            )
          }, server = FALSE)
          
          
  }
  
  shinyApp(ui = ui, server = server)
}

Answer 1

我建议使用

dataTableProxy

和

replaceData

来实现所需的行为。这比重新渲染

datatable

更快。

此外，重新渲染表格似乎会弄乱

selectInputs

的绑定。

另请注意：要实现此功能，我需要切换到

server = TRUE

library(DT)
library(shiny)

selectInputIDs <- paste0("sel", 1:10)

initTbl <- data.frame(
  A = c(1:10),
  B = LETTERS[1:10],
  C = c(11:20),
  D = LETTERS[1:10],
  Feedback = sapply(selectInputIDs, function(x){as.character(selectInput(inputId = x, label = "", choices = c(1, 2, 3, 4), selected = 1))}),
  Score = rep(10, 10)
)

ui <- fluidPage(
  # please see: https://github.com/rstudio/shiny/issues/3979#issuecomment-1920046008
  # alternative: set selectize = FALSE in selectInput
  htmltools::findDependencies(selectizeInput("dummy", label = NULL, choices = NULL)),
  DT::dataTableOutput(outputId = 'my_table')
)

server <- function(input, output, session) {
  
  displayTbl <- reactive({
    data.frame(
      A = c(1:10),
      B = LETTERS[1:10],
      C = c(11:20),
      D = LETTERS[1:10],
      Feedback = sapply(selectInputIDs, function(x){as.character(selectInput(inputId = x, label = "", choices = c(1, 2, 3, 4), selected = input[[x]]))}),
      Score = sapply(selectInputIDs, function(x){as.integer(input[[x]])*10})
    )
  })
  
  output$my_table = DT::renderDataTable({
    DT::datatable(
      initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
      options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  }, server = TRUE)
  
  my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
  
  observeEvent({sapply(selectInputIDs, function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
}

shinyApp(ui = ui, server = server)