为每行创建 selectInput(s) 并使用所选值更新反应表答案

【问题标题】：Create selectInput(s) for each rows and update reactive table using chosen values为每行创建 selectInput(s) 并使用所选值更新反应表
【发布时间】：2018-08-30 06:08:33
【问题描述】：

我正在尝试使用闪亮和 DT 包在 data.frame 的每一行中实现“selectInput”。 This 发帖帮了我很多忙。

以下代码应从每一行获取输入，并为每次单击“更改”按钮更新 Update_Select 列。问题是它更新了一次列并变为空闲状态。

library(shiny)
library(DT)

ui <- fluidPage(
  fluidRow(
    fluidRow(column(6, actionButton("act", "Change:")),
             column(6, verbatimTextOutput("txt", placeholder = T))),
    fluidRow(column(12, DTOutput("react_tbl")))
  )
)

server <- function(input, output, session) {
  # Helper function for making checkbox
  shinyInput = function(FUN, len, id, ...) { 
    inputs = character(len) 
    for (i in seq_len(len)) { 
      inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
    } 
    inputs 
  } 

  # Helper function for reading checkbox
  shinyValue = function(id, len) { 
    unlist(lapply(seq_len(len), function(i) { 
      value = input[[paste0(id, i)]] 
      if (is.null(value)) NA else value 
    })) 
  }

  alld <- reactiveValues(react_tbl = data.frame(cars, Rating = shinyInput(selectInput,
                                                                          nrow(cars),
                                                                          "selecter_",
                                                                          choices=1:5,
                                                                          width="60px"),
                                                Update_Action = NA,
                                                Update_Select = NA))


  output$react_tbl = DT::renderDataTable(
    alld$react_tbl,
    selection = 'none',
    server = FALSE,
    escape = FALSE,
    options = list(
      dom = "t",
      paging = TRUE,
      pageLength = 20,
      lengthMenu = c(5, 10, 20, 100, 1000, 10000),
      preDrawCallback = JS('function() { 
                           Shiny.unbindAll(this.api().table().node()); }'), 
      drawCallback = JS('function() { 
                        Shiny.bindAll(this.api().table().node()); } '))
      )


  observeEvent(input$act,{
    alld$react_tbl["Update_Action"] <- input$act
    alld$react_tbl["Update_Select"] <- shinyValue("selecter_", nrow(alld$react_tbl))
  })
  output$txt <- renderText(shinyValue("selecter_", nrow(alld$react_tbl)))

  }

shinyApp(ui, server)

【问题讨论】：

谁能告诉我，这是可行的还是错误的？谢谢。

标签： r shiny dt

【解决方案1】：

数据变化时需要解绑。

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());
        }
      })")
  )),
  fluidRow(......

在服务器函数中：

  observeEvent(alld$react_tbl, {
    session$sendCustomMessage("unbindDT", "react_tbl")
  })

【讨论】：