Add banner and main landmarks to page_navbar()

DESCRIPTION

@@ -69,7 +69,7 @@ Config/Needs/routine: chromote, desc, renv
 Config/Needs/website: brio, crosstalk, dplyr, DT, ggplot2, glue,
     htmlwidgets, leaflet, lorem, palmerpenguins, plotly, purrr, rprojroot,
     rstudio/htmltools, scales, stringr, tidyr, webshot2
-Config/roxygen2/version: 8.1.0
+Config/roxygen2/version: 8.1.1
 Config/testthat/edition: 3
 Config/testthat/parallel: true
 Config/testthat/start-first: zzzz-bs-sass, fonts, zzz-precompile, theme-*,

NEWS.md

@@ -31,6 +31,8 @@
 
 * Added an aria-controls attribute when using bslib::page_navbar() with bslib::nav_panel() to establish an explicit relationship between the tab and the controlled tab panel. (@shelbylevel, #1354)
 
+* `page_navbar()` now includes banner and main landmarks, making it easier for screen reader users to navigate the page. (@jcheng5, @shelbylevel, #1357)
+
 # bslib 0.12.0
 
 ## New features

R/navs-legacy.R

@@ -224,7 +224,8 @@ navs_bar_ <- function(
   header = NULL,
   footer = NULL,
   fluid = TRUE,
-  theme = NULL
+  theme = NULL,
+  page_landmarks = FALSE
 ) {
   navbar_options <- navbar_options %||% navbar_options()
 
@@ -258,7 +259,8 @@ navs_bar_ <- function(
     inverse = identical(navbar_theme, "dark"),
     underline = navbar_options[["underline"]],
     fluid = fluid,
-    theme = theme
+    theme = theme,
+    page_landmarks = page_landmarks
   )
 
   attribs <- navbar_options[["attribs"]] %||% list()
@@ -267,7 +269,7 @@ navs_bar_ <- function(
   # user includes both, the attribute wins for being most technically-correct.
   attribs[["data-bs-theme"]] <- attribs[["data-bs-theme"]] %||% navbar_theme
 
-  # navbarPage_() returns a tagList() of the nav and content
+  # navbarPage_() returns a tagList() of the navbar and content
   navbar[[1]] <- tagAppendAttributes(
     navbar[[1]],
     style = if (!is.null(navbar_bg)) {
@@ -300,7 +302,8 @@ navbarPage_ <- function(
   underline = TRUE,
   collapsible = FALSE,
   fluid = TRUE,
-  theme = NULL
+  theme = NULL,
+  page_landmarks = FALSE
 ) {
   # alias title so we can avoid conflicts w/ title in withTags
   pageTitle <- title
@@ -401,7 +404,11 @@ navbarPage_ <- function(
   contents <- dropNulls(list(header, tabset$content, footer))
 
   if (is.null(sidebar)) {
-    contentDiv <- div(class = containerClass, !!!contents)
+    contentDiv <- div(
+      class = containerClass,
+      role = if (page_landmarks) "main",
+      !!!contents
+    )
 
     # If fillable is truthy, the .container also needs to be fillable
     if (!isFALSE(fillable)) {
@@ -426,11 +433,17 @@ navbarPage_ <- function(
     contentDiv <- bindFillRole(contentDiv, container = TRUE, item = TRUE)
   }
 
+  # Keep the navbar and content as siblings for CSS and sticky positioning.
+  # Embedded navsets retain navigation semantics without page-level landmarks.
+  if (page_landmarks) {
+    containerDiv$name <- "nav"
+    navbar <- tags$header(class = navbarClass, containerDiv)
+  } else {
+    navbar <- tags$nav(class = navbarClass, role = "navigation", containerDiv)
+  }
+
   # *Don't* wrap in bootstrapPage() (shiny::navbarPage()) does that part
-  tagList(
-    tags$nav(class = navbarClass, role = "navigation", containerDiv),
-    contentDiv
-  )
+  tagList(navbar, contentDiv)
 }
 
 navbarMenu_ <- function(title, ..., menuName = title, icon = NULL, align) {

R/page.R

@@ -442,7 +442,7 @@ page_navbar <- function(
   }
 
   # If a sidebar is provided, we want the layout_sidebar(fill = TRUE) component
-  # (which is a sibling of the <nav>) to always fill the page
+  # (which is a sibling of the navbar) to always fill the page
   page_func <- if (isFALSE(fillable) && is.null(sidebar)) {
     page
   } else {
@@ -469,7 +469,8 @@ page_navbar <- function(
     footer = footer,
     navbar_options = .navbar_options,
     fluid = fluid,
-    theme = theme
+    theme = theme,
+    page_landmarks = TRUE
   )
 
   page_func(

tests/testthat/test-page.R

@@ -33,6 +33,158 @@ test_that("page_navbar()", {
   )
 })
 
+describe("Navbar page landmarks", {
+  skip_if_not_installed("shiny")
+
+  cases <- expand.grid(
+    page_type = c("page_navbar", "navbarPage"),
+    fluid = c(TRUE, FALSE),
+    fillable = c(TRUE, FALSE),
+    stringsAsFactors = FALSE
+  )
+
+  for (i in seq_len(nrow(cases))) {
+    case <- cases[i, ]
+    case_name <- sprintf(
+      "%s(fluid = %s, fillable = %s)",
+      case$page_type,
+      case$fluid,
+      case$fillable
+    )
+
+    it(paste(case_name, "gives the content div a main landmark without a sidebar"), {
+      page_fn <- switch(
+        case$page_type,
+        page_navbar = page_navbar,
+        navbarPage = shiny::navbarPage
+      )
+      ui <- page_fn(
+        title = "foo",
+        nav_panel("One", "content"),
+        theme = bs_theme(),
+        fluid = case$fluid,
+        fillable = case$fillable,
+        navbar_options = navbar_options(class = "sticky-top")
+      )
+      query <- tagQuery(ui)
+      container_class <- if (case$fluid) ".container-fluid" else ".container"
+
+      expect_equal(query$find("header.navbar")$length(), 1)
+      expect_equal(query$find("header.navbar.sticky-top")$length(), 1)
+      navbar <- query$find("header.navbar")$selectedTags()[[1]]
+      expect_null(tagGetAttribute(navbar, "role"))
+      expect_equal(
+        query$find(paste0("header.navbar > nav", container_class))$length(),
+        1
+      )
+
+      main_roles <- vapply(
+        query$find("div")$selectedTags(),
+        function(tag) identical(tagGetAttribute(tag, "role"), "main"),
+        logical(1)
+      )
+      expect_equal(sum(main_roles), 1)
+      expect_equal(query$find("main")$length(), 0)
+      content <- query$find(paste0("div", container_class))
+      expect_equal(content$length(), 1)
+      expect_equal(tagGetAttribute(content$selectedTags()[[1]], "role"), "main")
+      expect_equal(content$hasClass("html-fill-container"), case$fillable)
+      expect_equal(content$hasClass("html-fill-item"), case$fillable)
+    })
+
+    it(paste(case_name, "retains the existing main landmark with a sidebar"), {
+      page_fn <- switch(
+        case$page_type,
+        page_navbar = page_navbar,
+        navbarPage = shiny::navbarPage
+      )
+      ui <- page_fn(
+        title = "foo",
+        nav_panel("One", "content"),
+        theme = bs_theme(),
+        fluid = case$fluid,
+        fillable = case$fillable,
+        sidebar = sidebar("side", open = "always"),
+        navbar_options = navbar_options(class = "sticky-top")
+      )
+      query <- tagQuery(ui)
+      container_class <- if (case$fluid) ".container-fluid" else ".container"
+
+      expect_equal(query$find("header.navbar")$length(), 1)
+      expect_equal(query$find("header.navbar.sticky-top")$length(), 1)
+      navbar <- query$find("header.navbar")$selectedTags()[[1]]
+      expect_null(tagGetAttribute(navbar, "role"))
+      expect_equal(
+        query$find(paste0("header.navbar > nav", container_class))$length(),
+        1
+      )
+
+      main_roles <- vapply(
+        query$find("div")$selectedTags(),
+        function(tag) identical(tagGetAttribute(tag, "role"), "main"),
+        logical(1)
+      )
+      expect_equal(sum(main_roles), 0)
+      expect_equal(query$find("main.bslib-page-main")$length(), 1)
+    })
+  }
+})
+
+test_that("page_navbar() keeps the navbar and content as adjacent siblings", {
+  skip_if_not_installed("shiny")
+
+  for (has_sidebar in c(TRUE, FALSE)) {
+    html <- renderTags(page_navbar(
+      title = "foo",
+      sidebar = if (has_sidebar) sidebar("side", open = "always"),
+      nav_panel("One", "content")
+    ))$html
+
+    # tagQuery() doesn't support adjacent-sibling selectors.
+    expect_match(html, "</header>\\s*<div\\b", perl = TRUE)
+  }
+})
+
+test_that("shiny::navbarPage() has landmarks with its non-fillable default", {
+  skip_if_not_installed("shiny")
+
+  themes <- list(NULL, bs_theme(3), bs_theme(4), bs_theme(5))
+  for (theme in themes) {
+    query <- tagQuery(shiny::navbarPage(
+      title = "foo",
+      nav_panel("One", "content"),
+      theme = theme
+    ))
+
+    expect_equal(query$find("header.navbar > nav.container-fluid")$length(), 1)
+    content <- query$find("div.container-fluid")
+    expect_equal(content$length(), 1)
+    expect_equal(tagGetAttribute(content$selectedTags()[[1]], "role"), "main")
+    expect_false(content$hasClass("html-fill-container"))
+  }
+})
+
+test_that("navset_bar() does not introduce page-level landmarks", {
+  skip_if_not_installed("shiny")
+
+  query <- tagQuery(div(navset_bar(
+    title = "foo",
+    nav_panel("One", "content")
+  )))
+
+  expect_equal(query$find("nav.navbar > div.container-fluid")$length(), 1)
+  navbar <- query$find("nav.navbar")$selectedTags()[[1]]
+  expect_equal(tagGetAttribute(navbar, "role"), "navigation")
+  expect_equal(query$find("header")$length(), 0)
+  expect_equal(query$find("main")$length(), 0)
+  main_roles <- vapply(
+    query$find("div")$selectedTags(),
+    function(tag) identical(tagGetAttribute(tag, "role"), "main"),
+    logical(1)
+  )
+  expect_false(any(main_roles))
+})
+
 test_that("page_sidebar()", {
   with_private_seed()