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

【问题标题】：Implementing Feedback in R / Shiny with DT DataTables rows per select input choice not working / crashing在 R / Shiny 中使用 DT DataTables 行每个选择输入选项实现反馈不起作用/崩溃
【发布时间】：2021-08-31 14:21:21
【问题描述】：

我正在尝试建立一个反馈系统。这是我正在尝试构建的简化示例。我有一个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，应用程序在提交时不会崩溃。但反过来，确实如此。顺便说一句 - 无论哪种情况，我的反馈都不会更新。

【问题讨论】：

有什么理由让你renderUI你的dataTableOutput而不是直接把它放入UI？从我看到的renderUI 部分对数据没有任何用处，它只是在数据更改时重新呈现表，但它总是会呈现相同的。
因为我试图显示反馈按钮和表格，只有当数据存在时，通过反应调用和检查。无论如何，这部分代码结构与我的问题或它不起作用的原因并不真正相关。
不是，但它使您的问题过于复杂，因此帮助您变得更加复杂，因为该错误有些混淆。一个好的代表也是最小的。例如，在您的代表中，甚至命名所有inputs 是一项艰巨的任务，因为它们不是在ui 和server 端创建的。我的意思是，如果你让你的例子更简单，你就有更高的机会获得帮助。
我看不到输出表。该应用程序仅显示 selectInput 和反馈按钮。 datatable 永远不会被渲染。但是当点击反馈按钮时，我确实得到了同样的错误（总是）。原因是recommendation_feedback 列是一个包含NULLs 的列表列。 write.table 不支持列表列。
我知道这一点，并在我的帖子中指出。我试图让它不返回空值列表。此外，这张桌子对我来说很好。不确定是否存在版本问题。

标签： r shiny dt

【解决方案1】：

为了避免应用程序崩溃写下一行

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

就在write.table()之前

请注意lapply 返回一个列表，因此是您的第一个问题。

接下来，在单选按钮中回收输入 ID 也是一个问题。通过定义唯一 ID，您可以使其工作。最后，为确保单选按钮始终有效，最好定义新的 ID。如果对于给定的cyl 值，ID 是固定的，它只会在第一次工作。随后选择该cyl 将显示初始选择，可以通过updateradioButtons 更新，但这不会是反应性的。试试这个并根据您的需要修改显示表。

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)

【讨论】：

这其实不是我的问题。正如我所指出的，sapply 应该返回一个向量，但返回的是一个 NULL 列表，因为我在回收下一个 DT 反馈列的输入 ID 时做错了。问题不在于write.table。转换为 as.character() 只会用 NULL 填充我的反馈。不是用户输入的内容。
防止崩溃不是我的需要，因为我已经知道导致崩溃的原因，并在问题中进行了解释。我想解决崩溃的根本原因。
反馈正在起作用 - 为每个显示器定义一组新的 ID。