R/app_utils-general.R

In isoexplorer: GUI Components to Explore Stable Isotope Data Files

# app utility functions =====

# inject CSS/JS required by the app
use_app_utils <- function() {
  tagList(
    shinyjs::useShinyjs(),
    # adopt error color of the theme and make error validation larger
    tags$style(HTML(
      ".shiny-output-error-validation {
        color: var(--bs-danger) !important;
        font-size: 1.5rem;
      }"
    )) |>
      singleton(),
    # support ansi color codes from cli
    tags$style(HTML(paste(format(cli::ansi_html_style()), collapse = "\n"))) |>
      singleton(),
    # make card headings taller
    tags$style(HTML(".card-header { padding: 1rem 1.25rem;}")) |> singleton(),
    # preserve spacing of CLI errors that might make it to the GUI
    tags$style(HTML(
      ".cli-inline-error {
        display: inline;
        white-space: pre-wrap;
      }"
    )) |>
      singleton()
  )
}

# isoreader2 registers the data aggregators the file server relies on in its
# .onAttach hook, so it must be attached (not merely loaded via ::) before any
# aggregation happens. attachNamespace() runs that hook without the
# library()/require() call CRAN disallows in package code, and is a no-op once
# isoreader2 is already attached. Called by the app launchers and by
# ie_file_server(), so apps built from the modules (raw shinyApp, not just
# ie_run_app) work too.
ensure_isoreader2_attached <- function() {
  if (!"isoreader2" %in% .packages()) {
    attachNamespace("isoreader2")
  }
  invisible()
}

# logging =====

log_any <- function(
  msg,
  log_fun,
  ns = NULL,
  toaster = NULL,
  position = "bottom-left",
  ...
) {
  ns_prefix <- if (!is.null(ns)) paste0("[", ns(NULL), "] ") else ""
  if (!is.null(toaster)) {
    format_inline("{ns_prefix}{msg} [GUI msg: '{toaster}']") |> log_fun()
    bslib::toast(
      HTML(cli::ansi_html(toaster)),
      position = position,
      ...
    ) |>
      bslib::show_toast()
  } else {
    log_fun(paste0(ns_prefix, msg, collapse = ""))
  }
}

# calls log_warning and log_error for any encountered conditions
log_cnds <- function(
  cnds = tibble(),
  ns = NULL,
  user_msg = NULL,
  .call = caller_call()
) {
  if (!is.data.frame(cnds) && is.data.frame(cnds$conditions)) {
    cnds <- cnds$conditions
  }
  if (nrow(cnds) == 0) {
    return(invisible(NULL))
  }

  call <- as.character(.call[1]) |>
    stringr::str_remove(stringr::fixed("<reactive:")) |>
    stringr::str_remove(stringr::fixed(">"))
  if (is_empty(call)) {
    call <- "unknown"
  }

  warnings <- cnds |> filter(.data$type == "warning")
  if (nrow(warnings) > 0) {
    for (message in warnings$message) {
      log_warning(
        ns = ns,
        user_msg = if (!is.null(user_msg)) {
          user_msg
        } else {
          format_inline("Warning in {call}()")
        },
        warning = message
      )
    }
  }

  errors <- cnds |> filter(.data$type == "error")
  if (nrow(errors) > 0) {
    log_error(
      ns = ns,
      user_msg = if (!is.null(user_msg)) {
        user_msg
      } else {
        format_inline("{qty(nrow(errors))}Error{?s} in {call}()")
      },
      error = errors$condition |>
        purrr::map_chr(~ format(.x) |> paste(collapse = "\n"))
    )
  }
}

log_error <- function(..., ns = NULL, user_msg = NULL, error = NULL) {
  error_msg <-
    if (!is.null(error)) {
      gsub("\\n", "<br>", cli::ansi_html(error)) |> paste(collapse = "<br>")
    } else {
      ""
    }

  pkg <- utils::packageName()
  issue_title <- sprintf(
    "Version %s: %s",
    if (!is.null(pkg)) {
      as.character(utils::packageVersion(pkg))
    } else {
      "app"
    },
    user_msg
  )

  issue_body <- sprintf(
    "Please describe here what you were attempting to do in the app when this issue occurred.\n\n## Trace (do NOT delete)\n\n<pre>%s</pre>",
    error_msg
  )

  issue_url <- sprintf(
    "https://github.com/isoverse/isoexplorer/issues/new?title=%s&body=%s",
    utils::URLencode(issue_title, reserved = TRUE),
    utils::URLencode(HTML(issue_body), reserved = TRUE)
  )

  error_screen <- modalDialog(
    title = span(
      style = "color: red;",
      h2(user_msg, style = "color: red;"),
      h4(
        "Please try again. If the issue persists, please",
        tags$a("report this error", href = issue_url, target = "_blank")
      )
    ),
    if (nchar(error_msg) > 0) pre(HTML(error_msg))
  )

  log_any(
    msg = paste0(
      ...,
      if (!is.null(error)) paste0("Encountered error:\n", error, "\n"),
      collapse = ""
    ),
    ns = ns,
    log_fun = rlog::log_error,
    toaster = user_msg,
    header = "Encountered error",
    type = "danger",
    duration_s = 10
  )

  if (!is.null(error)) {
    showModal(error_screen)
  }
}

log_warning <- function(..., ns = NULL, user_msg = NULL, warning = NULL) {
  msg <- paste0(..., collapse = "")
  if (!nzchar(msg) && !is.null(user_msg)) {
    msg <- user_msg
  }
  log_any(
    msg = msg,
    ns = ns,
    log_fun = rlog::log_warn,
    toaster = if (!is.null(warning)) warning else user_msg,
    header = if (!is.null(warning)) HTML(cli::ansi_html(user_msg)) else NULL,
    type = "warning",
    duration_s = 5
  )
}

log_info <- function(..., ns = NULL, user_msg = NULL) {
  msg <- paste0(..., collapse = "")
  if (!nzchar(msg) && !is.null(user_msg)) {
    msg <- user_msg
  }
  log_any(
    msg = msg,
    ns = ns,
    log_fun = rlog::log_info,
    toaster = user_msg,
    type = "info",
    duration_s = 2
  )
}

log_success <- function(..., ns = NULL, user_msg = NULL) {
  msg <- paste0(..., collapse = "")
  if (!nzchar(msg) && !is.null(user_msg)) {
    msg <- user_msg
  }
  log_any(
    msg = msg,
    ns = ns,
    log_fun = rlog::log_info,
    toaster = user_msg,
    type = "success",
    duration_s = 2
  )
}

log_debug <- function(..., ns = NULL) {
  log_any(msg = paste0(..., collapse = ""), ns = ns, log_fun = rlog::log_debug)
}

# ui helpers =====

# convenience function for adding non-breaking spaces
spaces <- function(n = 1) {
  htmltools::HTML(rep("&nbsp;", n))
}

# wrap content in an inline div
inline <- function(...) {
  htmltools::div(style = "display: inline-block;", ...)
}

# add a bslib tooltip to a widget
add_tooltip <- function(widget, ...) {
  bslib::tooltip(widget, ...)
}