How to force Shiny to update the UI before a reactive process finishes?
I am working on a chat bot that works with the shinyChatR package. When the user finishes inputing the necessary information, the server takes several seconds to process the request. While this happens, the entire UI (including the chat) freezes, showing the loading message just after the process finishes
How can I force shiny to update the UI before the reactive process finishes? The following mockup will make the problem clear:
library(shiny)
library(shinyChatR)
library(promises)
library(future)
library(shinyjs)
plan(multisession)
csv_path <- "chat.csv"
id_chat <- "chat1"
id_sendMessageButton <- paste0(id_chat, "-chatFromSend")
chat_user <- "Client"
bot <- "Bot"
bot_message <- "Hello!"
# drop this if the chat log shall not be deleted
if (file.exists(csv_path)) {
file.remove(csv_path)
}
ChatData <- shinyChatR:::CSVConnection$new(csv_path, n = 100)
# Define UI
ui <- fluidPage(titlePanel("Chatbot Demo"),
chat_ui(id = id_chat, ui_title = "Chat Area"))
# Define server logic
server <- function(input, output, session) {
# Initialize chat server
chat <- chat_server(
id = id_chat,
chat_user = chat_user,
csv_path = csv_path # Using CSV to store messages
)
placa <- reactiveVal()
cedula <- reactiveVal()
trigger <- reactiveVal(F)
ChatData$insert_message(user = bot,
message = "Please enter your plate",
time = strftime(Sys.time()))
# Observe incoming messages and respond
observeEvent(cedula(),{
mensaje_actual_bot <- ChatData$get_data()[ChatData$get_data()$user=="Bot",2]
mensaje_actual_bot <- as.vector(mensaje_actual_bot[nrow(mensaje_actual_bot),])$text
mensaje_actual_cliente <- ChatData$get_data()[ChatData$get_data()$user=="Client",2]
mensaje_actual_cliente <- as.vector(mensaje_actual_cliente[nrow(mensaje_actual_cliente),])$text
if(mensaje_actual_bot=="Loading..."){
Sys.sleep(10)
result <- F
if(result){
ChatData$insert_message(user = bot,
message = "Response A",
time = strftime(Sys.time()))
}else{
ChatData$insert_message(user = bot,
message = "Response B",
time = strftime(Sys.time()))
ChatData$insert_message(user = bot,
message = "For a new query please enter your plate",
time = strftime(Sys.time()))
}
}
})
observeEvent(input[[id_sendMessageButton]], {
#browser()
mensaje_actual_bot <- ChatData$get_data()[ChatData$get_data()$user=="Bot",2]
mensaje_actual_bot <- as.vector(mensaje_actual_bot[nrow(mensaje_actual_bot),])$text
mensaje_actual_cliente <- ChatData$get_data()[ChatData$get_data()$user=="Client",2]
mensaje_actual_cliente <- as.vector(mensaje_actual_cliente[nrow(mensaje_actual_cliente),])$text
if(mensaje_actual_bot=="Please enter your plate" | mensaje_actual_bot=="For a new query please enter your plate"){
placa(mensaje_actual_cliente)
ChatData$insert_message(user = bot,
message = "Please enter your ID",
time = strftime(Sys.time()))
}
if(mensaje_actual_bot=="Please enter your ID"){
ChatData$insert_message(user = bot,
message = "Loading...",
time = strftime(Sys.time()))
cedula(mensaje_actual_cliente)
}
})
observeEvent(trigger(),{
mensaje_actual_bot <- ChatData$get_data()[ChatData$get_data()$user=="Bot",2]
mensaje_actual_bot <- as.vector(mensaje_actual_bot[nrow(mensaje_actual_bot),])$text
mensaje_actual_cliente <- ChatData$get_data()[ChatData$get_data()$user=="Client",2]
mensaje_actual_cliente <- as.vector(mensaje_actual_cliente[nrow(mensaje_actual_cliente),])$text
})
}
# Run the application
shinyApp(ui, server)
Solution
Updated answer, July 2024 (Shiny >= 1.8.1)
In shiny 1.8.1, the new ExtendedTask feature was introduced which is now recommended for non-blocking tasks in Shiny. It could be used like this in order to send the Loading message into the chat while before the processing starts and not after it finishes.
The
ExtendedTaskcontains a promises::future_promise() which defines the asynchronous operation. Here we have a delay of five seconds and then the client message after the processing is returned.idProcessing <- ExtendedTask$new(function(mensaje_actual_cliente) { future_promise({ # long computation Sys.sleep(5) # client value mensaje_actual_cliente }) })In your
observeEventon the button which sends the message theÈxtendedTaskis invoked:idProcessing$invoke(mensaje_actual_cliente)Directly after the invoking the loading message is inserted:
# execute immediately ChatData$insert_message(user = bot, message = "Loading...", time = strftime(Sys.time()))We define an
observeEventon the result of theExtendedTaskwhich gets triggered when the computation is done, then the message after the processing gets inserted.observeEvent(idProcessing$result(), { # See code below })
library(shiny)
library(shinyChatR)
library(promises)
library(future)
future::plan(multisession)
csv_path <- "chat.csv"
id_chat <- "chat1"
id_sendMessageButton <- paste0(id_chat, "-chatFromSend")
chat_user <- "Client"
bot <- "Bot"
bot_message <- "Hello!"
# drop this if the chat log shall not be deleted
if (file.exists(csv_path)) {
file.remove(csv_path)
}
# helper function
getChatDataAsVector <- function(ChatData, User) {
data <- ChatData$get_data()[ChatData$get_data()$user==User, 2]
return(as.vector(data[nrow(data),])$text)
}
ChatData <- shinyChatR:::CSVConnection$new(csv_path, n = 100)
# Define UI
ui <- fluidPage(titlePanel("Chatbot Demo"),
chat_ui(id = id_chat, ui_title = "Chat Area"))
# Define server logic
server <- function(input, output, session) {
# Initialize chat server
chat <- chat_server(
id = id_chat,
chat_user = chat_user,
csv_path = csv_path # Using CSV to store messages
)
ChatData$insert_message(user = bot,
message = "Please enter your plate",
time = strftime(Sys.time()))
idProcessing <- ExtendedTask$new(function(mensaje_actual_cliente) {
future_promise({
# long computation
Sys.sleep(5)
# client value
mensaje_actual_cliente
})
})
observeEvent(input[[id_sendMessageButton]], {
mensaje_actual_bot <- getChatDataAsVector(ChatData, "Bot")
mensaje_actual_cliente <- getChatDataAsVector(ChatData, "Client")
if(mensaje_actual_bot=="Please enter your plate" | mensaje_actual_bot=="For a new query please enter your plate"){
ChatData$insert_message(user = bot,
message = "Please enter your ID",
time = strftime(Sys.time()))
}
if(mensaje_actual_bot=="Please enter your ID"){
idProcessing$invoke(mensaje_actual_cliente)
# execute immediately
ChatData$insert_message(user = bot,
message = "Loading...",
time = strftime(Sys.time()))
}
})
# Observe incoming messages and respond
observeEvent(idProcessing$result(), {
mensaje_actual_bot <- getChatDataAsVector(ChatData, "Bot")
mensaje_actual_cliente <- getChatDataAsVector(ChatData, "Client")
if(mensaje_actual_bot=="Loading..."){
ChatData$insert_message(user = bot,
message = "Response B",
time = strftime(Sys.time()))
ChatData$insert_message(user = bot,
message = "For a new query please enter your plate",
time = strftime(Sys.time()))
}
})
}
shinyApp(ui, server)
Original answer, April 2024
Here is an example using a future_promise which should yield the desired behavior: The "loading" message is shown immediately. The ui update is not blocked by the computation.
future_promise({
# long computation
Sys.sleep(5)
# client value
mensaje_actual_cliente
}) %...>% # passed to reactive
cedula()
# execute immediatly
ChatData$insert_message(user = bot,
message = "Loading...",
time = strftime(Sys.time()))
library(shiny)
library(shinyChatR)
library(promises)
library(future)
library(shinyjs)
plan(multisession)
csv_path <- "chat.csv"
id_chat <- "chat1"
id_sendMessageButton <- paste0(id_chat, "-chatFromSend")
chat_user <- "Client"
bot <- "Bot"
bot_message <- "Hello!"
# drop this if the chat log shall not be deleted
if (file.exists(csv_path)) {
file.remove(csv_path)
}
ChatData <- shinyChatR:::CSVConnection$new(csv_path, n = 100)
# Define UI
ui <- fluidPage(titlePanel("Chatbot Demo"),
chat_ui(id = id_chat, ui_title = "Chat Area"))
# Define server logic
server <- function(input, output, session) {
# Initialize chat server
chat <- chat_server(
id = id_chat,
chat_user = chat_user,
csv_path = csv_path # Using CSV to store messages
)
placa <- reactiveVal()
cedula <- reactiveVal()
trigger <- reactiveVal(F)
ChatData$insert_message(user = bot,
message = "Please enter your plate",
time = strftime(Sys.time()))
# Observe incoming messages and respond
observeEvent(cedula(),{
mensaje_actual_bot <- ChatData$get_data()[ChatData$get_data()$user=="Bot",2]
mensaje_actual_bot <- as.vector(mensaje_actual_bot[nrow(mensaje_actual_bot),])$text
mensaje_actual_cliente <- ChatData$get_data()[ChatData$get_data()$user=="Client",2]
mensaje_actual_cliente <- as.vector(mensaje_actual_cliente[nrow(mensaje_actual_cliente),])$text
if(mensaje_actual_bot=="Loading..."){
result <- F
if(result){
ChatData$insert_message(user = bot,
message = "Response A",
time = strftime(Sys.time()))
}else{
ChatData$insert_message(user = bot,
message = "Response B",
time = strftime(Sys.time()))
ChatData$insert_message(user = bot,
message = "For a new query please enter your plate",
time = strftime(Sys.time()))
}
}
})
observeEvent(input[[id_sendMessageButton]], {
#browser()
mensaje_actual_bot <- ChatData$get_data()[ChatData$get_data()$user=="Bot",2]
mensaje_actual_bot <- as.vector(mensaje_actual_bot[nrow(mensaje_actual_bot),])$text
mensaje_actual_cliente <- ChatData$get_data()[ChatData$get_data()$user=="Client",2]
mensaje_actual_cliente <- as.vector(mensaje_actual_cliente[nrow(mensaje_actual_cliente),])$text
if(mensaje_actual_bot=="Please enter your plate" | mensaje_actual_bot=="For a new query please enter your plate"){
placa(mensaje_actual_cliente)
ChatData$insert_message(user = bot,
message = "Please enter your ID",
time = strftime(Sys.time()))
}
if(mensaje_actual_bot=="Please enter your ID"){
future_promise({
# long computation
Sys.sleep(5)
# client value
mensaje_actual_cliente
}) %...>% # passed to reactive
cedula()
# execute immediatly
ChatData$insert_message(user = bot,
message = "Loading...",
time = strftime(Sys.time()))
}
})
observeEvent(trigger(),{
mensaje_actual_bot <- ChatData$get_data()[ChatData$get_data()$user=="Bot",2]
mensaje_actual_bot <- as.vector(mensaje_actual_bot[nrow(mensaje_actual_bot),])$text
mensaje_actual_cliente <- ChatData$get_data()[ChatData$get_data()$user=="Client",2]
mensaje_actual_cliente <- as.vector(mensaje_actual_cliente[nrow(mensaje_actual_cliente),])$text
})
}
# Run the application
shinyApp(ui, server)
- grid.arrange's relative height argument didn't works well in RMarkdown
- How apply a function to every element of a matrix?
- Polar plot in R using ggplot2
- Find total length of time in multiple values of a dataset that overlaps with a given period of time
- Faster than R's `simplify2array`?
- What is the most simple way to label a data.table frequency chart in R?
- How to show dates in a secondary x-axis while the primary x-axis is numerical?
- online compiler for r-markdown document
- Unecessarily large column widths in HTML tables published by R Quarto when the table header contains special characters
- Bootstrapping a vector of results, by group in R
- Speeding Up Monte Carlo Simulations for Weather-Dependent Claims
- Is there an R class which allows to list 2 elements but shows only the first of them by default when called?
- Convert day of week number to weekday name in R
- How do you use "<<-" (scoping assignment) in R?
- Using reactivePoll to monitor and process file changes
- How to find out which graph is most similar to another graph?
- ggplot2: rectangular background behind axis text in circular bar plot
- How to simulate button click using rvest
- CMIP6, automating by month
- Covert dummy variables to single categorical in R?
- Animated reducing bar chart with gganimate
- Create an object class matrix/array from data frame
- How to add a vector of names to `sort_by()` in base R
- Among many subfolders, find CSVs starting with a given string and within ZIPs or not, and merge them while adding their names in a new column with R
- How to add a greek letter to an axis label to a 3D plot in plotly?
- bigrquery + dplyr error when using functions and sourcing from separate R script
- Shiny App Error: /v1/applications/ 400 - Validation Error Execution halted
- Rupee Unicode replacement not working in R
- Mutate multiple variable to create multiple new variables
- How to use the Stata equivalent of a foreach loop in R with mutate()