Enabling/Disabling an R shiny input depending on the Internet connection

Is it possible with shinyjs to enable or disable a whole input depending on the state of the Internet connection of the user (i.e. on or off)?

I commented below what I think would be needed - observing the function testing for an Internet connection - but that doesn't work of course as it is no Shiny input.

Here is a reprex:

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(),
    mainPanel(
        tabsetPanel(type = "tabs",
            tabPanel("Reprex",
                checkboxInput(inputId = "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)
{
    observeEvent(input[["Download_Some_Data"]],
    {
        toggleState(id = "Download_Some_Data", condition = is_online())
    })
    
    # observe(is_online(),
    # {
        # toggleState(id = "Download_Some_Data", condition = is_online())
    # })
}

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

EDIT: Also, even if it's kind of secondary, is it possible to grey out the input's label (i.e. in my case, not only the check box but 'Download some data only if there is an Internet connection' too)?

Solution

We can use curl::has_internet() or httr2::is_online() along with invalidateLater to check the internet connection:

library(shiny)
library(shinyjs)
library(curl)
# alternative:
# httr2::is_online()

ui <- fluidPage(useShinyjs(),
                tags$head(
                  tags$style(
                    HTML(
                    "
                    .grey-out {
                      color: lightgrey;
                    }"
                    )
                  )),
                mainPanel(tabsetPanel(
                  type = "tabs", tabPanel(
                    "Reprex",
                    checkboxInput(
                      inputId = "Download_Some_Data",
                      label = span(id = "DSD_label", "Download some data only if there is an Internet connection"),
                      value = FALSE,
                      width = '100%'
                    )
                  )
                ), width = 12))

server <- function(input, output, session) {
  host_is_online <- reactiveVal(NULL)
  observe({
    invalidateLater(500L)
    host_is_online(curl::has_internet())
  })
  observeEvent(host_is_online(), {
    toggleState(id = "Download_Some_Data", condition = host_is_online())
    toggleClass(id = "DSD_label", class = "grey-out", condition = !host_is_online())
  })
}

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

Alternative - if you need that info only for a single element:

library(shiny)
library(shinyjs)
library(httr2)

ui <- fluidPage(useShinyjs(), mainPanel(tabsetPanel(
  type = "tabs", tabPanel(
    "Reprex",
    checkboxInput(
      inputId = "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) {
  observe({
    invalidateLater(500L)
    toggleState(id = "Download_Some_Data", condition = httr2::is_online())
  })
}

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