Question

我正在尝试使用闪亮和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)

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

为每行创建selectInput，并使用选择的值更新反应表

1 个答案: