从 Shiny DT 中的单选按钮中提取用户输入值到数据框或列表中

Question

我正在构建一个带有数据表的闪亮应用程序，该数据表使用一些 javascript 回调，用户可以在其中为每一行进行选择（是/否/也许），然后在应用程序的后期阶段我需要该用户输入列表或表格的形式。未预定义确切的行数。理想情况下，我想总结一下每个用户选择了多少“是”/“否”/“可能”以及如何选择哪些行为否。我可以将值打印到 R 终端，但这还不够，值需要保存为对象。

这是我迄今为止的代码的简短示例（基于Radio Buttons on Shiny Datatable, with data.frame / data.table 和Extracting values of selected radio buttons in shiny DT）

library(shiny)
library(DT)
library(shinyWidgets)

my_table <- tibble(
  rowid = letters[1:7],
  val_1 = round(runif(7, 0, 10), 1),
  val_2 = round(rnorm(7), 2),
  Yes   = "Yes",
  No    = "No",
  Maybe = "Maybe"
) %>%
  mutate(
    Yes =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , Yes),
    No =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , No),
    Maybe =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , Maybe)
  )


shinyApp(
  ui = fluidPage(
    title = 'Radio buttons in a table',
    DT::dataTableOutput("datatable"),
    actionBttn(
      inputId = "btnProcess",
      label = "Process",
      style = "float",
      size = "sm",
      color = "success"
    ),
    actionBttn(
      inputId = "btnCancel",
      label = "Cancel",
      style = "float",
      size = "sm",
      color = "warning"
    )#,
    #verbatimTextOutput('sel')
    
    
    
  ),
  
  server = function(input, output, session) {
    dtWithRadioButton <- reactiveValues(dt = my_table)
    
    
    output$datatable <- renderDT(
      datatable(
        dtWithRadioButton$dt,
        selection = "none",
        escape = FALSE,
        options = list(
          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
    )
    
    # this did not work
    #list_results <- eventReactive(input$btnProcess,{
    
    observeEvent(input$btnProcess, {
      dt <- dtWithRadioButton$dt # accessing the reactive value
      # do some processing based on the radio button selection
      
      list_values <- list()
      for (i in unique(my_table$rowid)) {
        list_values[[i]] <- paste0(i, ": ", input[[i]])
        
      }
      
      print(list_values)
      
    })
    
    # This did noy work
    # output$sel = renderPrint({
    #   list_results()
    # })
    #
    
    observeEvent(input$btnCancel, {
      removeModal(session)
    })
  }
)

对于许多奖励积分，使用一些 .css 代码来更改依赖于单选按钮的行的颜色会很棒（例如红色表示否，绿色表示是，黄色表示可能）。

Answer 1

您可以在reactive 中进行计算，然后在observeEvent 中调用reactive，并使用您选择的任何输出方法将其显示为文本或DT 表。

library(shiny)
library(DT)
library(shinyWidgets)

my_table <- tibble(
  rowid = letters[1:7],
  val_1 = round(runif(7, 0, 10), 1),
  val_2 = round(rnorm(7), 2),
  Yes   = "Yes",
  No    = "No",
  Maybe = "Maybe"
) %>%
  mutate(
    Yes =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , Yes),
    No =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , No),
    Maybe =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , Maybe)
  )


shinyApp(
  ui = fluidPage(
    title = 'Radio buttons in a table',
    DT::dataTableOutput("datatable"),
    actionBttn(
      inputId = "btnProcess",
      label = "Process",
      style = "float",
      size = "sm",
      color = "success"
    ),
    actionBttn(
      inputId = "btnCancel",
      label = "Cancel",
      style = "float",
      size = "sm",
      color = "warning"
    ),
    verbatimTextOutput('sel')
    
    
    
  ),
  
  server = function(input, output, session) {
    dtWithRadioButton <- reactiveValues(dt = my_table)
    
    
    output$datatable <- renderDT(
      datatable(
        dtWithRadioButton$dt,
        selection = "none",
        escape = FALSE,
        options = list(
          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
    )
    

    
    list_results <- reactive({
      list_values <- list()
      for (i in unique(my_table$rowid)) {
        list_values[[i]] <- paste0(i, ": ", input[[i]])
        
      }
      list_values
    })
    
    observeEvent(input$btnProcess, {
      
      output$sel = renderPrint({
        list_results()
      })


      
    })
    

    
    observeEvent(input$btnCancel, {
      removeModal(session)
    })
  }
)

Answer 2

您可以在reactiveValues 中添加一个新变量来存储结果，使用sapply 从input 获取每个唯一id 的数据并将其存储在数据框中。

library(shiny)
library(DT)
library(shinyWidgets)

my_table <- tibble(
  rowid = letters[1:7],
  val_1 = round(runif(7, 0, 10), 1),
  val_2 = round(rnorm(7), 2),
  Yes   = "Yes",
  No    = "No",
  Maybe = "Maybe"
) %>%
  mutate(
    Yes =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , Yes),
    No =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , No),
    Maybe =  sprintf('<input type="radio" name="%s" value="%s"/>', rowid , Maybe)
  )


shinyApp(
  ui = fluidPage(
    title = 'Radio buttons in a table',
    DT::dataTableOutput("datatable"),
    actionBttn(
      inputId = "btnProcess",
      label = "Process",
      style = "float",
      size = "sm",
      color = "success"
    ),
    actionBttn(
      inputId = "btnCancel",
      label = "Cancel",
      style = "float",
      size = "sm",
      color = "warning"
    ),
    dataTableOutput('result')
  ),
  
  server = function(input, output, session) {
    dtWithRadioButton <- reactiveValues(dt = my_table, result = NULL)
    
    
    output$datatable <- renderDT(
      datatable(
        dtWithRadioButton$dt,
        selection = "none",
        escape = FALSE,
        options = list(
          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
    )
    
    
    observeEvent(input$btnProcess, {
      dt <- dtWithRadioButton$dt 
      dt$result <- sapply(unique(my_table$rowid), function(x) input[[x]])
      dtWithRadioButton$result <- dt
    })
    
    
    observeEvent(input$btnCancel, {
      removeModal(session)
    })
    
    output$result <- renderDT({
      req(dtWithRadioButton$result)
      datatable(dtWithRadioButton$result[c('rowid', 'val_1', 'val_2', 'result')])
    })
  }
)