從 Shiny DT 中的單選按鈕中提取用戶輸入值到 dataframe 或列表中

Question

我正在構建一個 shiny 應用程序，該應用程序帶有一個數據表，該數據表使用一些 javascript 回調，用戶可以在其中為每一行進行選擇（是/否/也許），然后在應用程序的后期階段，我需要用戶以列表或表格。 未預定義確切的行數。 理想情況下，我想總結一下每個用戶選擇了多少“是”/“否”/“可能”以及如何選擇哪些行為否。 我可以將這些值打印到 R 終端，但這還不夠，這些值需要保存為 object。

這是迄今為止我所擁有的代碼的簡短示例（基於Shiny 數據表上的單選按鈕，帶有 data.frame / data.table和提取 Z531704A02607A1646Z DT 中所選單選按鈕的值 DT EE1 ）

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

您可以在reactiveValues添加一個新變量來存儲結果，使用sapply從每個唯一id的input中獲取數據，並將其存儲在 dataframe 中。

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')])
    })
  }
)

Answer 2

您可以在reactive中進行計算，然后在observeEvent中調用該reactive式，並使用您選擇的任何 output 方法將其顯示為文本或 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)
    })
  }
)