如何在R Shiny中建立动态滤镜？

Question

I am building an App with an upload function and a filter function for category variables. That way, users are able to do a bit of data manipulation by specifying columns and values. However, the filter function does not work. The code is simplified as following:

#ui.R
library(shiny)

fluidPage(
  titlePanel("Test Dynamic Column Selection"),
  sidebarLayout(
    sidebarPanel(
      fileInput('file1', 'Choose CSV File',
            accept=c('text/csv', 
                     'text/comma-separated-values,text/plain', 
                     '.csv')),
      hr(),
      checkboxInput('header', 'Header', TRUE),
      radioButtons('sep', 'Separator',
               c(Comma=',',
                 Semicolon=';',
                 Tab='\t'),
               ','),
      hr(),
      uiOutput("choose_columns"),
      hr(),
      uiOutput("choose_column"),
      textInput('column_value', label = 'Value'),
      actionButton('filter', label = 'Filter')
    ),
    mainPanel(
      tableOutput('contents')
    )
  )
)

#server.R
library(shiny)

function(input, output) {

  uploaded_data <- reactive({
    inFile <- input$file1
    read.table(inFile$datapath, header=input$header, sep=input$sep, quote=input$quote)
  })

  react_vals <- reactiveValues(data = NULL)

  output$choose_columns <- renderUI({
    if(is.null(input$file1))
      return()

    colnames <- names(react_vals$data)

    checkboxGroupInput("choose_columns", "Choose columns", 
                   choices  = colnames,
                   selected = colnames)
  })

  output$choose_column <- renderUI({
    if(is.null(input$file1))
      return()
    is_factor <- sapply(react_vals$data, is.factor)
    colnames <- names(react_vals$data[, is_factor])
    selectInput("choose_column", "Choose column", choices = colnames)
  })

  observeEvent(input$file1, react_vals$data <- uploaded_data())
  observeEvent(input$choose_columns, react_vals$data <- react_vals$data[, input$choose_columns])

  # This line of code does not work :(
  observeEvent(input$filter, react_vals$data <- subset(react_vals$data, input$choose_column != input$column_value))

  output$contents <- renderTable(react_vals$data)
}

Answer 1

I think there were multiple problems with your app, I try to explain it step by step:

1. input$choose_columns is dependent on the react_vals$data reactive value, and thus when unchecking a checkbox, Shiny assigns a new value to react_vals$data with one less column, and then rerenders the input$choose_columns UI, so that there is one less checkbox available. (Same thing with the input$choose_column selectInput )

Your code:

colnames <- names(react_vals$data)

Replacement code:

colnames <- names(uploaded_data())

2. Use req() when checking whether a file is uploaded, UI is rendered, etc. It is best practice.

Your code:

if(is.null(input$file1)) return()

Replacement code:

req(input$file1)

3. Filtering is not working. Basically why it didn't work is that it tries to subset based on comparing two strings from input$choose_column and input$column_value .

ie: "Column name A" != "Value: something"

Which returns TRUE usually for every rows, and it ended up not filtering at all.

I came up with 2 solutions, they are a little bit ugly, so if someone comes up with a better solution, feel free to comment/edit.

#server.R
library(shiny)
function(input, output) {

  uploaded_data <- reactive({
    inFile <- input$file1
    read.table(inFile$datapath, header=input$header, sep=input$sep, quote=input$quote)
  })

  react_vals <- reactiveValues(data = NULL)

  output$choose_columns <- renderUI({
    req(input$file1)

    colnames <- names(uploaded_data())
    checkboxGroupInput("choose_columns", "Choose columns", 
                       choices  = colnames,
                       selected = colnames)
  })

  output$choose_column <- renderUI({
    req(input$file1)
    is_factor <- sapply(uploaded_data(), is.factor)
    colnames <- colnames(uploaded_data()[is_factor])
    selectInput("choose_column", "Choose column", choices = colnames)
  })

  observeEvent(input$file1, react_vals$data <- uploaded_data())
  observeEvent(input$choose_columns, react_vals$data <- uploaded_data()[, input$choose_columns])

  observeEvent(input$filter, {
    react_vals$data <-
      #Option A
      eval(parse(text = sprintf("subset(uploaded_data(), %s != '%s')", input$choose_column, input$column_value)))

      #Option B
      #subset(uploaded_data(), uploaded_data()[, which(names(uploaded_data()) == input$choose_column)] != input$column_value)
  })

  output$contents <- renderTable(react_vals$data)
}

shinyApp(ui, server)