R/utils.R

In a11yShiny: Accessibility Enhancements to Popular R Shiny Functions

#' Safely add ARIA attributes
#'
#' @keywords internal
#' @param tag htmltools tag
#' @param label sets aria-label
#' @param labelledby sets id for aria-labelledby
#' @param describedby sets id for aria-describedby
#' @param role sets ARIA role
#' @param tabindex sets focus order
#' @param live sets live region politeness (aria-live)
#' @param atomic sets atomicity of updates (aria-atomic)
#' @param hidden sets aria-hidden ("true"/"false")
#' @param controls sets aria-controls
#' @param pressed sets aria-pressed
#' @param ... additional attributes
#' @return modified tag
#' @noRd

add_aria <- function(
  tag,
  label = NULL,
  labelledby = NULL,
  describedby = NULL,
  role = NULL,
  tabindex = NULL,
  live = NULL,
  atomic = NULL,
  hidden = NULL,
  controls = NULL,
  pressed = NULL,
  ...
) {
  # Validate if tag is a shiny/htmltools tag object
  if (!inherits(tag, "shiny.tag") && !inherits(tag, "shiny.tag.list") && !is.list(tag)) {
    stop("add_aria: Argument 'tag' is not an htmltools/shiny tag object", call. = FALSE)
  }

  # Compose attributes
  attrs <- list(...)
  if (!is.null(label)) attrs[["aria-label"]] <- label
  if (!is.null(labelledby)) attrs[["aria-labelledby"]] <- labelledby
  if (!is.null(describedby)) attrs[["aria-describedby"]] <- describedby
  if (!is.null(role)) attrs[["role"]] <- role
  if (!is.null(tabindex)) attrs[["tabindex"]] <- tabindex
  if (!is.null(live)) attrs[["aria-live"]] <- live
  if (!is.null(atomic)) attrs[["aria-atomic"]] <- atomic
  if (!is.null(hidden)) attrs[["aria-hidden"]] <- hidden
  if (!is.null(controls)) attrs[["aria-controls"]] <- controls
  if (!is.null(pressed)) attrs[["aria-pressed"]] <- pressed

  do.call(htmltools::tagAppendAttributes, c(list(tag), attrs))
}

#' Set ARIA attributes specifically on inner elements of the given tag (via CSS selector)
#'
#' Uses htmltools::tagQuery; for older htmltools versions, the tag is returned unchanged.
#'
#' @keywords internal
#' @param tag htmltools tag (container)
#' @param selector CSS selector that finds the inner target elements
#' @param label sets aria-label
#' @param labelledby sets id for aria-labelledby
#' @param describedby sets id for aria-describedby
#' @param role sets ARIA role
#' @param tabindex sets focus order
#' @param live sets live region politeness (aria-live)
#' @param atomic sets atomicity of updates (aria-atomic)
#' @param hidden sets aria-hidden ("true"/"false")
#' @param controls sets aria-controls
#' @param pressed sets aria-pressed
#' @param ... additional attributes
#' @param missing_ok If FALSE and the selector finds no elements, a warning is issued.
#' @return modified tag (original container), possibly unchanged if selector not found.
#' @noRd
add_aria_inside <- function(
  tag,
  selector,
  label = NULL,
  labelledby = NULL,
  describedby = NULL,
  role = NULL,
  tabindex = NULL,
  live = NULL,
  atomic = NULL,
  hidden = NULL,
  controls = NULL,
  pressed = NULL,
  ...,
  missing_ok = TRUE
) {
  # Validate if tag is a shiny/htmltools tag object
  if (!inherits(tag, "shiny.tag") && !inherits(tag, "shiny.tag.list") && !is.list(tag)) {
    stop("add_aria_inside: Argument 'tag' is not an htmltools/shiny tag object", call. = FALSE)
  }

  # htmltools::tagQuery only reliably available from >= 0.5.0
  if (utils::packageVersion("htmltools") < "0.5.0") {
    return(tag)
  }

  # Compose attributes
  attrs <- list(...)
  if (!is.null(label)) attrs[["aria-label"]] <- label
  if (!is.null(labelledby)) attrs[["aria-labelledby"]] <- labelledby
  if (!is.null(describedby)) attrs[["aria-describedby"]] <- describedby
  if (!is.null(role)) attrs[["role"]] <- role
  if (!is.null(tabindex)) attrs[["tabindex"]] <- tabindex
  if (!is.null(live)) attrs[["aria-live"]] <- live
  if (!is.null(atomic)) attrs[["aria-atomic"]] <- atomic
  if (!is.null(hidden)) attrs[["aria-hidden"]] <- hidden
  if (!is.null(controls)) attrs[["aria-controls"]] <- controls
  if (!is.null(pressed)) attrs[["aria-pressed"]] <- pressed

  # If no attributes were passed, return tag unchanged
  if (length(attrs) == 0) {
    return(tag)
  }

  q <- htmltools::tagQuery(tag)
  found <- q$find(selector)

  # Check if matches exist
  # found$selected is internal; if not present, we try addAttrs - if it fails, nothing happens.
  # Note: tagQuery API does not offer a direct length method, so heuristic:
  # We try to apply addAttrs; if nothing is found, nothing changes.
  res <- try(
    {
      do.call(found$addAttrs, attrs)
    },
    silent = TRUE
  )

  if (inherits(res, "try-error")) {
    if (!isTRUE(missing_ok)) {
      warning(sprintf("add_aria_inside: No elements found for selector '%s' or attribute assignment failed", selector), call. = FALSE)
    }
    return(tag)
  }

  # allTags() returns the updated container
  res$allTags()
}

