The below will dynamically create sliderinputs via renderUI/uiOutput with default values coming from the cgroup while at the same time not overwriting any changes in the currently selected user values whenever an input is added or deleted.
The only time the original default values are restored back to the amount column in the cgroup input is when the cgroup input selection itself is changed, otherwise the presently selected values are kept.
This is all the desired function of how the app must function; however, whenever the cgroup filter is changed there is a brief flicker in between where it does not have the xlim value defined. I thought there may be a way such as freezeReactiveValue to prevent this flicker from occurring but I have not been able to figure out a proper solution.
How can I prevent this flicker from occurring? Thank you for your help.
library(shiny)
library(tidyverse)
colorchoice <- c("red","blue","green","purple","orange","yellow")
colorgroup <- as_tibble_col(colorchoice[1:4],column_name = "color") %>%
mutate(group=as_factor("group1"), amount = case_when(color=="red" ~ 30,
color=="blue" ~ 10,
color=="purple" ~ 150,
color=="yellow" ~ 1000,
color=="green" ~ 600,
TRUE ~ 5))
colorgroup <- rbind(colorgroup,
as_tibble_col(colorchoice[2:6],column_name = "color") %>%
mutate(group="group2", amount = case_when(color=="red" ~ 800,
color=="blue" ~ 952,
color=="purple" ~ 5,
color=="yellow" ~ 50,
color=="green" ~ 35,
TRUE ~ 588)))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput('cgroup', 'Color Group:',
choices = levels(colorgroup$group),
selected = 'group1',
multiple = FALSE),
selectizeInput("si", "Colors", choices = colorchoice, multiple = TRUE),
uiOutput("col"),
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session) {
observe({
r <- colorgroup %>%
filter(group==input$cgroup) %>%
dplyr::select(color)
updateSelectizeInput(session, "si","Colors",
server = TRUE,
choices = colorchoice,
selected = r$color)
})
col_names <- reactive(paste0(input$si))
output$col <- renderUI({
map(req(col_names()), ~ {
old_val <- isolate(input[[.x]])
if (!isTruthy(old_val)) {
old_val <- colorgroup %>%
filter(group == input$cgroup) %>%
filter(color == .x) %>%
pull(amount)
}
sliderInput(.x, label = .x, min = 0, max = 1000, value = old_val)
})
})
output$plot <- renderPlot({
cols <- map_chr(col_names(), ~ input[[.x]] %||% "")
# convert empty inputs to transparent
cols[cols == ""] <- NA
barplot(
rep(1, length(cols)),
col = cols,
space = 0,
axes = FALSE
)
}, res = 96)
}
shinyApp(ui = ui, server = server)