Implementing Feedback in R / Shiny with DT DataTables rows per select input choice not working / crashing

user_3949008 0
Viewed 441

I am trying to build a feedback system. Here is a simplified example what I am trying to build. I have a DT:datatable that is rendered with a feedback column, based on a selected input choice.

The feedback is submitted through the observeEvent on a submit button. All the UI and server components are mostly as I want.

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)

However, upon submission, one of two things happens:

  1. App crashes with the following error in write.table. But, the root causes is that this line of code is returning a list of NULL values instead of my feedback inputs.
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)]]
    )
  })
  1. When the app does not crash, and Feedback gets submitted, but the new inputs don't take effect. Only the first ever submission is repeated written to the CSV.

Any idea where I am going wrong with this app?

Additional Info: It is my hunch that the crash happens when I get from a selection from 'fewer rows' DT to more rows, and not the other way. For example, if I select 8 CYL first, which has more cars, and then 4, the app does not crash on submit. But the reverse, it does. BTW - in either case, my feedback does not get updated.

dt shiny r
1 Answers

To avoid the app from crashing write the line

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

just before write.table()

Please note that lapply returns a list, hence your first issue.

Next, recycling input IDs in radio buttons is also an issue. By defining unique IDs, you can make it work. Lastly, to ensure that the radio buttons work all the time, it is best to define new IDs. If the IDs are fixed for a given cyl value, it will only work the first time. Subsequent selection of that cyl will display the initial selection, which can be updated via updateradioButtons, but that will not be reactive. Try this and modify display table to your needs.

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)
user_133332790
Related