I am trying to create a "increment filter" on a dummy dataset ("iris"). The ultimate goal is to allow users to add dynamic sets of filters through + button to filter the dataset.
I made two modules (one nested in the other). the inner module (singleFilter ) to create the dynamics for each individual set of filters which pass the a boolean filter and reactives from the inner module server. The outer module (filter ) allows + button to 1) add more filter sets, 2) combine the output from inner modules and 3) filter data to create a new data.frame. In the main app, just render the table. Here is the code (sorry for being long but i thought it is the reprex code i can generate so far).
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(tidyverse)
data("iris")
# -------------- calculate_filter --------------
calculate_filter <- function(filter_val, comp_sign, col_selected, ori_df) {
if (!is.null(filter_val)) {
if (filter_val == "") {
filter_val = NULL
}
}
if (any(map_lgl(list(filter_val, comp_sign, col_selected), is.null))) {
TRUE
} else{
if (comp_sign == "includes") {
ori_df[[col_selected]] == filter_val
} else if (comp_sign == "excludes") {
ori_df[[col_selected]] != filter_val
} else{
comparison_fn <- get(comp_sign)
boolean_array <- comparison_fn(ori_df[[col_selected]], as.numeric(filter_val))
boolean_array
}
}
}
# -------------- singleFilter module ------------
singleFilterUI <- function(id, column_choices, include_and_or = TRUE) {
ns <- NS(id)
if (include_and_or) {
column_label = NULL
or_and_widget <- column(2, selectizeInput(inputId = ns("and_or"),
label = NULL,
choices = c("AND", "OR"),
multiple = F))
bttn_style <- 'padding:0px'
} else {
or_and_widget <- column(2, h5(""))
column_label = "feature"
bttn_style <- 'padding:0px; padding-top:25px'
}
tagList(
or_and_widget,
column(2, style='padding:0px;',
selectizeInput(inputId = ns("column"),
label = column_label,
choices = column_choices,
multiple = F)
),
column(2, style='padding:0px;',
uiOutput(outputId = ns("compare_ui"))
),
column(3, style='padding:0px;',
uiOutput(outputId = ns("filter_ui"))
),
column(1, style=bttn_style,
actionButton(inputId = ns("bttn"),
label = "+"))
)
}
singleFilterServer <- function(id, df, filter_labels = NULL, text_style = "padding:0px; padding-left:1px") {
moduleServer(
id,
function(input, output, session) {
ns <- session$ns
output$compare_ui <- renderUI({
req(input$column)
col_selected <- input$column
if(class(df[[col_selected]]) == "numeric"){
choice_type <- c(">", "<", ">=", "<=", "==", "!=")
}else{
choice_type <- c("includes", "excludes")
}
pickerInput(
inputId = ns("compare"),
label = filter_labels[1],
choices = choice_type,
multiple = F
)
})
output$filter_ui <- renderUI({
req(input$column)
col_selected <- input$column
if(class(df[[col_selected]]) == "numeric"){
col_range <- range(df[[col_selected]], na.rm = T)
col_range <- format(col_range, scientific = T, digits = 2, drop0trailing=T)
tagList(
column(6, style='padding:0px;', textInput(
inputId = ns("filter"),
label = filter_labels[2], value = NULL
)),
column(2, style=text_style,
tagList(
h5(paste0("(",paste(col_range, collapse = "~"), ")"))
)
)
)
}
else{
pickerInput(
inputId = ns("filter"),
label = filter_labels[2],
choices = unique(df[[col_selected]]),
multiple = T,
options = list(`live-search`=TRUE)
)
}
})
filter <- reactive({
calculate_filter(
filter_val = input$filter,
comp_sign = input$compare,
col_selected = input$column,
ori_df = df
)
})
out <- list(
and_or = reactive(input$and_or),
button = reactive(input$bttn),
filter = filter
)
out
}
)
}
# ---------------- filter module ----------------------
filterUI <- function(id, column_choices) {
ns <- NS(id)
tagList(
fluidRow(singleFilterUI(
id = ns("single_filter"), column_choices = column_choices, include_and_or = FALSE
)),
fluidRow(uiOutput(outputId = ns("filter_group")))
)
}
filterServer <- function(id, df) {
moduleServer(
id,
function(input, output, session) {
filter_1 <- singleFilterServer(id = "single_filter", df = df, filter_labels = c("compare", "value"), text_style = 'padding:0px; padding-left:1px; padding-top:25px')
click_id <- reactiveVal(1)
## Create a reactiveValues object to store the filters we create
filters <- reactiveValues()
observe({
req(filter_1$filter())
filters[[as.character(click_id())]] <- filter_1
})
# filter data.frame
filtered_df <- reactive({
req(filter_1$filter())
the_filter <- filter_1$filter()
for (filter_id in names(filters)) {
if (is.null(filters[[filter_id]]$and_or()) || filters[[filter_id]]$and_or() == "AND") {
the_filter <- the_filter & filters[[filter_id]]$filter()
} else {
the_filter <- the_filter | filters[[filter_id]]$filter()
}
}
cat(sum(the_filter), "\n")
df[the_filter,]
})
# update UIs with + click
filter_group_ui <- reactiveValues()
# observeEvent(filters[[as.character(click_id())]]$button(),{ # <---- change here to replicate issue 2
observeEvent(filter_1$button(), {
click_id(click_id() + 1)
cat("create_filter", as.character(click_id()), ":")
new_id = as.character(click_id())
output$filter_group <- renderUI({
ns <- session$ns
filter_group_ui[[new_id]] <- singleFilterUI(id = ns(new_id), column_choices = names(df))
tagList(
reactiveValuesToList(filter_group_ui)
)
})
new_filter <- singleFilterServer(id = new_id, df = df)
filters[[new_id]] <- new_filter
})
filtered_df
}
)
}
# ----------------- main app ---------------------
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tagList(
filterUI(id = "more_filter", names(iris)),
dataTableOutput(outputId = "table")
)
)
)
server <- function(input, output) {
df <- filterServer(id = "more_filter", iris)
output$table <- renderDataTable({
df()
},
options = list(pageLength = 10))
}
shinyApp(ui = ui, server = server)
My current app issues are that 1) starting on the 2nd single Filter, the reactive failed to filter the data.frame 2) The + button click triggers endless the observeEvent when using the reactiveValues objective (filters). 3) not sure whether previous user inputs are stored in reactiveValues object filter_group_ui when increment filter.
Thank you!!!!