在 DataTable 中使用 DropDown 更新 DataTable

Question

我正在尝试使用我在 DataTable 中创建的下拉菜单动态更新示例 DataTable。但是，无论我尝试什么，它似乎都没有更新。下面的示例代码是我目前正在使用的，以便在从species_selector 列中选择输入时更新Species 列。

library(shiny)
library(DT)

ui <- fluidPage(
  title = 'Selectinput column in a table',
  h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
  DT::dataTableOutput('foo'),
  actionButton(inputId = "submit", label = "Submit"),
  verbatimTextOutput('sel')
)

server <- function(input, output, session) {
  data <- head(iris, 5)

  for (i in 1:nrow(data)) {
    data$species_selector[i] <- as.character(selectInput(paste0("sel", i), "", choices = unique(iris$Species), width = "100px"))
  }

  output$foo = DT::renderDataTable(
    data, escape = FALSE, selection = 'none', server = FALSE,
    options = list(dom = 't', paging = FALSE, ordering = FALSE),
    callback = JS("table.rows().every(function(i, tab, row) {
        var $this = $(this.node());
        $this.attr('id', this.data()[0]);
        $this.addClass('shiny-input-container');
      });
      Shiny.unbindAll(table.table().node());
      Shiny.bindAll(table.table().node());")
  )
  
  observeEvent(input$submit, {
    update_data <- reactive({
      df <- data
      for(i in 1:nrow(df)) {
        df$Species[i] <- as.character(input[[paste0("sel", i)]])
      }
      return(df)
    })
    data <- update_data()
  })
  
  output$sel = renderPrint({
    for(i in 1:nrow(data)) {
      data$Species[i] <- as.character(input[[paste0("sel", i)]])
    }
    data
  })
}

shinyApp(ui, server)

任何帮助将不胜感激。谢谢！

Answer 1

你想要这样的东西吗？

library(shiny)
library(DT)

selector <- function(id, values, items = values){
  options <- HTML(paste0(mapply(
    function(i, item){
      value <- values[i]
      if(i == 1L){
        opt <- tags$option(value = value, selected = "selected", item)
      }else{
        opt <- tags$option(value = value, item)
      }
      as.character(opt)
    }, seq_along(values), items
  ), collapse = ""))
  as.character(tags$select(id = id, options))
}

js <- c(
  "function(settings) {",
  "  var table = this.api().table();",
  "  var $tbl = $(table.table().node());",
  "  var id = $tbl.closest('.datatables').attr('id');",
  "  var nrows = table.rows().count();",
  "  function selectize(i) {",
  "    var $slct = $('#slct' + i);",
  "    $slct.select2({",
  "      width: '100%',",
  "      closeOnSelect: true",
  "    });",
  "    $slct.on('change', function(e) {",
  "      var info = [{",
  "        row: i,",
  "        col: 4,",
  "        value: $slct.val()",
  "      }];",
  "      Shiny.setInputValue(id + '_cell_selection:DT.cellInfo', info);",
  "    });",
  "  }",
  "  for(var i = 1; i <= nrows; i++) {",
  "    selectize(i);",
  "  }",
  "}"
)

ui <- fluidPage(
  tags$head(
    tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
  ),
  br(),
  DTOutput("dtable"),
  tags$hr(),
  h2("Edited table:"),
  tableOutput("table")
)

server <- function(input, output, session) {
  
  dat <- head(iris, 3L)
  Dat <- reactiveVal(dat)
  for(i in 1L:nrow(dat)){
    dat$species_selector[i] <- 
      selector(id = paste0("slct", i), values = unique(iris$Species))
  }
  
  
  output[["dtable"]] <- renderDT({
    datatable(
      data = dat,
      selection = "none",
      escape = FALSE,
      rownames = FALSE,
      options = list(
        initComplete = JS(js),
        preDrawCallback = JS(
          "function() { Shiny.unbindAll(this.api().table().node()); }"
        ),
        drawCallback = JS(
          "function() { Shiny.bindAll(this.api().table().node()); }"
        )
      )
    )
  }, server = TRUE)

  observeEvent(input[["dtable_cell_selection"]], {
    info <- input[["dtable_cell_selection"]]
    Dat(editData(Dat(), info, rownames = FALSE))
  })
    
  output[["table"]] <- renderTable({
    Dat()
  })
}

shinyApp(ui, server)

Answer 2

您可以借助响应式值来保存数据框并在其中执行更改。

library(shiny)
library(DT)

data <- head(iris, 5)

for (i in 1:nrow(data)) {
  data$species_selector[i] <- as.character(selectInput(paste0("sel", i), "", choices = unique(iris$Species), width = "100px"))
}

ui <- fluidPage(
  title = 'Selectinput column in a table',
  h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
  DT::dataTableOutput('foo'),
  actionButton(inputId = "submit", label = "Submit"),
  verbatimTextOutput('sel')
)

server <- function(input, output, session) {

  rv <- reactiveValues(data = data)
  
  output$foo = DT::renderDataTable(
    rv$data, escape = FALSE, selection = 'none', server = FALSE,
    options = list(dom = 't', paging = FALSE, ordering = FALSE),
    callback = JS("table.rows().every(function(i, tab, row) {
        var $this = $(this.node());
        $this.attr('id', this.data()[0]);
        $this.addClass('shiny-input-container');
      });
      Shiny.unbindAll(table.table().node());
      Shiny.bindAll(table.table().node());")
  )
  
  observeEvent(input$submit, {
    for(i in 1:nrow(rv$data)) {
        rv$data$Species[i] <- as.character(input[[paste0("sel", i)]])
      }
  })
}

shinyApp(ui, server)