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

Question

I am building a shiny app with a datatable that uses some javascript callback in which users can make a selection for every row (yes/no/maybe), in a later stage of the app I then need that user input in the form of a list or table. The exact number of rows is not predefined. Ideally I would like to make the a summary on how many 'yes'/'no'/'maybe' were selected per user and how which rows were selected as no. I can print the values into the R terminal, but that is not sufficient, the values, need to be saved as an object.

Here is a short example of the code I have thusfar (based on Radio Buttons on Shiny Datatable, with data.frame / data.table and 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)
    })
  }
)

For many bonus points, having some.css code to change the colours of the rows dependent on the radio button would be amazing (say red for no, green for yes and yellow for maybe).

Answer 1

You could add a new variable in reactiveValues to store the result, get the data from input for each unique id using sapply and store it in 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

You can do the calculation in a reactive and then call that reactive inside an observeEvent and display it as a text or a DT table using any output method of your choice.

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