r - 使用 DT DataTables 行在 R/Shiny 中实现反馈，每个选择输入选项不起作用/崩溃

Question

我正在尝试建立一个反馈系统。这是我正在尝试构建的一个简化示例。我有一个 DT:datatable根据选定的输入选项呈现一个反馈列。
反馈通过observeEvent提交在提交按钮上。所有的 UI 和服务器组件大部分都是我想要的。

library(shiny)
library(shinydashboard)

ui <- ui <- dashboardPage(
  header = dashboardHeader(title='Car Recommendations'),
  sidebar = dashboardSidebar(
    width = 450,
    fluidRow(
      column(
        width = 9,
        selectInput(
          "cyl", 'Select Cylinder Count:',
          choices = c('', sort(unique(mtcars$cyl)))
          )
        )
      )
    ),
  body = dashboardBody(
    fluidPage(
    fluidRow(
      uiOutput('rec_ui')
      ))
    )
  )

server <- function(input, output, session) {
  mtcarsData <- reactive({
    req(input$cyl)
    mtcars %>%
      filter(cyl == input$cyl) %>%
      select(am, wt, hp, mpg)
  })
  
  output$rec_ui <- renderUI({
    mtcarsData()
    mainPanel(
      actionButton(
        'feedbackButton', 'Submit Feedback', class = 'btn-primary'
      ),
      dataTableOutput(('rec')),
      width = 12
    )
  })
  
  feedbackInputData <- reactive({
    mtcars <- mtcarsData()
    recsInput <- sapply(1:nrow(mtcars), function(row_id)
      input[[paste0('rec', row_id)]]
    )
  })
  
  observeEvent(input$feedbackButton, {
    mtcars <- mtcarsData()
    
    feedbackInput <- feedbackInputData()
    recFeedbackDf <- bind_rows(
      lapply(1:nrow(mtcars), function(row_id)
        list(
          shiny_session_token = session$token,
          recommendation_type = 'CAR',
          input_cyl = input$cyl,
          recommended_mpg = mtcars$mpg[row_id],
          recommendation_feedback = feedbackInput[row_id],
          feedback_timestamp = as.character(Sys.time())
        )
      )
    )
    
    write.table(
      recFeedbackDf, 'feedback.csv', row.names = FALSE,
      quote = FALSE, col.names = FALSE, sep = '|',
      append = TRUE
    )
    showModal(
      modalDialog(
        'Successfully submitted', easyClose = TRUE,
        footer = NULL, class = 'success'
      )
    )
  })
  
  output$rec <- DT::renderDataTable({
    df <- mtcarsData()

    feedbackCol <- lapply(1:nrow(df), function(recnum)
      as.character(
        radioButtons(
          paste0('rec', recnum), '',
          choices = c('neutral' = 'Neutral', 'good' = 'Good', 'bad' = 'Bad'),
          inline = TRUE
        )
      )
    )
    feedbackCol <- tibble(Feedback = feedbackCol)
    
    df <- bind_cols(
      df,
      feedbackCol
    )
    
    df %>%
      DT::datatable(
        extensions = 'FixedColumns',
        rownames = FALSE,
        escape = FALSE,
        class="compact cell-border",
        options = list(
          pageLength = 10,
          lengthChange = FALSE,
          scrollX = TRUE,
          searching = FALSE,
          dom = 't',
          ordering = TRUE,
          fixedColumns = list(leftColumns = 2),
          preDrawCallback = JS(
            'function() { Shiny.unbindAll(this.api().table().node()); }'
          ),
          drawCallback = JS(
            'function() { Shiny.bindAll(this.api().table().node()); } '
          ),
          autoWidth = TRUE,
          columnDefs = list(
            list(width = '250px', targets = -1)
          )
        )
      )
    })
  
  }

shinyApp(ui = ui, server = server)

但是，在提交时，会发生以下两种情况之一:

应用程序崩溃并在 write.table 中出现以下错误.但是，根本原因是这行代码返回了一个 NULL 的列表。值而不是我的反馈输入。

Warning: Error in write.table: unimplemented type 'list' in 'EncodeElement'

  feedbackInputData <- reactive({
    mtcars <- mtcarsData()
    recsInput <- sapply(1:nrow(mtcars), function(row_id)
      input[[paste0('rec', row_id)]]
    )
  })

当应用程序没有崩溃并且反馈被提交，但新的输入没有生效时。只有第一次提交会重复写入 CSV。

