R/composites.R

In a11yShiny: Accessibility Enhancements to Popular R Shiny Functions

# Internal counter for generating unique IDs when groupId is not provided
.a11y_id_counter <- new.env(parent = emptyenv())
.a11y_id_counter$n <- 0L

.next_a11y_id <- function(prefix) {
    .a11y_id_counter$n <- .a11y_id_counter$n + 1L
    paste0(prefix, .a11y_id_counter$n)
}

#' Accessible text input with action button
#'
#' A composite component combining [a11y_textInput()] and
#' [a11y_actionButton()] with BITV 2.0-conform ARIA attributes. The text input
#' enforces a visible label; the button enforces either a visible label or an
#' `aria-label`. By default the button gets `aria-controls` pointing to the
#' text input.
#'
#' @param textId ID for the inner text input (required)
#' @param buttonId ID for the inner action button (required)
#' @param label Visible label for the text input (required)
#' @param value Initial value for the text input (default: `""`)
#' @param placeholder Placeholder for the text input (optional)
#' @param button_label Visible label for the button (optional; if omitted/empty,
#'   `button_aria_label` is required)
#' @param button_icon Icon for the button (e.g. `shiny::icon("search")`,
#'   optional)
#' @param button_aria_label ARIA label for the button (required if
#'   `button_label` is missing or empty)
#' @param controls ID referenced by `aria-controls` on the button. If `NULL`,
#'   defaults to `textId`.
#' @param layout `"inline"` (default) or `"stack"`. Inline places text and
#'   button in one row; stack places them under each other.
#' @param text_describedby ID for `aria-describedby` of the text input
#'   (optional)
#' @param text_describedby_text Creates an sr-only `<div>` as description for
#'   the text input. If `text_describedby` is set, that ID is used, otherwise
#'   `<textId>-desc` (optional)
#' @param text_heading_level 1--6, marks the visible `<label>` of the text
#'   input as heading via `role="heading"` and `aria-level` (optional)
#' @return HTML tag containing the labeled text input and button
#'
#' @examples
#' # Search box with icon-only button
#' a11y_textButtonGroup(
#'     textId = "search_text",
#'     buttonId = "search_btn",
#'     label = "Search",
#'     placeholder = "Enter a keyword",
#'     button_icon = shiny::icon("search"),
#'     button_aria_label = "Run search"
#' )
#'
#' # Stacked layout with visible button label
#' a11y_textButtonGroup(
#'     textId = "comment_text",
#'     buttonId = "comment_btn",
#'     label = "Comment",
#'     button_label = "Send",
#'     layout = "stack"
#' )
#'
#' # With screen-reader description and heading-level on the label
#' a11y_textButtonGroup(
#'     textId = "query_text",
#'     buttonId = "query_btn",
#'     label = "Search query",
#'     placeholder = "Enter a keyword",
#'     button_icon = shiny::icon("search"),
#'     button_aria_label = "Run search",
#'     text_describedby_text = "Type a keyword and press the search button",
#'     text_heading_level = 3
#' )
#'
#' @export
a11y_textButtonGroup <- function(textId,
                                 buttonId,
                                 label,
                                 value = "",
                                 placeholder = NULL,
                                 button_label = NULL,
                                 button_icon = NULL,
                                 button_aria_label = NULL,
                                 controls = NULL,
                                 layout = c("inline", "stack"),
                                 text_describedby = NULL,
                                 text_describedby_text = NULL,
                                 text_heading_level = NULL) {
    layout <- match.arg(layout)

    # --- Build the text input using the accessible wrapper --------------------

    text_input <- a11y_textInput(
        inputId = textId,
        label = label,
        value = value,
        placeholder = placeholder,
        describedby = text_describedby,
        describedby_text = text_describedby_text,
        heading_level = text_heading_level
    )

    # --- Build the action button using the accessible wrapper -----------------
    # Link the button to the text input via aria-controls (defaults to textId)
    controls_id <- if (is_nonblank_string(controls)) controls else textId

    # Note: a11y_actionButton will error if neither label nor aria_label is set
    button <- a11y_actionButton(
        inputId = buttonId,
        label = button_label,
        icon = button_icon,
        aria_label = button_aria_label,
        aria_controls = controls_id
    )

    # --- Wrap both elements in a layout container -----------------------------

    container_class <- paste(
        "a11y-text-btn-group",
        if (layout == "inline") "a11y-text-btn-inline" else "a11y-text-btn-stack"
    )

    out <- htmltools::div(
        class = container_class,
        text_input,
        button
    )

    # Ensure the a11y stylesheet/JS is loaded (safe to attach even if children already have it)
    htmltools::attachDependencies(out, list(use_a11y()))
}

