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

Question

I am trying to create a table (with DT, pls don't use rhandsontable) which has few existing columns, one selectinput column (where each row will have options to choose) and finally another column which will be populated based on what user select from selectinput dropdown for each row.

in my example here, 'Feedback' column is the user dropdown selection column. I am not able to update the 'Score' column which will be based on the selection from 'Feedback' column dropdown.

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

I'd suggest using dataTableProxy along with replaceData to realize the desired behaviour. This is faster than re-rendering the datatable .

Furthermore, re-rendering the table seems to be messing around with the bindings of the selectInputs .

Also please note: for this to work I needed to switch to 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(
  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)