知道这个应用程序哪里出了问题吗？
附加信息:我的预感是，当我从“更少的行”DT 中选择更多行而不是其他方式时，会发生崩溃。例如，如果我先选择 8 CYL，它有更多的汽车，然后选择 4，应用程序不会在提交时崩溃。但反过来，确实如此。顺便说一句 - 在任何一种情况下，我的反馈都不会更新。

Answer 1

为避免应用程序崩溃，请编写该行recFeedbackDf <- apply(recFeedbackDf,2,as.character)就在之前 write.table()请注意 lapply返回一个列表，因此你的第一个问题。
接下来，在单选按钮中回收输入 ID 也是一个问题。通过定义唯一 ID，您可以使其工作。最后，为了确保单选按钮始终有效，最好定义新的 ID。如果给定的 ID 是固定的 cyl值，它只会在第一次工作。后续选择那个cyl将显示初始选择，可以通过 updateradioButtons 更新，但这不会是 react 性的。试试这个并根据您的需要修改显示表。

library(DT)
library(data.table)
library(shiny)
#library(shinyjs)
library(shinydashboard)
options(device.ask.default = FALSE)

ui <- dashboardPage(
  header = dashboardHeader(title='Car Recommendations'),

  sidebar = dashboardSidebar(
    width = 450,
    fluidRow(
      column(
        width = 9,
        selectInput(
          "cyl", 'Select Cylinder Count:',
          choices = c('', sort(unique(mtcars$cyl)))
        )
      )
    )
  ),
  body = dashboardBody(
    #useShinyjs(),
    fluidPage(
      fluidRow(
        actionButton('feedbackButton', 'Submit Feedback', class = 'btn-primary'),
        DTOutput('rec'),
        verbatimTextOutput("sel")
      ))
  )
)


server <- function(input, output, session) {
  cntr <- reactiveVal(0)
  rv <- reactiveValues()
  mtcarsData <- reactive({
    mtcar <- mtcars %>% filter(cyl == input$cyl) %>% 
      select(cyl, am, wt, hp, mpg) 
  })

  observe({
    req(input$cyl,mtcarsData())
    
    mtcar <- mtcarsData()
    id <- cntr() 
    m = data.table(
      rowid = sapply(1:nrow(mtcar), function(i){paste0('rec',input$cyl,i,id)}),
      Neutral = 'Neutral',
      Good = 'Good',
      Bad = 'Bad',
      mtcar
    ) %>%
    mutate(Neutral = sprintf('<input type="radio" name="%s" value="%s" checked="checked"/>', rowid, Neutral),
           Good = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Good),
           Bad  = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Bad)
           )

    rv$df <- m
    
    print(id)
  })
  
  observeEvent(input$cyl, {
    cntr(cntr()+1)
    #print(cntr())
  },ignoreInit = TRUE)

  feedbackInputData <- reactive({
    dfa <- req(rv$df)
    list_values <- list()
    for (i in unique(dfa$rowid)) {
      list_values[[i]] <- input[[i]]
    }
    list_values
  })

  observeEvent(input$feedbackButton, {
    req(input$cyl)
    mtcar <- rv$df  ## this could be mtcarsData(), if picking columns not in rv$df but only in mtcarsData()
    dt <- rv$df

    dt$Feedback  <- feedbackInputData()  
    recFeedbackDf <- bind_rows(
      lapply(1:nrow(mtcar), function(row_id){
        list(
          shiny_session_token = session$token,
          recommendation_type = 'CAR',
          input_cyl = input$cyl,
          recommended_mpg = mtcar$mpg[row_id],
          recommendation_feedback = dt$Feedback[row_id],
          feedback_timestamp = as.character(Sys.time())
        )
      })
    )

    recFeedbackDf <- apply(recFeedbackDf,2,as.character)

    write.table(
      recFeedbackDf, 'feedback.csv', row.names = FALSE,
      quote = FALSE, col.names = FALSE, sep = '|',
      append = TRUE
    )
    showModal(
      modalDialog(
        'Successfully submitted', easyClose = TRUE,
        footer = NULL, class = 'success'
      )
    )
  })
  
  output$rec <- renderDT(
    datatable(
      rv$df,
      selection = "none",
      escape = FALSE,
      options = list(
        columnDefs = list(list(visible = FALSE, targets = c(0,4))),  ## not displaying rowid and cyl 
        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-radiogroup');
                  });
                  Shiny.unbindAll(table.table().node());
                  Shiny.bindAll(table.table().node());"
      ),
      rownames = F
    ),
    server = FALSE
  )
  
  ###  verify if the radio button values are being returned
  output$sel = renderPrint({
    req(feedbackInputData())
    feedbackInputData()
  })

}

shinyApp(ui = ui, server = server)