Use Shiny to choose column, equality, and value to filter by conditions

[MayaGans]

I'm creating a Shiny app where I'd like the user to be able to select a column and condition, resulting in the input$COLUMN input$CONDITION input$VALUE which can be used to filter a dataframe.

Desired Output

iris %>% filter(input$COLUMN input$CONDITION input$VALUE) == iris %>% filter(Sepal.Length > 4.7)

For this to work I need to use rlang for the input$COLUMN , I need to eval the input$CONDITION and I need the input$VALUE to be converted to a numeric when appropriate. (I'm attempting this in my verbatimTextOutput )

What is the best approach for achieving this? I thought making the whole expression a string to be parsed within a tidy pipeline may be the way to go but I am open to alternate suggestions!!

library(shiny)
library(tidyverse)


ui <- fluidPage(

   # Sidebar with an input for column
   # boolean input
   # and value input
   sidebarLayout(
      sidebarPanel(
        fluidRow(column(4, selectInput("COLUMN", "Filter By:", choices = colnames(iris))),
                 column(4, selectInput("CONDITION", "Boolean", choices = c("==", "!=", ">", "<"))),
                 column(4, uiOutput("COL_VALUE")))
      ),

      # Show text generated by sidebar
      # use text in tidy pipeline to create subsetted dataframe
      mainPanel(
         verbatimTextOutput("as_text"),
         tableOutput("the_data")
      )
   )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

  output$COL_VALUE <- renderUI({
    x <- iris %>% select(!!sym(input$COLUMN))
    selectInput("VALUE", "Value", choices = x)
  })

  filtering_string <- reactive ({
    paste0("!!sym(", input$COLUMN, ") ", input$CONDITION, " ", input$VALUE)
  })

   output$as_text <- renderText({
     filtering_string()
   })


   output$the_data <- renderTable({
     iris %>%
       eval(parse(text = filtering_string()))
   })
}

# Run the application 
shinyApp(ui = ui, server = server)

[paleolimbot]

I imagine you should limit the functions that could possibly get called (lest somebody try to sneak unlink() or something as an operator value. Perhaps something like the following?

library(tidyverse)

allowed_operators <- c(">", ">=", "==", "<=", "==") %>% 
  set_names() %>% 
  map(match.fun)

filtering_expr <- function(input) {
  column <- rlang::sym(input$COLUMN)
  operator <- allowed_operators[[input$CONDITION]]
  if (is.null(operator)) {
    rlang::abort(glue::glue("Can't use operator `{input$CONDITION}`"))
  }
  value <- as.numeric(input$VALUE)
  
  call <- rlang::call2(operator, column, value)
  rlang::as_quosure(call, env = emptyenv())
}

input <- list(COLUMN = "Sepal.Length", CONDITION = ">", VALUE = "4.7")

iris %>% 
  dplyr::filter(!!filtering_expr(input)) %>% 
  as_tibble()
#> # A tibble: 139 x 5
#>    Sepal.Length Sepal.Width Petal.Length Petal.Width Species
#>           <dbl>       <dbl>        <dbl>       <dbl> <fct>  
#>  1          5.1         3.5          1.4         0.2 setosa 
#>  2          4.9         3            1.4         0.2 setosa 
#>  3          5           3.6          1.4         0.2 setosa 
#>  4          5.4         3.9          1.7         0.4 setosa 
#>  5          5           3.4          1.5         0.2 setosa 
#>  6          4.9         3.1          1.5         0.1 setosa 
#>  7          5.4         3.7          1.5         0.2 setosa 
#>  8          4.8         3.4          1.6         0.2 setosa 
#>  9          4.8         3            1.4         0.1 setosa 
#> 10          5.8         4            1.2         0.2 setosa 
#> # … with 129 more rows

^{Created on 2019-12-16 by the reprex package (v0.2.1)}

[Hlynur]

I'm almost certain this is not the way to go, but this works.

library(shiny)
library(tidyverse)


ui <- fluidPage(
  
  # Sidebar with an input for column
  # boolean input
  # and value input
  sidebarLayout(
    sidebarPanel(
      fluidRow(column(4, selectInput("COLUMN", "Filter By:", choices = colnames(iris))),
               column(4, selectInput("CONDITION", "Boolean", choices = c("==", "!=", ">", "<"))),
               column(4, uiOutput("COL_VALUE")))
    ),
    
    # Show text generated by sidebar
    # use text in tidy pipeline to create subsetted dataframe
    mainPanel(
      verbatimTextOutput("as_text"),
      tableOutput("the_data")
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  
  output$COL_VALUE <- renderUI({
    x <- iris %>% select(!!sym(input$COLUMN))
    selectInput("VALUE", "Value", choices = x, selected = x[1])
  })
  
  filtering_string <- reactive ({
    paste0("filter(iris, ", input$COLUMN, " ", input$CONDITION, " ", input$VALUE, ")")
  })
  
  output$as_text <- renderText({
    filtering_string()
  })
  
  
  output$the_data <- renderTable({
      eval(parse(text = filtering_string()))
  })
}

# Run the application 
shinyApp(ui = ui, server = server)