如何根据网络连接状态启用/禁用R Shiny输入控件

先说说你原代码的问题：is_online()不是Shiny的响应式对象，直接用observe(is_online())没法自动触发更新；而且你只在点击复选框时才检测网络状态，没法实时跟上网络变化。

下面是修改后的完整解决方案，同时满足控件禁用和标签灰化的需求：

RequiredLibraries <- c("shiny", "shinyjs")

RequiredLibraries2Install <- RequiredLibraries[!(RequiredLibraries %in% installed.packages()[, "Package"])]
if(length(RequiredLibraries2Install)) install.packages(RequiredLibraries2Install, dependencies = TRUE)
lapply(RequiredLibraries, library, character.only = TRUE)

is_online <- function(site = "http://www.google.com/") {
  tryCatch(
    {
      readLines(site, n=1)
      TRUE
    },
    warning = function(w) invokeRestart("muffleWarning"),
    error = function(e) FALSE
  )
}

ui <- fluidPage(
  useShinyjs(),
  # 自定义标签灰化的CSS样式
  tags$style(
    ".disabled-label {
      opacity: 0.5;
      pointer-events: none;
    }"
  ),
  mainPanel(
    tabsetPanel(type = "tabs",
                tabPanel("Reprex",
                         # 给复选框的标签单独加个ID，方便后续控制样式
                         tagList(
                           checkboxInput(
                             inputId = "Download_Some_Data", 
                             label = tags$span(id = "Download_Some_Data_label", 
                                               "Download some data only if there is an Internet connection"), 
                             value = FALSE, 
                             width = '100%'
                           )
                         )
                )
    ),
    width = 12
  )
)

server <- function(input, output, session) {
  # 用响应式变量存当前网络状态，初始化时先检测一次
  online_status <- reactiveVal(is_online())
  
  # 每隔5秒自动检测一次网络状态，更新响应式变量
  observe({
    invalidateLater(5000, session) # 5000毫秒=5秒，可按需调整间隔
    online_status(is_online())
  })
  
  # 根据网络状态更新控件和标签
  observe({
    current_status <- online_status()
    # 启用/禁用复选框
    toggleState(id = "Download_Some_Data", condition = current_status)
    # 给标签加/移除灰化样式
    if(current_status) {
      removeClass(id = "Download_Some_Data_label", class = "disabled-label")
    } else {
      addClass(id = "Download_Some_Data_label", class = "disabled-label")
    }
  })
}

runApp(list(ui = ui, server = server), launch.browser = TRUE)

关键改动说明 #

1. 定时自动检测网络：用invalidateLater每隔5秒触发一次网络检测，确保网络状态变化时能实时更新控件状态，不用等用户点击复选框。
2. 标签灰化处理：给复选框的标签加了单独的ID，配合自定义CSS类，用addClass和removeClass控制标签的灰化效果，实现和控件同步的状态变化。
3. 初始状态正确显示：页面加载时就会检测一次网络状态，控件和标签一开始就显示正确的状态。

可选优化：用客户端API检测网络 #

如果想更准确地判断用户本地的网络状态（而不是服务器到外部站点的连接），可以用浏览器自带的navigator.onLineAPI，不用服务器端请求：

在UI里加这段脚本：

tags$script(
  "
  // 监听网络状态变化，把状态传给Shiny
  window.addEventListener('online', () => Shiny.setInputValue('client_online', true));
  window.addEventListener('offline', () => Shiny.setInputValue('client_online', false));
  // 页面加载时先传一次初始状态
  Shiny.setInputValue('client_online', navigator.onLine);
  "
)

然后把server里的网络状态部分改成：

# 直接用客户端传来的状态
online_status <- reactiveVal(input$client_online)

observe({
  online_status(input$client_online)
})

这种方式更贴合用户实际的网络情况，也避免了服务器频繁请求外部站点。

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