Goal
I am working on a shiny app and the choices for some of the selectizeInput() dropdowns should be interdependent. In additon, I'd also like to experiment with the server = TRUE option to potentially speed up the application as there will be a lot of choices to select from.
Problem
I'm able to get the interdependency working just fine when using the client-side version, but when I try using the server-side version the application does not work. I've tried a few different combinations of settings, but nothing seems to work. I've described the approaches I've tried in the comments in the reprex below. In short, when I switch from server = FALSE to server = TRUE it seems to get stuck in an invalidation loop. Any help would be greatly appreciated!
My reprex
library(shiny)
library(dplyr)
#>
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#>
#> filter, lag
#> The following objects are masked from 'package:base':
#>
#> intersect, setdiff, setequal, union
header <- tibble::tibble(
v1 = c("A", "A", "A", "B", "C", "B", "D"),
v2 = c("1", "2", "1", "1", "2", "1", "3"),
v3 = c("1", "1", "2", "1", "1", "2", "2"),
v4 = c("1", "1", "1", "2", "1", "1", "1")
)
getChoices <- function(header, ...) {
# Get arguments passed as ...
filters <- list(...)
# Drop all NULL filters which is the default value for a shiny::selectInput
# when multiple = TRUE
filters <- filters[lengths(filters) > 0]
# Drop all filters with only an empty string, "", as this is a standard
# default for shiny::selectInput when multiple = FALSE and no selection is
# made. First, check that filters isn't an empty list.
if (length(filters) > 0) {
filters <- filters[sapply(filters, function(x) !all(x == ""))]
}
# Generate list of choices that should be displayed for each column. Note
# that choices for column i should be independent of the currently selected
# value for column i, but should be dependent on the filtering based on the
# selections for all other columns.
choices <- vector("list", length(names(header)))
for (i in names(header)) {
x <- header
# exclude filter for column i
filters_sans_self <- filters[!names(filters) %in% i]
# filter data.frame down based on all filters other than i
for (j in names(filters_sans_self)) {
x <- dplyr::filter(x,!!as.symbol(j) %in% filters_sans_self[[j]])
}
# find all unique values in column i in data.frame x and include an
# empty character as an option to indicate "no selection"
choices[[i]] <- c("", sort(unique(x[[i]])))
}
choices
}
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Dynamically Linked SelectizeInput() Choices"),
sidebarLayout(
sidebarPanel(
shiny::selectizeInput("v1", "v1", choices = NULL, multiple = TRUE),
shiny::selectizeInput("v2", "v2", choices = NULL, multiple = TRUE)
),
mainPanel(shiny::tableOutput("table"))
)
)
# Define server logic
server <- function(input, output, session) {
choices <- shiny::reactive({
getChoices(header = header,
v1 = input$v1,
v2 = input$v2)
})
output$table <- shiny::renderTable({
filtered_table <- header
if (!is.null(input$v1) & !identical(input$v1, "")) {
filtered_table <- dplyr::filter(filtered_table, v1 %in% input$v1)
}
if (!is.null(input$v2) & !identical(input$v2, "")) {
filtered_table <- dplyr::filter(filtered_table, v2 %in% input$v2)
}
filtered_table
})
# This block is required if trying to set choices = NULL in the observe event
# below in order to show that the call with choices = NULL drops all of the
# choices rather than "not resulting in any change in to the input object" as
# indicated in the docs as I interpret it ... ?updateSelectizeInput:
# "Any arguments with NULL values will be ignored; they will not result in
# any changes to the input object on the client."
updateSelectizeInput(session = session, "v1", choices = unique(header$v1), server = TRUE)
updateSelectizeInput(session = session, "v2", choices = unique(header$v2), server = TRUE)
# Just as with choices = NULL, when selected = NULL, the input is changed on
# the client. If selected is just set to existing value (e.g., input$v1), then
# this triggers an invalidation of the input and creates a endless
# invalidation loop. However, if server is set to FALSE, everything works as
# expected.
shiny::observeEvent(choices(),
{
updateSelectizeInput(
session = session,
"v1",
selected = input$v1,
# selected = NULL,
choices = c(input$v1, choices()$v1),
# choices = NULL,
# server = TRUE
server = FALSE
)
updateSelectizeInput(
session = session,
"v2",
selected = input$v2,
# selected = NULL,
choices = c(input$v2, choices()$v2),
# choices = NULL,
# server = TRUE
server = FALSE
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Shiny applications not supported in static R Markdown documents
Created on 2021-09-13 by the reprex package (v2.0.1)
Session info
sessioninfo::session_info()
#> ─ Session info ───────────────────────────────────────────────────────────────
#> setting value
#> version R version 4.1.0 (2021-05-18)
#> os Ubuntu 20.04.3 LTS
#> system x86_64, linux-gnu
#> ui X11
#> language (EN)
#> collate en_US.UTF-8
#> ctype en_US.UTF-8
#> tz America/Chicago
#> date 2021-09-13
#>
#> ─ Packages ───────────────────────────────────────────────────────────────────
#> package * version date lib source
#> assertthat 0.2.1 2019-03-21 [1] CRAN (R 4.1.0)
#> bslib 0.3.0 2021-09-02 [1] CRAN (R 4.1.0)
#> cli 3.0.1 2021-07-17 [1] CRAN (R 4.1.0)
#> crayon 1.4.1 2021-02-08 [1] CRAN (R 4.1.0)
#> DBI 1.1.1 2021-01-15 [1] CRAN (R 4.1.0)
#> digest 0.6.27 2020-10-24 [1] CRAN (R 4.1.0)
#> dplyr * 1.0.7 2021-06-18 [1] CRAN (R 4.1.0)
#> ellipsis 0.3.2 2021-04-29 [1] CRAN (R 4.1.0)
#> evaluate 0.14 2019-05-28 [1] CRAN (R 4.1.0)
#> fansi 0.5.0 2021-05-25 [1] CRAN (R 4.1.0)
#> fastmap 1.1.0 2021-01-25 [1] CRAN (R 4.1.0)
#> fs 1.5.0 2020-07-31 [1] CRAN (R 4.1.0)
#> generics 0.1.0 2020-10-31 [1] CRAN (R 4.1.0)
#> glue 1.4.2 2020-08-27 [1] CRAN (R 4.1.0)
#> highr 0.9 2021-04-16 [1] CRAN (R 4.1.0)
#> htmltools 0.5.2 2021-08-25 [1] CRAN (R 4.1.0)
#> httpuv 1.6.3 2021-09-09 [1] CRAN (R 4.1.0)
#> jquerylib 0.1.4 2021-04-26 [1] CRAN (R 4.1.0)
#> jsonlite 1.7.2 2020-12-09 [1] CRAN (R 4.1.0)
#> knitr 1.33 2021-04-24 [1] CRAN (R 4.1.0)
#> later 1.3.0 2021-08-18 [1] CRAN (R 4.1.0)
#> lifecycle 1.0.0 2021-02-15 [1] CRAN (R 4.1.0)
#> magrittr 2.0.1 2020-11-17 [1] CRAN (R 4.1.0)
#> mime 0.11 2021-06-23 [1] CRAN (R 4.1.0)
#> pillar 1.6.2 2021-07-29 [1] CRAN (R 4.1.0)
#> pkgconfig 2.0.3 2019-09-22 [1] CRAN (R 4.1.0)
#> promises 1.2.0.1 2021-02-11 [1] CRAN (R 4.1.0)
#> purrr 0.3.4 2020-04-17 [1] CRAN (R 4.1.0)
#> R6 2.5.1 2021-08-19 [1] CRAN (R 4.1.0)
#> Rcpp 1.0.7 2021-07-07 [1] CRAN (R 4.1.0)
#> reprex 2.0.1 2021-08-05 [1] CRAN (R 4.1.0)
#> rlang 0.4.11 2021-04-30 [1] CRAN (R 4.1.0)
#> rmarkdown 2.10 2021-08-06 [1] CRAN (R 4.1.0)
#> rstudioapi 0.13 2020-11-12 [1] CRAN (R 4.1.0)
#> sass 0.4.0 2021-05-12 [1] CRAN (R 4.1.0)
#> sessioninfo 1.1.1 2018-11-05 [1] CRAN (R 4.1.0)
#> shiny * 1.6.0 2021-01-25 [1] CRAN (R 4.1.0)
#> stringi 1.7.4 2021-08-25 [1] CRAN (R 4.1.0)
#> stringr 1.4.0 2019-02-10 [1] CRAN (R 4.1.0)
#> tibble 3.1.4 2021-08-25 [1] CRAN (R 4.1.0)
#> tidyselect 1.1.1 2021-04-30 [1] CRAN (R 4.1.0)
#> utf8 1.2.2 2021-07-24 [1] CRAN (R 4.1.0)
#> vctrs 0.3.8 2021-04-29 [1] CRAN (R 4.1.0)
#> withr 2.4.2 2021-04-18 [1] CRAN (R 4.1.0)
#> xfun 0.25 2021-08-06 [1] CRAN (R 4.1.0)
#> xtable 1.8-4 2019-04-21 [1] CRAN (R 4.1.0)
#> yaml 2.2.1 2020-02-01 [1] CRAN (R 4.1.0)
#>
#> [1] /home/acagle/R/library
#> [2] /opt/R/4.1.0/lib/R/library