Search code examples
rshiny

How to force shiny to update UI before 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 ExtendedTask contains 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 observeEvent on the button which sends the message the ÈxtendedTask is 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 observeEvent on the result of the ExtendedTask which gets triggered when the computation is done, then the message after the processing gets inserted.

      observeEvent(idProcessing$result(), {
  # See code below
})

    enter image description here

    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()))

    enter image description here

    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)