#' Collect all htmltools tags by name and/or class in a tag tree (recursive)
#'
#' Recursively searches for all tags with the given `name` (e.g. "div", "main") and optionally a CSS class (e.g. "a11y-col").
#'
#' @keywords internal
#' @param tag htmltools tag, tagList, or list
#' @param name Character name of the tag to search for (e.g., "div")
#' @param class (optional) Only match tags with this class. Default: NULL (match all)
#' @return List of matching tag objects
#' @noRd
find_html_tags <- function(tag,
                           name,
                           class = NULL) {
  results <- list()
  scan_single <- function(x) {
    if (is.null(x)) {
      return()
    }
    if (inherits(x, "shiny.tag")) {
      match_name <- identical(x$name, name)
      match_class <- is.null(class) || (!is.null(x$attribs$class) && grepl(class, x$attribs$class))
      if (match_name && match_class) {
        results <<- c(results, list(x))
      }
      # Recursively scan children if any
      children <- x$children
      if (!is.null(children)) scan_single(children)
    } else if (inherits(x, "shiny.tag.list") || is.list(x)) {
      lapply(x, scan_single)
    }
  }
  scan_single(tag)
  results
}

#' Find all direct children with a specific class in a list of shiny tags
#'
#' @param elements List of potentially mixed shiny.tag/shiny.tag.list elements
#' @param class Character string specifying the CSS class to match
#' @return List of direct a11y_column shiny.tag objects
#' @noRd
find_direct_children_class <- function(elements, class) {
  Filter(function(x) {
    inherits(x, "shiny.tag") &&
      identical(x$name, "div") &&
      grepl(class, paste(x$attribs$class, collapse = " "))
  }, elements)
}

#' Find all direct children that do NOT have a specific class in a list of shiny tags
#'
#' @param elements List of potentially mixed shiny.tag/shiny.tag.list elements
#' @param class Character string specifying the CSS class to match
#' @return List of direct a11y_column shiny.tag objects
#' @noRd
find_direct_children_without_class <- function(elements, class) {
  Filter(function(x) {
    inherits(x, "shiny.tag") &&
      identical(x$name, "div") &&
      !grepl(class, paste(x$attribs$class, collapse = " "))
  }, elements)
}

#' Check if input is a non-blank string
#'
#' Returns `TRUE` only for character scalars that are not `NA` and not empty
#' after trimming whitespace.
#'
#' @keywords internal
#' @param x Object to validate.
#' @return Logical scalar.
#' @noRd
is_nonblank_string <- function(x) {
  is.character(x) &&
    length(x) == 1L &&
    !is.na(x) &&
    nzchar(trimws(x))
}