How to prevent output from running twice when inputs are inter-dependent? - r

Question

I'm developping an R Shiny-based application.
I want to keep my input consistent with available data, thus I update the selected values in selectInput.
When I change selected value in input 1, then the value of input 2 is updated, then the data is updated (just once). OK
BUT if I change selected value in input 2, then the data is updated, then the value of input 1 is updated, then the data is updated AGAIN.
Check out the "check latest_value" that is printed twice.
Initially I used renderUI rather than updateSelectInput, but at initialisation, the data is computed twice.
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type)),
uiOutput('plant_ui'),
DTOutput('plot')
),
server = function(input, output) {
data=reactive({
# req(input$type)
my_data_temp=my_data
if(length(input$type)>0){
my_data_temp=my_data_temp%>%filter(Type%in%input$type)
}
if(length(input$plant)>0){
my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
}
my_data_temp
})
latest_plant_value=reactive({
if(is.null(input$plant))data()$Plant[1]
else input$plant
})
output$plant_ui=renderUI({
sub_data=data()
selectInput(inputId = 'plant',"filtre par plant",choices = unique(sub_data$Plant),
selected=latest_plant_value())
})
output$plot <- renderDT({
print("check latest_value")
datatable(data()) })
}
)
runApp(app)
That's why I decided to use updateSelectInput based on this Alternate control of a sliderInput between a derived value and user selected value but the sequential structure of the code makes the data to be computed twice when I change input 2 value.
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
selectInput('plant','Choix du type',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
DTOutput('plot')
),
server = function(input, output,session) {
data=reactive({
# req(input$type)
my_data_temp=my_data
if(length(input$type)>0){
my_data_temp=my_data_temp%>%filter(Type%in%input$type)
}
if(length(input$plant)>0){
my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
}
my_data_temp
})
observeEvent(input$type,{
print("update type changed")
updateSelectInput(session, "plant",
selected = unique(my_data%>%filter(Type%in%input$type)%>%.$Plant)[1])
})
observeEvent(input$plant,{
print("update plant changed")
updateSelectInput(session, "type",
selected = unique(my_data%>%filter(Plant%in%input$plant)%>%.$Type)[1])
})
output$plot <- renderDT({
print("check latest_value")
datatable(data()) })
}
)
runApp(app)
Fixes like this one don't work in that case because I'm not trying to achieve the same thing three interdependent selectInput in R/Shiny application
I want the default selected value of each input to be consistent so that the filter returns at least 1 value. This of any input I change.

Answer 1

One way to get around this is to create a reactiveVal that tells the app that an updating operation is in progress, and require data to wait until that flag returns to False before running.
I've added 5 lines to your second shiny app:
To server():
# Create update in progress flag
updating_type_inprogress <- reactiveVal(FALSE)
To observeEvent(input$type ...:
# When type is changed, set flag to TRUE
updating_type_inprogress(TRUE)
To observeEvent(input$plant ...:
# Once this function has run, the updating operation is done
updating_type_inprogress(FALSE)
To data():
# Stops updating data() if the in-progress flag is TRUE
req(!updating_type_inprogress())
To renderDT():
# Stops updating renderDT() if the in-progress flag is TRUE
# this is probably optional unless there's resource-intensive code
# that doesn't depend on changes in data()
req(!updating_type_inprogress())
Here's the whole code:
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
selectInput('plant','Choix du type',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
DTOutput('plot')
),
server = function(input, output,session) {
data=reactive({
req(!updating_type_inprogress())
print(input$type)
print(input$plant)
my_data_temp=my_data
if(length(input$type)>0){
my_data_temp=my_data_temp%>%filter(Type%in%input$type)
}
if(length(input$plant)>0){
my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
}
my_data_temp
})
observeEvent(input$type,{
updating_type_inprogress(TRUE)
updateSelectInput(session, "plant",
selected = unique(my_data%>%filter(Type%in%input$type)%>%.$Plant)[1])
})
observeEvent(input$plant,{
updating_type_inprogress(FALSE)
updateSelectInput(session, "type",
selected = unique(my_data%>%filter(Plant%in%input$plant)%>%.$Type)[1])
})
updating_type_inprogress <- reactiveVal(FALSE)
output$plot <- renderDT({
req(!updating_type_inprogress())
print("check latest_value")
datatable(data()) })
}
)
runApp(app)
As you can see, when you change input$type, the data() and renderDT() functions only run once with the correctly updated values:
[1] "check latest_value"
[1] "Quebec"
[1] "Qn1"
[1] "check latest_value"
[1] "Mississippi"
[1] "Mn1"
[1] "check latest_value"
[1] "Quebec"
[1] "Qn1"

Answer 2

Interesting problem and not easy to solve! Interestingly, what you are asking for is not what you need. Observation:
If the user selects Qn2 while Input1 is "Mississippi", you first set Input1 on Quebec and then hard set Input2 on Qn1, changing the choise of the user. This is bad.
Datatable is always updated once any of the two inputs changes, hence the many re-calculations of the table.
The solution therefore is twofold:
Don't overwrite the user's choice of e.g. Qc2 to Qc1. I used an if condition for that.
Install a watchguard to only update
the datatable when its contents actually changed. I do this with a reactiveVal() that I only update when the choice of the two inputs was valid (i.e. when the result set is greater than 0).
See the result below. Watch the console output to observe the decisions.
library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
shinyApp(
ui = bootstrapPage(
selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
selectInput('plant','Choix du plant',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
DTOutput('plot')
),
server = function(input, output,session) {
latest_data <- reactiveVal(my_data)
observe({
result <- my_data %>% filter(Type %in% input$type, Plant %in% input$plant)
if(nrow(result) > 0){
latest_data(result)
}else{
cat(format(Sys.time(), "%H:%M:%S"), "Didn't update the dataframe because the choice was not valid.\n")
}
})
observeEvent(input$type,{
if(! input$plant %in% my_data$Plant[my_data$Type == input$type]){
old <- input$plant
new <- my_data %>% filter(Type %in% input$type) %>% slice(1) %>% pull(Plant) %>% as.character()
updateSelectInput(session, "plant", selected = new)
cat(format(Sys.time(), "%H:%M:%S"), "Updated input$plant from", old, "to", new, "so that it represents a valid choice for", input$type, "\n")
}else{
cat(format(Sys.time(), "%H:%M:%S"), "Didn't update input$plant", input$plant, "because it is a valid choice for", input$type, "already\n")
}
})
observeEvent(input$plant,{
updateSelectInput(session, "type",
selected = my_data %>% filter(Plant %in% input$plant) %>% slice(1) %>% pull(Type))
})
output$plot <- renderDT({
cat(format(Sys.time(), "%H:%M:%S"), "updating datatable to only include", isolate(input$plant), "and", isolate(input$type), "\n\n")
latest_data()
datatable(latest_data())
})
}
)