DT：根据R SHINY APP中另一列的SELECTUT PUT动态更改列值 [英] DT: Dynamically change column values based on selectinput from another column in R shiny app

问题描述

我正在尝试创建一个表(使用DT，请不要使用rhandsontable)，该表的现有列很少，只有一个selectinput列(其中每行都有选项可供选择)，最后还有一个列将根据用户从selectinput下拉列表中为每行选择的内容进行填充。

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

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

推荐答案

我建议结合使用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(
  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)

这篇关于DT：根据R SHINY APP中另一列的SELECTUT PUT动态更改列值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！