rselectshinyshinywidgets
When using selectizeGroupUI from shinyWidgets, how to limit default selection to a specified subset of data?
The below example code for selectizeGroupUI() works great for my needs. However by default when first invoking it selects and shows the entire dataset, before the user applies any filters.
My problem is the dataset I'm using this for is very large and takes some time to load. Is there a way to limit the initial dataset view to a subset of the data frame (in this example, manufacturer = Audi), and the user clicks another to-be-added button in order to show the complete dataset?
Example code:
library(shiny)
library(shinyWidgets)
data("mpg", package = "ggplot2")
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
tags$h3("Filter data with selectize group"),
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = c("manufacturer", "model", "trans", "class"),
selected = c("manufacturer", "model", "trans", "class"),
inline = TRUE
),
selectizeGroupUI(
id = "my-filters",
params = list(
manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
model = list(inputId = "model", title = "Model:"),
trans = list(inputId = "trans", title = "Trans:"),
class = list(inputId = "class", title = "Class:")
)
),
status = "primary"
),
DT::dataTableOutput(outputId = "table")
)
)
)
server <- function(input, output, session) {
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "my-filters",
data = mpg,
vars = vars_r
)
output$table <- DT::renderDataTable({
req(res_mod())
res_mod()
})
}
shinyApp(ui, server)
Solution
Since we are dealing with a module (and the inputs are not directly accessible), I modified the function selectizeGroupServer To include an updater for manufacturer input. The new function is called selectizeGroupServer_custom
observe({
updateSelectInput(inputId = 'manufacturer', choices = unique(rv$data$manufacturer), selected = 'audi')
})
new module:
selectizeGroupServer_modified <-
function(input, output, session, data, vars)
{
`%inT%` <- function(x, table) {
if (!is.null(table) && ! "" %in% table) {
x %in% table
} else {
rep_len(TRUE, length(x))
}
}
ns <- session$ns
shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"),
display = "none")
rv <- reactiveValues(data = NULL, vars = NULL)
observe({
if (is.reactive(data)) {
rv$data <- data()
}
else {#this will be the first data
rv$data <- as.data.frame(data)
}
if (is.reactive(vars)) { #this will be the data type for vars
rv$vars <- vars()
}
else {
rv$vars <- vars
}
for (var in names(rv$data)) {
if (var %in% rv$vars) {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0("container-",
var)), display = "table-cell")
}
else {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0("container-",
var)), display = "none")
}
}
})
observe({
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(session = session, inputId = x,
choices = vals, server = TRUE)
#CODE INSERTED HERE
if (x == 'manufacturer') {
updateSelectizeInput(session = session, inputId = x,
choices = vals, server = TRUE, selected = 'manufacturer')
}
})
})
observeEvent(input$reset_all, {
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(session = session, inputId = x,
choices = vals, server = TRUE)
})
})
observe({
vars <- rv$vars
lapply(X = vars, FUN = function(x) {
ovars <- vars[vars != x]
observeEvent(input[[x]], {
data <- rv$data
indicator <- lapply(X = vars, FUN = function(x) {
data[[x]] %inT% input[[x]]
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
if (all(indicator)) {
shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"),
display = "none")
}
else {
shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"),
display = "block")
}
for (i in ovars) {
if (is.null(input[[i]])) {
updateSelectizeInput(session = session, inputId = i,
choices = sort(unique(data[[i]])), server = TRUE)
}
}
if (is.null(input[[x]])) {
updateSelectizeInput(session = session, inputId = x,
choices = sort(unique(data[[x]])), server = TRUE)
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
})
})
observe({
updateSelectInput(inputId = 'manufacturer', choices = unique(rv$data$manufacturer), selected = 'audi')
})
return(reactive({
data <- rv$data
vars <- rv$vars
indicator <- lapply(X = vars, FUN = function(x) {
`%inT%`(data[[x]], input[[x]])
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
return(data)
}))
}
app:
library(shiny)
library(shinyWidgets)
data("mpg", package = "ggplot2")
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
tags$h3("Filter data with selectize group"),
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = c("manufacturer", "model", "trans", "class"),
selected = c("manufacturer", "model", "trans", "class"),
inline = TRUE
),
selectizeGroupUI(
id = "my-filters",
params = list(
manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
model = list(inputId = "model", title = "Model:"),
trans = list(inputId = "trans", title = "Trans:"),
class = list(inputId = "class", title = "Class:")
)
),
status = "primary"
),
DT::dataTableOutput(outputId = "table")
)
)
)
server <- function(input, output, session) {
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer_modified,
id = "my-filters",
data = mpg,
vars = vars_r
)
output$table <- DT::renderDataTable({
res_mod()
})
}
shinyApp(ui, server)
EDIT:
If we want to have a button that says "show all data", we can modify selectizeGroupUI. The new name will be selectizeGroupUI_custom
Modules and App code:
library(shiny)
library(shinyWidgets)
# SERVER MODULE -----------------------------------------------------------
selectizeGroupServer_modified <-
function(input, output, session, data, vars) {
`%inT%` <- function(x, table) {
if (!is.null(table) && !"" %in% table) {
x %in% table
} else {
rep_len(TRUE, length(x))
}
}
ns <- session$ns
shinyWidgets:::toggleDisplayServer(
session = session, id = ns("reset_all"),
display = "none"
)
rv <- reactiveValues(data = NULL, vars = NULL)
observe({
if (is.reactive(data)) {
rv$data <- data()
} else { # this will be the first data
rv$data <- as.data.frame(data)
}
if (is.reactive(vars)) { # this will be the data type for vars
rv$vars <- vars()
} else {
rv$vars <- vars
}
for (var in names(rv$data)) {
if (var %in% rv$vars) {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0(
"container-",
var
)), display = "table-cell")
} else {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0(
"container-",
var
)), display = "none")
}
}
})
observe({
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(
session = session, inputId = x,
choices = vals, server = TRUE
)
})
})
observeEvent(input$reset_all, {
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(
session = session, inputId = x,
choices = vals, server = TRUE
)
})
})
observe({
vars <- rv$vars
lapply(X = vars, FUN = function(x) {
ovars <- vars[vars != x]
observeEvent(input[[x]],
{
data <- rv$data
indicator <- lapply(X = vars, FUN = function(x) {
data[[x]] %inT% input[[x]]
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
if (all(indicator)) {
shinyWidgets:::toggleDisplayServer(
session = session, id = ns("reset_all"),
display = "none"
)
} else {
shinyWidgets:::toggleDisplayServer(
session = session, id = ns("reset_all"),
display = "block"
)
}
for (i in ovars) {
if (is.null(input[[i]])) {
updateSelectizeInput(
session = session, inputId = i,
choices = sort(unique(data[[i]])), server = TRUE
)
}
}
if (is.null(input[[x]])) {
updateSelectizeInput(
session = session, inputId = x,
choices = sort(unique(data[[x]])), server = TRUE
)
}
},
ignoreNULL = FALSE,
ignoreInit = TRUE
)
})
})
observe({
updateSelectInput(inputId = "manufacturer", choices = unique(rv$data$manufacturer), selected = "audi")
})
return(reactive({
data <- rv$data
vars <- rv$vars
indicator <- lapply(X = vars, FUN = function(x) {
`%inT%`(data[[x]], input[[x]])
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
return(data)
}))
}
# UI MODULE ---------------------------------------------------------------
selectizeGroupUI_custom <-
function(id, params, label = NULL, btn_label = "Reset filters", inline = TRUE) {
ns <- NS(id)
if (inline) {
selectizeGroupTag <- tagList(
##### NEW LOCATION FOR THE BUTTON #####
actionButton(
inputId = ns("reset_all"), label = btn_label,
style = "float: left;"
##### NEW LOCATION FOR THE BUTTON #####
),
tags$b(label), tags$div(
class = "btn-group-justified selectize-group",
role = "group", `data-toggle` = "buttons", lapply(
X = seq_along(params),
FUN = function(x) {
input <- params[[x]]
tagSelect <- tags$div(
class = "btn-group",
id = ns(paste0("container-", input$inputId)),
selectizeInput(
inputId = ns(input$inputId),
label = input$title, choices = input$choices,
selected = input$selected, multiple = ifelse(is.null(input$multiple),
TRUE, input$multiple
), width = "100%",
options = list(
placeholder = input$placeholder,
plugins = list("remove_button"), onInitialize = I("function() { this.setValue(\"\"); }")
)
)
)
return(tagSelect)
}
)
)
)
} else {
selectizeGroupTag <- tagList(tags$b(label), lapply(
X = seq_along(params),
FUN = function(x) {
input <- params[[x]]
tagSelect <- selectizeInput(
inputId = ns(input$inputId),
label = input$title, choices = input$choices,
selected = input$selected, multiple = ifelse(is.null(input$multiple),
TRUE, input$multiple
), width = "100%", options = list(
placeholder = input$placeholder,
plugins = list("remove_button"), onInitialize = I("function() { this.setValue(\"\"); }")
)
)
return(tagSelect)
}
), actionLink(
inputId = ns("reset_all"), label = btn_label,
icon = icon("remove"), style = "float: right;"
))
}
tagList(
singleton(tagList(tags$link(
rel = "stylesheet", type = "text/css",
href = "shinyWidgets/modules/styles-modules.css"
), shinyWidgets:::toggleDisplayUi())),
selectizeGroupTag
)
}
# APP ---------------------------------------------------------------------
data("mpg", package = "ggplot2")
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
tags$h3("Filter data with selectize group"),
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = c("manufacturer", "model", "trans", "class"),
selected = c("manufacturer", "model", "trans", "class"),
inline = TRUE
),
selectizeGroupUI_custom(
id = "my-filters",
params = list(
manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
model = list(inputId = "model", title = "Model:"),
trans = list(inputId = "trans", title = "Trans:"),
class = list(inputId = "class", title = "Class:")
), btn_label = "Show all data"
),
status = "primary"
),
DT::dataTableOutput(outputId = "table")
)
)
)
########### SERVER###########
server <- function(input, output, session) {
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer_modified,
id = "my-filters",
data = mpg,
vars = vars_r
)
output$table <- DT::renderDataTable({
res_mod()
})
}
shinyApp(ui, server)
- R Language - Extracting the correct Data Type in a PDF Table
- Comparing the values of a certain number previous rows with the current row
- rpart package installation in R
- An efficient way to assign value based on a min-max range and category
- Change output of the `purrr::map` function
- osmdata_sf returns failed to perform HTTP request curl::curl_fetch_memory() error in R?
- Comparing nls() to nls2() - what am I doing wrong
- How to add "variables grid" below ggplot
- How can I use predefined code snippets outside of code chunks in Quarto within RStudio/Posit?
- Wrap text for collapse rows in KableExtra for a long table in R
- Implementation of Breusch-Pagan test for random effects in plm with unbalanced panels
- Finding a value of a dataset in different ones
- Replicate matrix
- Unexpected results after converting raster data from geographic to projected coordinate system using the terra package
- How to remove rows by condition in R?
- How do I add an alias for magrittr pipe from R in vscode
- Package ‘neuralnet’ in R, rectified linear unit (ReLU) activation function?
- Sub-subtitle in a graph made with `ggplot2`
- How can I execute a statement and ignore warnings with tryCatch?
- Enumerate events where n consecutive values are not NA
- Serialize/deserialize a column with R and DuckDB
- Putting multiple plots on the same page in R?
- NA values in a non-editable date column in a datatable in a shiny app change to "Invalid Date" when clicked on
- How to enable/disable checkboxInput when certain panel is selected
- Writing robust R code: namespaces, masking and using the `::` operator
- Replacing with conditional value in dplyr case_when()
- How to assign pre-determined RGB values to polygons
- python/pandas equivalent to dplyr 1.0.0 summarize(across())
- Calculating moving average
- Estimating non-monotonic bi-exponential curve fit