Почему входные данные R / Shiny в datatable не работают правильно после обновления datatable? - PullRequest
Новая
       8

Почему входные данные R / Shiny в datatable не работают правильно после обновления datatable?

0 голосов
/ 02 октября 2018

Я пытаюсь создать таблицу данных с блестящими элементами ввода (checkboxInput или textInput).Это работает хорошо, пока я не обновлю данные.Если я добавлю больше строк с большим количеством элементов ввода, будут работать только новые элементы.Я думал, что таблица будет воссоздана каждый раз, когда я обновлю ее, и идентификаторы будут связаны с новыми элементами ввода.Пример кода ниже иллюстрирует проблему.Создается таблица с одной строкой первой.Если я затем создаю таблицу с двумя строками, используя раскрывающийся список слева, я могу только прочитать значения второй строки в выходной таблице.Любое изменение входов первой строки не влияет на таблицу выходных данных. 

library(DT)
library(shiny)
server <- function(input, output) {
  updateTable <- reactive({
    num <- as.integer(input$num)
    df <- data.frame(check = unlist(lapply(1:num, function(i) as.character(checkboxInput(paste0("check_", i), label = paste0("check", i), value = 0)))),
               text = unlist(lapply(1:num, function(i) as.character(textInput(paste0("text_",i), label = paste0("text", i), value = "")))))
  })

  output$input_ui <- DT::renderDataTable(
    updateTable(),
    server = FALSE, escape = FALSE, selection = 'none',
    options = list(
      dom = 't', paging = FALSE, ordering = FALSE,lengthChange = TRUE,
      preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
      drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
    )
  )

  output$table <- renderTable({
    num <- as.integer(input$num)
    data.frame(lapply(1:num, function(i) {
      paste(input[[paste0("check_", i)]], input[[paste0("text_",i)]], sep = " : ")
    }))
  })
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("num", "select number of inputs", choices = seq(1,10,1))
    ),
    mainPanel(
      DT::dataTableOutput("input_ui"),
      tableOutput("table")
    )
  )
)

shinyApp(ui = ui, server = server)

1 Ответ

0 голосов
/ 07 октября 2018

Возможное решение предоставлено здесь:

https://groups.google.com/d/msg/shiny-discuss/ZUMBGGl1sss/7sdRQecLBAAJ

Насколько я понимаю, это позволяет "принудительно" полностью отменить привязку всех флажков / текстовых надписей перед перерисовкой таблицы благодаряна использование: 

session$sendCustomMessage('unbind-DT', 'input_ui')

.Я не претендую на то, чтобы действительно понять это, но, видимо, это работает.Смотрите ниже для возможной реализации.

library(shiny)
library(DT)
server <- function(input, output,session) {
  updateTable <- reactive({
    num <- as.integer(input$num)
    session$sendCustomMessage('unbind-DT', 'input_ui')
    df <- data.frame(
      check = unlist(lapply(1:num, function(i) as.character(checkboxInput(paste0("check_", i), label = paste0("check", i), value = 0)))),
      text = unlist(lapply(1:num, function(i) as.character(textInput(paste0("text_",i), label = paste0("text", i), value = "")))))
    tbl <- DT::datatable(df, escape = FALSE,
                         selection = "none", 
                         options = list(
                           dom = 't', paging = FALSE, ordering = FALSE,lengthChange = TRUE,
                           preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                           drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
                         ))

  })

  output$input_ui <- DT::renderDataTable(
    updateTable(),
    server = FALSE
  )

  output$table <- renderTable({
    num <- as.integer(input$num)
    data.frame(lapply(1:num, function(i) {
      paste(input[[paste0("check_", i)]], input[[paste0("text_",i)]], sep = " : ")
    }))
  })
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("num", "select number of inputs", choices = seq(1,10,1))
    ),
    mainPanel(
      DT::dataTableOutput("input_ui"),
      tags$script(HTML(
        "Shiny.addCustomMessageHandler('unbind-DT', function(id) {
          Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
        })")),
      tableOutput("table")
    )
  )
)

shinyApp(ui = ui, server = server)

HTH!

...