Suspending event scheduling in Shiny - r

Question

I have an app with two observeEvent() handlers reacting to input A and input B and doing some stuff. Among the stuff for event A, is updating input B.
shinyApp(
ui = fluidPage(
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
observeEvent(input$A, ignoreInit = TRUE, {
message("Doing A stuff")
updateSelectInput(session, "B", selected = 10)
})
observeEvent(input$B, ignoreInit = TRUE, {
message("Doing B stuff")
})
}
)
So changing input A obviously triggers event B as well. I would like event B to be triggered only when the user is changing the value of the input and not when it is done by updateInput. Is there a way to suspend scheduling events when a expression is evaluated? I would like something like this:
shinyApp(
ui = fluidPage(
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
observeEvent(input$A, ignoreInit = TRUE, {
message("Doing A stuff")
suspendEventScheduling()
updateSelectInput(session, "B", selected = 10)
resumeEventScheduling()
})
observeEvent(input$B, ignoreInit = TRUE, {
message("Doing B stuff")
})
}
)
Documentation for observers mentions "suspended state" but I cannot find any examples as to how to actually use it.

Answer 1

In the past I have used a sentinel value pattern to work around these types of situations (see below). But it always feels very fragile. Hopefully this feature request leads to better options.
library(shiny)
shinyApp(
ui = fluidPage(
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
is_server_update <- FALSE
observeEvent(input$A, {
message("Doing A stuff")
updateSelectInput(session, "B", selected = 10)
# Unchanged value doesn't trigger an invalidation
if (input$B != 10) {
is_server_update <<- TRUE
}
}, ignoreInit = TRUE)
observeEvent(input$B, {
if (is_server_update) {
is_server_update <<- FALSE
} else {
message("Doing B stuff")
}
}, ignoreInit = TRUE)
}
)

Answer 2

After some playing around, I put together a bit of JavaScript that should do
the trick.
The idea is to keep track of suspended inputs whose values should not
change. Using an event hook, we can then check if an input event targets
one of the suspended inputs. If so, prevent it from making changes. Crucially
though, the UI still gets updated – just not the Shiny input values.
We then also need a couple of helper functions to manage the list of
suspended inputs. Here’s the JavaScript, and the R helpers:
js <-
"
// Don't actually modify the Shiny object in 'real' code!
Shiny.suspendedInputs = new Set();
$(document).on('shiny:inputchanged', function(event) {
Shiny.suspendedInputs.has(event.target.id) && event.preventDefault();
})
Shiny.addCustomMessageHandler('suspendinput', function(message) {
Shiny.suspendedInputs.add(message.id);
});
Shiny.addCustomMessageHandler('resumeinput', function(message) {
Shiny.suspendedInputs.delete(message.id);
// Last value that Shiny got is probably out of sync with the UI
Shiny.forgetLastInputValue(message.id);
})
"
suspendInput <- function(inputId, session = getDefaultReactiveDomain()) {
session$sendCustomMessage("suspendinput", list(id = inputId))
}
resumeInput <- function(inputId, session = getDefaultReactiveDomain()) {
session$sendCustomMessage("resumeinput", list(id = inputId))
}
Almost always the suspend and resume messages should be sent on different
flush cycles. Otherwise the resume is executed before the input events from
any updates have triggered, resulting in nothing happening. Another helper
to ensure “correct” usage would be in order:
suspendForNextFlush <- function(inputId, session = getDefaultReactiveDomain()) {
session$onFlush(function() suspendInput(inputId, session = session))
session$onFlushed(function() resumeInput(inputId, session = session))
}
And now we are ready to put everything together for a working app:
library(shiny)
shinyApp(
ui = fluidPage(
tags$script(HTML(js)),
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
observeEvent(input$A, {
message("Doing A stuff")
suspendForNextFlush("B")
updateSelectInput(session, "B", selected = 10)
}, ignoreInit = TRUE)
observeEvent(input$B, {
message("Doing B stuff")
}, ignoreInit = TRUE)
}
)