如何强制Shiny在响应式进程完成前更新UI？

架构老林

2026-6-25

问题描述

我正在开发一个基于shinyChatR包的聊天机器人。当用户输入完必要信息后，服务器需要数秒时间处理请求，在此期间整个UI（包括聊天界面）会冻结，加载消息仅在进程结束后才会显示。

如何强制Shiny在响应式进程完成前更新UI？以下示例代码可清晰展示该问题：

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!"

# 保留聊天记录则删除此段
if (file.exists(csv_path)) {
  file.remove(csv_path)
}

ChatData <- shinyChatR:::CSVConnection$new(csv_path, n = 100)

# 定义UI
ui <- fluidPage(titlePanel("Chatbot Demo"),
                chat_ui(id = id_chat, ui_title = "Chat Area"))

# 定义服务器逻辑
server <- function(input, output, session) {
  
  # 初始化聊天服务器
  chat <- chat_server(
    id = id_chat,
    chat_user = chat_user,
    csv_path = csv_path  # 使用CSV存储消息
  )
  placa <- reactiveVal()
  cedula <- reactiveVal()
  trigger <- reactiveVal(F)
  ChatData$insert_message(user = bot,
                          message = "Please enter your plate",
                          time = strftime(Sys.time()))
  
  # 监听用户输入并响应
  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]], {
    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
    
  })
}

# 运行应用
shinyApp(ui, server)

解决方案

问题根源是耗时操作（如Sys.sleep(10)）阻塞了Shiny主线程，导致UI无法即时更新。通过future和promises实现异步处理，可让UI先显示加载状态，后台完成任务后再更新结果。

修改后的代码如下：

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!"

# 保留聊天记录则删除此段
if (file.exists(csv_path)) {
  file.remove(csv_path)
}

ChatData <- shinyChatR:::CSVConnection$new(csv_path, n = 100)

# 定义UI
ui <- fluidPage(titlePanel("Chatbot Demo"),
                chat_ui(id = id_chat, ui_title = "Chat Area"))

# 定义服务器逻辑
server <- function(input, output, session) {
  
  # 初始化聊天服务器
  chat <- chat_server(
    id = id_chat,
    chat_user = chat_user,
    csv_path = csv_path  # 使用CSV存储消息
  )
  placa <- reactiveVal()
  ChatData$insert_message(user = bot,
                          message = "请输入你的车牌",
                          time = strftime(Sys.time()))
  
  # 监听用户输入并响应
  observeEvent(input[[id_sendMessageButton]], {
    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 == chat_user, 2]
    mensaje_actual_cliente <- as.vector(mensaje_actual_cliente[nrow(mensaje_actual_cliente), ])$text
    
    if(mensaje_actual_bot == "请输入你的车牌" | mensaje_actual_bot == "如需新查询，请输入你的车牌"){
      placa(mensaje_actual_cliente)
      ChatData$insert_message(user = bot,
                              message = "请输入你的身份证号",
                              time = strftime(Sys.time()))
    }
    
    if(mensaje_actual_bot == "请输入你的身份证号"){
      # 先插入加载消息，立即更新UI
      ChatData$insert_message(user = bot,
                              message = "加载中...",
                              time = strftime(Sys.time()))
      
      # 将耗时任务放入后台异步执行
      future({
        Sys.sleep(10)  # 模拟耗时处理
        result <- FALSE  # 模拟处理结果
        return(result)
      }) %...>% {
        # 后台任务完成后，更新聊天消息
        if(.){
          ChatData$insert_message(user = bot,
                                  message = "响应A",
                                  time = strftime(Sys.time()))
        } else {
          ChatData$insert_message(user = bot,
                                  message = "响应B",
                                  time = strftime(Sys.time()))
          ChatData$insert_message(user = bot,
                                  message = "如需新查询，请输入你的车牌",
                                  time = strftime(Sys.time()))
        }
      } %>% catch(function(e){
        # 处理异步任务中的错误
        ChatData$insert_message(user = bot,
                                message = "处理出错，请重试",
                                time = strftime(Sys.time()))
      })
    }
  })
}

# 运行应用
shinyApp(ui, server)

关键改动说明

移除原代码中监听cedula()的阻塞逻辑，将耗时操作直接整合到发送按钮的监听事件中
使用future()将Sys.sleep(10)等耗时任务放到后台进程执行，避免阻塞Shiny主线程
通过%...>%链式调用，在后台任务完成后再插入最终响应消息
添加错误捕获逻辑，处理异步任务中可能出现的异常

内容的提问来源于stack exchange，提问作者Ekapunk

如何强制Shiny在响应式进程完成前更新UI？

关键改动说明 #

关键改动说明