R/layout.R
In a11yShiny: Accessibility Enhancements to Popular R Shiny Functions

Documented in a11y_column a11y_fluidPage a11y_fluidRow

#' Accessible fluid page
#'
#' A wrapper for [shiny::fluidPage()] with required `title`/`lang`, one main
#' landmark, optional header/nav/aside/footer, skip link, and flexible layout
#' CSS.
#'
#' - Enforces `title` and `lang`
#' - Ensures exactly one `<main id="main-content">`
#' - Attaches the CSS dependency (`use_a11y`) for flexible layout (`.a11y-flow`)
#' - Allows optional header/nav/aside/footer blocks
#'
#' @param ... Content to go inside `<main>` when `main` is `NULL`, or extra
#'   children to append to `main`
#' @param title Page title (required)
#' @param lang Language code (required)
#' @param main (optional) `<main>` tag (`tags$main(...)`); if provided, it is
#'   normalized (id/class ensured)
#' @param main_id (optional) ID to assign if the main has no id yet
#'   (default `"main-content"`)
#' @param header (optional) Header content or `tags$header(...)`
#' @param nav (optional) Nav content or `tags$nav(...)`
#' @param aside (optional) Aside content or `tags$aside(...)`
#' @param footer (optional) Footer content or `tags$footer(...)`
#' @return A Shiny UI tag (page)
#'
#' @examples
#' # Minimal accessible page
#' a11y_fluidPage(
#'   title = "My App",
#'   lang  = "en",
#'   htmltools::h1("Welcome")
#' )
#'
#' # Page with header and footer
#' a11y_fluidPage(
#'   title  = "Dashboard",
#'   lang   = "de",
#'   header = htmltools::tags$header(htmltools::h1("Dashboard")),
#'   footer = htmltools::tags$footer("Footer content"),
#'   htmltools::p("Main content goes here")
#' )
#'
#' @export
a11y_fluidPage <- function(...,
                           title,
                           lang = NULL,
                           main = NULL,
                           main_id = "main-content",
                           header = NULL,
                           nav = NULL,
                           aside = NULL,
                           footer = NULL) {
  # Validate required parameters
  if (missing(title) || !is_nonblank_string(title)) {
    stop("a11y_fluidPage: `title` is required", call. = FALSE)
  }
  if (missing(lang) || !is_nonblank_string(lang)) {
    stop("a11y_fluidPage: `lang` is required and must be a non-empty string (e.g., 'de', 'en-US')", call. = FALSE)
  }

  # Normalize helper for landmarks (wrap into the expected tag if needed)
  normalize_landmark <- function(tag, expected_name, css_class) {
    if (is.null(tag)) {
      return(NULL)
    }
    if (inherits(tag, "shiny.tag") && identical(tag$name, expected_name)) {
      return(htmltools::tagAppendAttributes(tag, class = css_class))
    }
    # Wrap arbitrary content into the expected semantic element
    wrapper <- htmltools::tags[[expected_name]]
    htmltools::tagAppendAttributes(wrapper(tag), class = css_class)
  }

  # Build or normalize <main>
  dots <- list(...)
  if (is.null(main)) {
    main_tag <- htmltools::tags$main(id = main_id, class = "a11y-main", !!!dots)
  } else {
    if (!inherits(main, "shiny.tag") || !identical(main$name, "main")) {
      main_tag <- htmltools::tags$main(id = main_id, class = "a11y-main", main, !!!dots)
    } else {
      # Ensure class
      main_tag <- htmltools::tagAppendAttributes(main, class = "a11y-main")
      # Ensure id
      if (!is_nonblank_string(main_tag$attribs$id)) {
        main_tag <- htmltools::tagAppendAttributes(main_tag, id = main_id)
      }
      # Append any extra children from ...
      if (length(dots)) {
        main_tag <- do.call(htmltools::tagAppendChildren, c(list(main_tag), dots))
      }
    }
  }

  # Normalize optional landmarks
  header_tag <- normalize_landmark(header, "header", "a11y-header")
  nav_tag <- normalize_landmark(nav, "nav", "a11y-nav")
  aside_tag <- normalize_landmark(aside, "aside", "a11y-aside")
  footer_tag <- normalize_landmark(footer, "footer", "a11y-footer")

  # Content wrapper (CSS can make this flexible)
  flow <- htmltools::div(class = "a11y-flow", header_tag, nav_tag, main_tag, aside_tag, footer_tag)

  # Prefer bslib::page_fluid(lang=...) so <html lang="..."> is in static HTML
  use_bslib <- requireNamespace("bslib", quietly = TRUE) &&
    utils::packageVersion("bslib") >= "0.5.0"

  page <- if (use_bslib) {
    bslib::page_fluid(flow, title = title, lang = lang)
  } else {
    shiny::fluidPage(flow, title = title)
  }

  # Fallback: set <html lang="..."> at runtime if not set statically
  if (!use_bslib) {
    lang_script <- htmltools::tags$script(
      htmltools::HTML(sprintf(
        "document.documentElement.setAttribute('lang','%s');", lang
      ))
    )
    page <- htmltools::tagList(htmltools::tags$head(lang_script), page)
  }

  # Attach CSS/JS dependency
  htmltools::attachDependencies(page, list(use_a11y()))
}

