tests/testthat/test-a11y_selectInput.R

In a11yShiny: Accessibility Enhancements to Popular R Shiny Functions

# ===========================================================================
# Tests for a11y_selectInput
# ===========================================================================

# --- CSS class --------------------------------------------------------------

test_that("a11y_selectInput has a11y-select class", {
  si <- a11y_selectInput("sel1", "Colour", choices = c("Red", "Blue"))
  html <- as.character(si)
  expect_true(grepl("a11y-select", html))
})

# --- Label validation -------------------------------------------------------

test_that("a11y_selectInput errors when label is missing", {
  expect_error(
    a11y_selectInput("sel2", choices = c("A", "B")),
    "label.*required"
  )
})

test_that("a11y_selectInput errors when label is NULL", {
  expect_error(
    a11y_selectInput("sel3", label = NULL, choices = c("A", "B")),
    "label.*required"
  )
})

test_that("a11y_selectInput errors when label is empty string", {
  expect_error(
    a11y_selectInput("sel4", label = "", choices = c("A", "B")),
    "label.*required"
  )
})

test_that("a11y_selectInput errors when label is whitespace only", {
  expect_error(
    a11y_selectInput("sel5", label = "   ", choices = c("A", "B")),
    "label.*required"
  )
})

test_that("a11y_selectInput error message includes inputId", {
  expect_error(
    a11y_selectInput("mySelectId", label = "", choices = c("A")),
    "mySelectId"
  )
})

# --- describedby_text -------------------------------------------------------

test_that("a11y_selectInput creates sr-only div with describedby_text", {
  si <- a11y_selectInput("sel6", "Size", choices = c("S", "M"),
                         describedby_text = "Choose a size")
  html <- as.character(si)
  expect_true(grepl("a11y-sr-only", html))
  expect_true(grepl("Choose a size", html))
  expect_true(grepl("sel6-desc", html))
})

test_that("a11y_selectInput uses describedby ID when both describedby and describedby_text are set", {
  si <- a11y_selectInput("sel7", "Size", choices = c("S", "M"),
                         describedby = "custom-desc",
                         describedby_text = "Choose a size")
  html <- as.character(si)
  expect_true(grepl("custom-desc", html))
})

test_that("a11y_selectInput uses describedby without describedby_text", {
  si <- a11y_selectInput("sel8", "Size", choices = c("S", "M"),
                         describedby = "ext-desc")
  html <- as.character(si)
  expect_true(grepl('aria-describedby=["\']ext-desc["\']', html))
})

# --- heading_level ----------------------------------------------------------

test_that("a11y_selectInput errors on invalid heading_level", {
  expect_error(
    a11y_selectInput("sel9", "Label", choices = c("A"), heading_level = 7),
    "heading_level"
  )
})

test_that("a11y_selectInput errors on non-numeric heading_level", {
  expect_error(
    a11y_selectInput("sel10", "Label", choices = c("A"), heading_level = "three"),
    "heading_level"
  )
})

test_that("a11y_selectInput valid heading_level does not error", {
  expect_no_error(
    a11y_selectInput("sel11", "Label", choices = c("A"), heading_level = 3)
  )
})

# --- aria_controls ----------------------------------------------------------

test_that("a11y_selectInput sets aria-controls when provided", {
  si <- a11y_selectInput("sel12", "Pick", choices = c("X"),
                         aria_controls = "target-panel")
  html <- as.character(si)
  expect_true(grepl('aria-controls=["\']target-panel["\']', html))
})

# --- Dependency attachment --------------------------------------------------

test_that("a11y_selectInput attaches a11yShiny dependency", {
  si <- a11y_selectInput("sel13", "Pick", choices = c("X"))
  deps <- htmltools::htmlDependencies(si)
  dep_names <- vapply(deps, function(d) d$name, character(1))
  expect_true("a11yShiny" %in% dep_names)
})

# --- selectize vs native select ---------------------------------------------

test_that("a11y_selectInput works with selectize = FALSE", {
  si <- a11y_selectInput("sel14", "Pick", choices = c("A", "B"),
                         selectize = FALSE)
  html <- as.character(si)
  expect_true(grepl("a11y-select", html))
})

# --- Multiple selection -----------------------------------------------------

test_that("a11y_selectInput supports multiple = TRUE", {
  si <- a11y_selectInput("sel15", "Pick", choices = c("A", "B", "C"),
                         multiple = TRUE)
  html <- as.character(si)
  expect_true(grepl("a11y-select", html))
})