闪亮绑定输入 class 丢失在 R Shiny 与 DT 和 Z19B13BE0F34E065AB672ZB203

Question

I am trying to build a shiny app that uses dynamically created inputs within a data.table with the help of the DT package. In the reproducible example below, the shiny-input input$Sel_Group_1 created within the DT-output depends on the value chosen in the shiny-input input$selectGroup (values a or b). The selected item (values c,d,f,g) are then shown in the textoutput output$selectedItem .

When I initially launch the app everything works fine, but as soon as I update the value in input$selectGroup the binding of the element input$Sel_Group_1 is lost and the textoutput output$selectedItem does not react any more. Upon inspecting the element input$Sel_Group_1 I found out that the class attribute "shiny-bound-input" is lost as soon as the value in input$selectGroup is updated.

Many thanks in advance for help on this topic!

library(shiny)
library(DT)
library(data.table)


data <- data.table(Group = c("a", "a", "b", "b"), Item = c("c", "d", "f", "g"))

ui <- fluidPage(
  selectInput("selectGroup", "Select Group", c("a", "b")),
  DT::dataTableOutput('ItemSelection'),
  textOutput("selectedItem")
)

server <- function(input, output, session) {
  output$ItemSelection <- DT::renderDT(
    {
      data_selected <- data[Group == input$selectGroup]
      data_unique <- unique(data[Group == input$selectGroup, .(Group)])

      data_unique$Item_Selection[1] <-
        as.character(selectInput(
          "Sel_Group_1",
          label = NULL,
          choices = unique(data_selected[Group %in% data_unique[1], Item]),
          width = "100px"
        ))

      return(data_unique)

    }
    , escape = FALSE, selection = 'none', server = FALSE,
    options = list(dom = 't', paging = FALSE, ordering = FALSE),
    rownames = 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());")
  )


  output$selectedItem <- renderText(paste0("Item selected is: ", input$Sel_Group_1))
}

shinyApp(ui, server)

Answer 1

You have to unbind before the table is rerendered:

library(shiny)
library(DT)
library(data.table)


data <- data.table(Group = c("a", "a", "b", "b"), Item = c("c", "d", "f", "g"))

ui <- fluidPage(
  tags$head(tags$script(
    HTML(
      "Shiny.addCustomMessageHandler('unbindDT', function(id) {
        var $table = $('#'+id).find('table');
        if($table.length > 0){
          Shiny.unbindAll($table.DataTable().table().node());
        }
      })")
  )),
  selectInput("selectGroup", "Select Group", c("a", "b")),
  DT::dataTableOutput('ItemSelection'),
  textOutput("selectedItem")
)

server <- function(input, output, session) {
  output$ItemSelection <- DT::renderDT(
    {
      data_selected <- data[Group == input$selectGroup]
      data_unique <- unique(data[Group == input$selectGroup, .(Group)])
      
      data_unique$Item_Selection[1] <-
        as.character(selectInput(
          "Sel_Group_1",
          label = NULL,
          choices = unique(data_selected[Group %in% data_unique[1], Item]),
          width = "100px"
        ))
      
      datatable(
        data_unique, escape = FALSE, selection = 'none',
        options = list(
          dom = 't', 
          paging = FALSE, 
          ordering = FALSE,
          preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
          drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
        ),
        rownames = FALSE
      )
      
    }, server = FALSE)
  
  observeEvent(input$selectGroup, {
    session$sendCustomMessage("unbindDT", "ItemSelection")
  })
  
  
  output$selectedItem <- renderText(paste0("Item selected is: ", input$Sel_Group_1))
}

shinyApp(ui, server)