I have an R shiny app that works fine, but when I retrieve the data by pressing the ´Get data´ button all the components within the server function get executed twice, and I only want them to be executed once. The reason I only want it to be executed once, is that the second execution causes re-rendering of plots in the app which is noticeable when I run it on a remote server.
Ive attached a simplified version of the code. Note that the ranges variable is not applied in this simplified version, but I am including it to show the differences between the two reactive datasets dat_subset and **dat_filt ** , which are needed for the real app to work as expected.
I know that the code does get executed twice because of the invalidateLater(500) code - but if I do not include that, the plots do not re-render when I filter the reactable.
I only want the code to be executed once when I press get_data, but I also want the column plot to re-render and update when I filter the data in the table.
So my question is, can I trigger re-rendering of the plot when the table is filtered without having to use the invalidateLater function?
Here is the code:
library(shiny)
library(htmlwidgets)
library(reactable)
library(tidyr)
library(dplyr)
library(ggplot2)
library(shinyjs)
library(shinyWidgets)
jsCode <- 'shinyjs.getSortedAndFilteredData = function() {
try {
var instance = Reactable.getInstance("dat_table");
if (instance) {
var filteredIdx = instance.sortedFlatRows.map(x => x.index + 1);
Shiny.onInputChange("filtered_data", filteredIdx);
}
} catch (err) {
console.error(err);
}
}'
# Define UI for application that draws a histogram
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("getSortedAndFilteredData")),
theme = shinythemes::shinytheme("lumen"),
fluidRow(
column(width = 10,
actionButton("get_data", "Get Data", class = "btn-primary")
)
),
fluidRow(
column(width = 7,
plotOutput("age_distribution_plot", height = 300)
)
),
fluidRow(
column(width = 10,
reactableOutput("dat_table")
)
)
)
get_age_cat_plot = function(dat){
dat$age_cat <- cut(dat$age, breaks=c(6, 11, 21, 36, Inf), labels = c("<10","11-20","21-35","36+"), right = TRUE)
d <- dat %>% group_by(gender, age_cat) %>% summarise(count = n(), .groups="keep") %>% na.omit()
d %>%
ggplot(aes(factor(age_cat, levels=rev(levels(dat$age_cat))), count, fill = gender)) +
scale_fill_manual(values = c("M"="#7285A5","F" = "pink3","U"="lightgray"))+
geom_col(alpha=0.3, width=0.8, color="darkgrey") + theme_classic()+
geom_text(aes(label = count), # Adding percentage labels
position = position_stack(vjust = 0.5),
color = "black", size = 5) +labs(y = "age", x="count")
}
server <- shinyServer(function(input, output, session) {
ranges <- reactiveValues(x = NULL, y = NULL)
gene_table_ready <- reactiveVal(FALSE)
dat <- eventReactive(input$get_data,{
print("GETTING THE DATA ")
ranges$x <- NULL; ranges$y <- NULL
gene_table_ready(TRUE)
age <- sample(0:75, 200, replace = TRUE)
gender <- sample(c("M", "F"), 200, replace = TRUE)
data.frame(age = age, gender = gender)
})
dat_subset <- reactive({
print("getting dat subset")
dat <- dat()
if (!is.null(ranges$x))
dat <- subset(dat, chr_start >= ranges$x[1] & chr_start <= ranges$x[2])
dat
})
observe({
if(gene_table_ready()){
js$getSortedAndFilteredData()
invalidateLater(500)
}
})
dat_filt <- reactive({
print("FILTERING....")
dat <- dat_subset()
if(!is.null(input$filtered_data))
dat <- dat[input$filtered_data, ]
dat
})
output$dat_table <- renderReactable({
print("Updating the data table")
dat <- dat_subset()
reactable(
dat,
filterable = TRUE,
)
})
output$age_distribution_plot <- renderPlot({
print("Getting age cat plot... ")
get_age_cat_plot(dat_filt())
})
})
shinyApp(ui = ui, server = server)
The problem is that when dat_subset gets invalidated, it invalidates both dat_filt and dat_table. Then there is a race condition about which chain of consequences finishes first. But actually, the table update and then JS update of input$filtered_data is very slow. Your plot renders first, but it correctly uses the newest dat_filt with the incorrect old input$filtered_data. So the first plot that flashes up briefly is wrong.
I suggest adding a reactiveVal to buffer the input$filtered_data. Use an observer to update it with the JS filtering updates. But when you recompute dat, manually set the reactiveVal to what you know will eventually come from the updated input$filtered_data.
library(shiny)
library(htmlwidgets)
library(reactable)
library(tidyr)
library(dplyr)
library(ggplot2)
library(shinyjs)
library(shinyWidgets)
jsCode <- 'shinyjs.getSortedAndFilteredData = function() {
try {
var instance = Reactable.getInstance("dat_table");
if (instance) {
var filteredIdx = instance.sortedFlatRows.map(x => x.index + 1);
Shiny.onInputChange("filtered_data", filteredIdx);
}
} catch (err) {
console.error(err);
}
}'
# Define UI for application that draws a histogram
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("getSortedAndFilteredData")),
theme = shinythemes::shinytheme("lumen"),
fluidRow(
column(width = 10,
actionButton("get_data", "Get Data", class = "btn-primary")
)
),
fluidRow(
column(width = 7,
plotOutput("age_distribution_plot", height = 300)
)
),
fluidRow(
column(width = 10,
reactableOutput("dat_table")
)
)
)
get_age_cat_plot = function(dat){
dat$age_cat <- cut(dat$age, breaks=c(6, 11, 21, 36, Inf), labels = c("<10","11-20","21-35","36+"), right = TRUE)
d <- dat %>% group_by(gender, age_cat) %>% summarise(count = n(), .groups="keep") %>% na.omit()
d %>%
ggplot(aes(factor(age_cat, levels=rev(levels(dat$age_cat))), count, fill = gender)) +
scale_fill_manual(values = c("M"="#7285A5","F" = "pink3","U"="lightgray"))+
geom_col(alpha=0.3, width=0.8, color="darkgrey") + theme_classic()+
geom_text(aes(label = count), # Adding percentage labels
position = position_stack(vjust = 0.5),
color = "black", size = 5) +labs(y = "age", x="count")
}
server <- shinyServer(function(input, output, session) {
ranges <- reactiveValues(x = NULL, y = NULL)
gene_table_ready <- reactiveVal(FALSE)
# Add a buffer that you can control. Use filtered_data_2() instead of input$filtered_data
filtered_data_2 <- reactiveVal(NULL)
observeEvent(input$filtered_data, {
filtered_data_2(input$filtered_data)
})
dat <- eventReactive(input$get_data,{
print("GETTING THE DATA ")
ranges$x <- NULL; ranges$y <- NULL
gene_table_ready(TRUE)
filtered_data_2(1:200) # Force the update here. Shiny will ignore the JS update that is the same as this.
age <- sample(0:75, 200, replace = TRUE)
gender <- sample(c("M", "F"), 200, replace = TRUE)
data.frame(age = age, gender = gender)
})
dat_subset <- reactive({
print("getting dat subset")
dat <- dat()
if (!is.null(ranges$x))
dat <- subset(dat, chr_start >= ranges$x[1] & chr_start <= ranges$x[2])
dat
})
observe({
if(gene_table_ready()){
js$getSortedAndFilteredData()
invalidateLater(500)
}
})
dat_filt <- reactive({
print("FILTERING....")
dat <- dat_subset()
if(!is.null(filtered_data_2())) # use the new reactiveVal
dat <- dat[filtered_data_2(), ] # use the new reactiveVal
dat
})
output$dat_table <- renderReactable({
print("Updating the data table")
dat <- dat_subset()
reactable(
dat,
filterable = TRUE,
)
})
output$age_distribution_plot <- renderPlot({
print("Getting age cat plot... ")
get_age_cat_plot(dat_filt())
})
})
shinyApp(ui = ui, server = server)