#' Accessible group of text inputs
#'
#' A wrapper for a group of related text input elements inside a
#' `<fieldset>`/`<legend>` with ARIA attributes according to BITV 2.0. Intended
#' for combined form elements that belong together (e.g. address fields, date
#' parts, etc.).
#'
#' * The group gets a visible legend (required).
#' * Each inner text input has its own ID.
#' * For each inner input you must provide at least **one** of: a visible
#'   `label`, an `aria_label`, or a `title` attribute.
#' * The fieldset is marked as `role="group"` and is linked to the legend via
#'   `aria-labelledby`.
#'
#' @param groupId ID for the fieldset/group (used as id of `<fieldset>`)
#' @param legend Visible group label (used as `<legend>`, required)
#' @param inputs A list of input specifications. Each element must be a list
#'   with:
#'   \describe{
#'     \item{inputId}{ID of the text input (required)}
#'     \item{label}{Visible label for this text field (optional)}
#'     \item{value}{Initial value (optional, default: `""`)}
#'     \item{placeholder}{Placeholder text (optional)}
#'     \item{width}{Width for this field (optional, as in [shiny::textInput()])}
#'     \item{aria_label}{Accessible name via `aria-label` (optional -- required
#'       if no visible label and no title)}
#'     \item{title}{Title attribute for additional explanation or as accessible
#'       name if no visible label (optional)}
#'   }
#' @param describedby ID of an element used for `aria-describedby` on the group
#'   (optional)
#' @param describedby_text Creates an sr-only `<div>` that serves as a
#'   description for the group and is linked via `aria-describedby`. If
#'   `describedby` is set, its ID is used, otherwise an ID is generated
#'   (`<groupId>-desc`). (optional)
#' @param legend_heading_level 1--6, marks the visible `<legend>` as a heading
#'   via `role="heading"` and `aria-level` (optional)
#'
#' @return HTML tag of the fieldset containing multiple text inputs (possibly
#'   with an sr-only group description)
#'
#' @examples
#' # Address field group
#' a11y_textInputsGroup(
#'     groupId = "address",
#'     legend = "Address",
#'     inputs = list(
#'         list(inputId = "street", label = "Street"),
#'         list(inputId = "city", label = "City"),
#'         list(inputId = "zip", label = "ZIP code")
#'     )
#' )
#'
#' # With group description and legend promoted to heading level
#' a11y_textInputsGroup(
#'     groupId = "address_full",
#'     legend = "Postal address",
#'     inputs = list(
#'         list(inputId = "street2", label = "Street and number"),
#'         list(inputId = "zip2", label = "ZIP code", width = "120px"),
#'         list(inputId = "city2", label = "City"),
#'         list(inputId = "country2", label = "Country")
#'     ),
#'     describedby_text = "Please enter your full postal address.",
#'     legend_heading_level = 3
#' )
#'
#' @export
a11y_textInputsGroup <- function(groupId,
                                 legend,
                                 inputs,
                                 describedby = NULL,
                                 describedby_text = NULL,
                                 legend_heading_level = NULL) {
    # --- Validate required arguments ------------------------------------------
    legend_visible <- !missing(legend) && is_nonblank_string(legend)
    if (!legend_visible) {
        id_msg <- if (!is.null(groupId)) paste0(" (groupId: ", groupId, ")") else ""
        stop(paste0("a11y_textInputsGroup: A visible `legend` is required", id_msg),
            call. = FALSE
        )
    }

    if (missing(inputs) || !is.list(inputs) || length(inputs) == 0) {
        id_msg <- if (!is.null(groupId)) paste0(" (groupId: ", groupId, ")") else ""
        stop(paste0("a11y_textInputsGroup: `inputs` must be a non-empty list", id_msg),
            call. = FALSE
        )
    }

    # Extract a named value from a spec list, returning `default` if missing
    get_spec <- function(x, name, default = NULL) {
        if (!is.null(x[[name]])) x[[name]] else default
    }

    # --- Build a Shiny text input for each spec in `inputs` ------------------
    input_tags <- lapply(inputs, function(spec) {
        if (!is.list(spec)) {
            stop("a11y_textInputsGroup: Each element of `inputs` must be a list",
                call. = FALSE
            )
        }

        inputId <- get_spec(spec, "inputId", get_spec(spec, "id", NULL))
        if (!is_nonblank_string(inputId)) {
            stop("a11y_textInputsGroup: Each input spec must contain a non-empty `inputId`",
                call. = FALSE
            )
        }

        label <- get_spec(spec, "label", NULL)
        value <- get_spec(spec, "value", "")
        placeholder <- get_spec(spec, "placeholder", NULL)
        width <- get_spec(spec, "width", NULL)
        aria_label <- get_spec(spec, "aria_label", NULL)
        title_attr <- get_spec(spec, "title", NULL)

        label_visible <- is_nonblank_string(label)

        # BITV 2.0 requires every input to have an accessible name —
        # either a visible label, an aria-label, or a title attribute
        if (!label_visible &&
            !is_nonblank_string(aria_label) &&
            !is_nonblank_string(title_attr)) {
            stop(
                paste0(
                    "a11y_textInputsGroup: Input \"", inputId,
                    "\" must have either a visible `label`, `aria_label` or `title`"
                ),
                call. = FALSE
            )
        }

        # Pass label to Shiny only when it should be rendered visibly;
        # hidden inputs get their accessible name via aria-label / title instead
        label_for_shiny <- if (label_visible) label else NULL

        ti <- shiny::textInput(
            inputId     = inputId,
            label       = label_for_shiny,
            value       = value,
            width       = width,
            placeholder = placeholder
        )

        # Add a11y classes for consistent focus ring and group-item layout
        ti <- htmltools::tagAppendAttributes(
            ti,
            class = "a11y-text a11y-text-group-item"
        )

        # Apply ARIA attributes directly on the <input> element (not the wrapper)
        input_sel <- paste0("#", inputId)

        # When there is no visible label, provide an accessible name via aria-label or title
        if (!label_visible && is_nonblank_string(aria_label)) {
            # add_aria_inside(..., label = ...) -> aria-label
            ti <- add_aria_inside(ti, input_sel, label = aria_label)
        }

        if (is_nonblank_string(title_attr)) {
            ti <- add_aria_inside(ti, input_sel, title = title_attr)
        }

        ti
    })

    # --- Build the <fieldset> with <legend> and ARIA group role ---------------
    legend_id <- if (is_nonblank_string(groupId)) {
        paste0(groupId, "-legend")
    } else {
        .next_a11y_id("a11y-text-group-legend-")
    }

    legend_tag <- htmltools::tags$legend(
        id = legend_id,
        legend
    )

    # Optionally promote the legend to a heading so it appears in the
    # document outline (useful when the group starts a new form section)
    if (!is.null(legend_heading_level)) {
        if (!is.numeric(legend_heading_level) ||
            !(legend_heading_level %in% 1:6)) {
            stop("a11y_textInputsGroup: legend_heading_level must be a number 1-6",
                call. = FALSE
            )
        }
        legend_tag <- add_aria(
            legend_tag,
            role = "heading",
            "aria-level" = as.integer(legend_heading_level)
        )
    }

    # Create a visually hidden description for the group that screen readers
    # will announce via aria-describedby on the fieldset
    sr_desc_div <- NULL
    desc_id <- NULL
    if (is_nonblank_string(describedby_text)) {
        desc_id <- if (is_nonblank_string(describedby)) {
            describedby
        } else if (is_nonblank_string(groupId)) {
            paste0(groupId, "-desc")
        } else {
            .next_a11y_id("a11y-text-group-desc-")
        }

        sr_desc_div <- htmltools::tags$div(
            id    = desc_id,
            class = "a11y-sr-only",
            describedby_text
        )
    } else if (is_nonblank_string(describedby)) {
        desc_id <- describedby
    }

    # Assemble the fieldset: role="group" lets assistive tech treat the
    # inputs as a related set, aria-labelledby links to the legend text
    fieldset_tag <- htmltools::tags$fieldset(
        id    = groupId,
        class = "a11y-text-group",
        legend_tag,
        input_tags
    )

    fieldset_tag <- add_aria(
        fieldset_tag,
        role = "group",
        labelledby = legend_id
    )

    if (is_nonblank_string(desc_id)) {
        fieldset_tag <- add_aria(fieldset_tag, describedby = desc_id)
    }

    out <- if (!is.null(sr_desc_div)) {
        htmltools::tagList(fieldset_tag, sr_desc_div)
    } else {
        fieldset_tag
    }

    # Ensure the a11y stylesheet/JS is loaded
    htmltools::attachDependencies(out, list(use_a11y()))
}