#' Accessible fluid row
#'
#' A wrapper for [shiny::fluidRow()] with optional section landmarks, ARIA
#' attributes according to BITV 2.0, and custom CSS class. Ensures responsive
#' layout by validating that all columns are `a11y_column`s and their widths
#' sum to 12.
#'
#' @param ... Content to place into the row (columns, tags)
#' @param id (optional) Row ID
#' @param aria_label (optional) `aria-label` for the row (helpful for sections)
#' @return HTML `<section>` tag (row)
#'
#' @examples
#' # A row with two columns (widths must sum to 12)
#' a11y_fluidRow(
#'   a11y_column(6, htmltools::p("Left")),
#'   a11y_column(6, htmltools::p("Right"))
#' )
#'
#' # Labeled section row
#' a11y_fluidRow(
#'   a11y_column(12, htmltools::p("Full width")),
#'   aria_label = "Results section"
#' )
#'
#' @export
a11y_fluidRow <- function(...,
                          id = NULL,
                          aria_label = NULL) {
  elements <- list(...)

  # Compose a11y_class for CSS
  row_class <- paste("a11y-row")
  attrs <- list(class = row_class)
  if (!is.null(id)) attrs$id <- id
  if (!is.null(aria_label)) attrs[["aria-label"]] <- aria_label

  # Warning if nested a11y_fluidRow detected
  nested <- find_html_tags(elements, name = "section", class = "a11y-row")
  if (length(nested) > 0) {
    warning("a11y_fluidRow: Nested a11y_fluidRow detected; this is allowed, but it can create serious navigational problems for keyboard users", call. = FALSE)
  }

  # Validate if all children are a11y_column and if sum(width) == 12
  if (length(elements) > 0) {
    # Search all direct a11y_column divs
    a11y_columns <- find_direct_children_class(elements, "a11y-col")
    not_a11y <- find_direct_children_without_class(elements, "a11y-col")
    if (length(not_a11y) > 0) {
      stop("a11y_fluidRow: At least one column is not implemented with a11y_column (lacks 'a11y-col'); only a11y_columns are accepted", call. = FALSE)
    }
    # Extract the widths (data-width attribute)
    col_widths <- vapply(
      a11y_columns,
      function(x) {
        w <- x$attribs[["data-width"]]
        if (!is.null(w)) as.numeric(w) else NA_real_
      },
      numeric(1)
    )
    col_offsets <- vapply(
      a11y_columns,
      function(x) {
        w <- x$attribs[["data-offset"]]
        if (!is.null(w)) {
          # offsets are optional, default to 0 if missing
          v <- as.numeric(w)
          if (is.na(v) || v < 1 || v > 12) stop("a11y_fluidRow: Each offset must be 1-12 (if set)", call. = FALSE)
          v
        } else {
          0
        }
      },
      numeric(1)
    )
    total <- sum(col_widths, col_offsets, na.rm = TRUE)
    if (length(a11y_columns) == 0) {
      warning("a11y_fluidRow: No direct a11y_column divs found", call. = FALSE)
    } else if (any(is.na(col_widths))) {
      stop("a11y_fluidRow: At least one column is not implemented with a11y_column which ensures accessibility", call. = FALSE)
    } else if (total != 12) {
      stop(sprintf("a11y_fluidRow: The sum of all a11y_column widths and offsets in a11y_fluidRow is %d (expected: 12)", total), call. = FALSE)
    }
  }

  # Use <section> for landmarking
  htmltools::tags$section(!!!attrs, ...)
}

#' Accessible column
#'
#' A wrapper for [shiny::column()] with optional ARIA attributes according to
#' BITV 2.0 and custom CSS class. Ensures responsive layout by validating that
#' columns have appropriate widths.
#'
#' @param width Column width (as in [shiny::column()]: 1--12)
#' @param offset (optional) Column offset (as in [shiny::column()], 1--12)
#' @param ... Content for column
#' @param id (optional) Column ID
#' @param aria_label (optional) `aria-label` for the column/region
#' @return HTML `<div>` tag with classes for grid and a11y
#'
#' @examples
#' # Simple column
#' a11y_column(6, htmltools::p("Half width content"))
#'
#' # Column with offset and aria-label
#' a11y_column(4,
#'   offset = 2,
#'   aria_label = "Sidebar",
#'   htmltools::p("Offset column")
#' )
#'
#' # Column with a descriptive aria-label for a form section
#' a11y_column(4,
#'   aria_label = "Histogram settings",
#'   htmltools::p("Configuration controls go here")
#' )
#'
#' @export
a11y_column <- function(width,
                        ...,
                        offset = NULL,
                        id = NULL,
                        aria_label = NULL) {
  if (!is.numeric(width) || width < 1 || width > 12) {
    stop(sprintf("a11y_column: 'width' must be an integer between 1 and 12. Provided: %s", as.character(width)), call. = FALSE)
  }
  if (!is.null(offset)) {
    if (!is.numeric(offset) || offset < 1 || offset > 12) {
      stop(sprintf("a11y_column: 'offset' must be an integer between 1 and 12 if provided. Provided: %s", as.character(offset)), call. = FALSE)
    }
  }
  css_class <- paste0("a11y-col col-", width)
  # Data attribute for validation of column widths in a11y_fluidRow
  attrs <- list(class = css_class, `data-width` = width)
  if (!is.null(offset)) attrs[["data-offset"]] <- offset
  if (!is.null(id)) attrs$id <- id
  if (!is.null(aria_label)) attrs[["aria-label"]] <- aria_label

  # Use div for aria-label and role
  htmltools::div(!!!attrs, ...)
}