From 8da6f4c9223dd18fb2dee6e66a98b981331b9c7d Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 14 May 2024 17:36:18 -0500 Subject: [PATCH 01/11] Rewrite navbar html generation from first principles --- R/build-news.R | 6 +- R/navbar-menu.R | 199 +++++++++++++++ R/navbar.R | 351 ++++++++++++++------------- tests/testthat/_snaps/navbar-menu.md | 68 ++++++ tests/testthat/_snaps/navbar.md | 106 -------- tests/testthat/test-navbar-menu.R | 162 +++++++++++++ tests/testthat/test-navbar.R | 68 ------ 7 files changed, 611 insertions(+), 349 deletions(-) create mode 100644 R/navbar-menu.R create mode 100644 tests/testthat/_snaps/navbar-menu.md create mode 100644 tests/testthat/test-navbar-menu.R diff --git a/R/build-news.R b/R/build-news.R index 54703c330..6ef5c0514 100644 --- a/R/build-news.R +++ b/R/build-news.R @@ -250,12 +250,12 @@ version_page <- function(x) { navbar_news <- function(pkg) { releases_meta <- pkg$meta$news$releases if (!is.null(releases_meta)) { - menu(tr_("News"), + menu_submenu(tr_("News"), c( - list(menu_text(tr_("Releases"))), + list(menu_heading(tr_("Releases"))), releases_meta, list( - menu_spacer(), + menu_separator(), menu_link(tr_("Changelog"), "news/index.html") ) ) diff --git a/R/navbar-menu.R b/R/navbar-menu.R new file mode 100644 index 000000000..7b6d7d3dd --- /dev/null +++ b/R/navbar-menu.R @@ -0,0 +1,199 @@ +# Menu constructors ----------------------------------------------------------- + +# Helpers for use within pkgdown itself +menu_submenu <- function(text, children) { + if (length(children) == 0) { + return() + } else { + list(text = text, children = children) + } +} +menu_link <- function(text, href) list(text = text, href = href) +menu_links <- function(text, href) { + purrr::map2(text, href, menu_link) +} +menu_heading <- function(text, ...) list(text = text, ...) +menu_separator <- function() list(text = "----") +menu_search <- function() list(search = list()) +menu_icon <- function(icon, href, label) { + list(icon = icon, href = href, "aria-label" = label) +} + +menu_type <- function(x) { + if (is.null(x)) { + "NULL" + } else if (!is.null(x$children)) { + "menu" + } else if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) { + "separator" + } else if (!is.null(x$text) && is.null(x$href)) { + "heading" + } else if ((!is.null(x$text) || !is.null(x$icon)) && !is.null(x$href)) { + "link" + } else if (!is.null(x$search)) { + "search" + } else if (!is_named(x)) { + "list" + } else { + cli::cli_abort("Unknown navbar component with names {names(x)}.") + } +} + +# Menu renderers -------------------------------------------------------------- + +navbar_html <- function(x, path_depth = 0L, depth = 0L, side = c("left", "right")) { + side <- arg_match(side) + type <- menu_type(x) + + if (type == "NULL") { + return("") + } else if (type == "list") { + return(navbar_html_list(x, depth = depth, path_depth = path_depth, side = side)) + } + + text <- switch(type, + menu = navbar_html_menu(x, depth = depth, path_depth = path_depth, side = side), + heading = navbar_html_heading(x), + link = navbar_html_link(x, depth = depth), + separator = navbar_html_separator(), + search = navbar_html_search(x, path_depth = path_depth) + ) + + if (type == "menu") { + class <- c(if (depth == 0L) "nav-item", "dropdown") + } else { + class <- if (depth == 0L) "nav-item" else "dropdown-item" + } + html_tag("li", class = class, text) +} + +navbar_html_list <- function(x, path_depth = 0L, depth = 0L, side = "left") { + tags <- purrr::map_chr( + x, + navbar_html, + path_depth = path_depth, + depth = depth, + side = side + ) + paste0(tags, collapse = "\n") +} + +navbar_html_menu <- function(x, path_depth = 0L, depth = 0L, side = "left") { + id <- paste0("dropdown-", make_slug(x$text)) + + button <- html_tag("button", + type = "button", + class = c(if (depth == 0L) "nav-link", "dropdown-toggle"), + id = id, + `data-bs-toggle` = "dropdown", + "aria-expanded" = "false", + "aria-haspopup" = "true", + "aria-label" = x$`aria-label`, + navbar_html_text(x), + ) + + li <- navbar_html( + x$children, + path_depth = path_depth, + depth = depth + 1, + side = side + ) + ul <- html_tag( + "ul", + class = c("dropdown-menu", if (side == "right") "dropdown-menu-end"), + "aria-labelledby" = id, + paste0("\n", indent(li, " "), "\n") + ) + + paste0("\n", indent(paste0(button, "\n", ul), " "), "\n") +} + +navbar_html_link <- function(x, depth = 0) { + html_tag( + "a", + class = if (depth == 0) "nav-link" else "dropdown-item", + href = x$href, + "aria-label" = x$`aria-label`, + navbar_html_text(x) + ) +} + +navbar_html_heading <- function(x) { + html_tag( + "h6", + class = "dropdown-header", + "data-toc-skip" = NA, + navbar_html_text(x) + ) +} + +navbar_html_separator <- function() { + '
' +} + +navbar_html_search <- function(x, path_depth = 0) { + paste0( + '' + ) +} + +# Reused HTML components ----------------------------------------------------- + +html_tag <- function(tag, ..., class = NULL) { + dots <- list2(...) + dots_attr <- dots[names2(dots) != ""] + dots_child <- dots[names2(dots) == ""] + + if (!is.null(class)) { + class <- paste0(class, collapse = " ") + } + attr <- purrr::compact(c(list(class = class), dots_attr)) + if (length(attr) > 0) { + html_attr <- ifelse( + is.na(attr), + names(attr), + paste0(names(attr), '="', attr, '"') + ) + html_attr <- paste0(" ", paste0(html_attr, collapse = " ")) + } else { + html_attr <- "" + } + + html_child <- paste0(purrr::compact(dots_child), collapse = " ") + + paste0("<", tag, html_attr, ">", html_child, "") +} + +navbar_html_text <- function(x) { + if (is.null(x$icon)) { + icon <- "" + } else { + # Extract icon set from class name + classes <- strsplit(x$icon, " ")[[1]] + icon_classes <- classes[grepl("-", classes)] + iconset <- purrr::map_chr(strsplit(icon_classes, "-"), 1) + + icon <- html_tag("span", class = unique(c(iconset, classes))) + } + + paste0( + icon, + if (!is.null(x$icon) && !is.null(x$text)) " ", + escape_html(x$text) + ) +} + +indent <- function(x, indent) { + paste0(indent, gsub("\n", paste0("\n", indent), x)) +} \ No newline at end of file diff --git a/R/navbar.R b/R/navbar.R index e1f112108..1954aed22 100644 --- a/R/navbar.R +++ b/R/navbar.R @@ -122,11 +122,12 @@ navbar_components <- function(pkg = ".") { # in BS3, search is hardcoded in the template if (pkg$bs_version == 5) { - menu$search <- list(search = NULL) + menu$search <- menu_search() } if (!is.null(pkg$tutorials)) { - menu$tutorials <- menu(tr_("Tutorials"), + menu$tutorials <- menu( + tr_("Tutorials"), menu_links(pkg$tutorials$title, pkg$tutorials$file_out) ) } @@ -134,8 +135,8 @@ navbar_components <- function(pkg = ".") { menu$github <- switch( repo_type(pkg), - github = menu_icon("github", repo_home(pkg), style = "fab"), - gitlab = menu_icon("gitlab", repo_home(pkg), style = "fab"), + github = menu_icon("fab fa-github fa-lb", repo_home(pkg), "GitHub"), + gitlab = menu_icon("fab fa-gitlab fa-lg", repo_home(pkg), "GitLab"), NULL ) @@ -173,188 +174,194 @@ navbar_articles <- function(pkg = ".") { vig <- pkg$vignettes[select_vignettes(section$contents, pkg$vignettes), , drop = FALSE] vig <- vig[vig$name != pkg$package, , drop = FALSE] c( - if (!is.null(section$navbar)) list(menu_spacer(), menu_text(section$navbar)), + if (!is.null(section$navbar)) list(menu_separator(), menu_heading(section$navbar)), menu_links(vig$title, vig$file_out) ) }) children <- unlist(sections, recursive = FALSE, use.names = FALSE) if (length(navbar) != length(articles)) { - children <- c(children, list(menu_spacer(), menu_link(tr_("More articles..."), "articles/index.html"))) - } - menu$articles <- menu(tr_("Articles"), children) - } - } - print_yaml(menu) -} - - -# Menu helpers ------------------------------------------------------------- - -menu <- function(text, children) { - if (length(children) == 0) - return() - list(text = text, menu = children) -} -menu_link <- function(text, href) { - list(text = text, href = href) -} -menu_links <- function(text, href) { - purrr::map2(text, href, ~ list(text = .x, href = .y)) -} -menu_icon <- function(icon, href, style = "fas") { - list(icon = paste0(style, " fa-", icon, " fa-lg"), href = href, "aria-label" = icon) -} -menu_text <- function(text) { - list(text = text) -} -menu_spacer <- function() { - menu_text("---------") -} - -menu_search <- function(depth = 0) { - paste0( - '
    • ' - ) -} - -bs4_navbar_links_html <- function(links, side = c("left", "right")) { - as.character(bs4_navbar_links_tags(links, side = side), options = character()) -} - -bs4_navbar_links_tags <- function(links, depth = 0L, side = "left") { - rlang::check_installed("htmltools") - - if (is.null(links)) { - return(htmltools::tagList()) - } - - # sub-menu - is_submenu <- (depth > 0L) - - # function for links - tackle_link <- function(x, index, is_submenu, depth) { - - if (has_name(x, "search")) { - return(htmltools::HTML(menu_search(depth))) - } - - if (!is.null(x$menu)) { - - if (is_submenu) { - menu_class <- "dropdown-item" - link_text <- bs4_navbar_link_text(x) - } else { - menu_class <- "nav-item dropdown" - link_text <- bs4_navbar_link_text(x) - } - - submenuLinks <- bs4_navbar_links_tags( - x$menu, - depth = depth + 1L, - side = side - ) - - dropdown_class <- "dropdown-menu" - if (side == "right") { - dropdown_class <- paste(dropdown_class, "dropdown-menu-end") - } - - return( - htmltools::tags$li( - class = menu_class, - htmltools::tags$button( - href = "#", - class = "nav-link dropdown-toggle", - `data-bs-toggle` = "dropdown", - type = "button", - `aria-expanded` = "false", - `aria-haspopup` = "true", - link_text, - id = paste0("dropdown-", make_slug(link_text)), - "aria-label" = x$`aria-label` %||% NULL - ), - htmltools::tags$div( - class = dropdown_class, - `aria-labelledby` = paste0("dropdown-", make_slug(link_text)), - submenuLinks + children <- c( + children, + list( + menu_separator(), + menu_link(tr_("More articles..."), "articles/index.html") ) ) - ) - - } - - if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) { - - if (index == 1) { - return(htmltools::tagList()) - } else { - return(htmltools::tags$div(class = "dropdown-divider")) } + menu$articles <- menu(tr_("Articles"), children) } - - if (!is.null(x$text) && is.null(x$href)) { - # header - return(htmltools::tags$h6(class = "dropdown-header", `data-toc-skip` = NA, x$text)) - } - - # standard menu item - textTags <- bs4_navbar_link_text(x) - - if (is_submenu) { - return( - htmltools::tags$a( - class = "dropdown-item", - href = x$href, - target = x$target, - textTags, - "aria-label" = x$`aria-label` %||% NULL - ) - ) - } - - htmltools::tags$li( - class = "nav-item", - htmltools::tags$a( - class = "nav-link", - href = x$href, - target = x$target, - textTags, - "aria-label" = x$`aria-label` %||% NULL - ) - ) - } - - tags <- purrr::map2(links, seq_along(links), tackle_link, is_submenu = is_submenu, depth = depth) - htmltools::tagList(tags) + print_yaml(menu) } -bs4_navbar_link_text <- function(x, ...) { - if (!is.null(x$icon)) { - # Find the icon set - classes <- strsplit(x$icon, " ")[[1]] - icon_classes <- classes[grepl("-", classes)] - iconset <- purrr::map_chr(strsplit(icon_classes, "-"), 1) - class <- paste0(unique(c(iconset, classes)), collapse = " ") - text <- paste0(if (!is.null(x$text)) " ", x$text) - htmltools::tagList(htmltools::tags$span(class = class), text, ...) - } else { - htmltools::tagList(x$text, ...) - } -} +# # Menu helpers ------------------------------------------------------------- + +# menu <- function(text, children) { +# if (length(children) == 0) +# return() +# list(text = text, menu = children) +# } +# menu_link <- function(text, href) { +# list(text = text, href = href) +# } +# menu_links <- function(text, href) { +# purrr::map2(text, href, ~ list(text = .x, href = .y)) +# } +# menu_icon <- function(icon, href, style = "fas") { +# list(icon = paste0(style, " fa-", icon, " fa-lg"), href = href, "aria-label" = icon) +# } +# menu_text <- function(text) { +# list(text = text) +# } +# menu_spacer <- function() { +# menu_text("---------") +# } + +# menu_search <- function(depth = 0) { +# paste0( +# '
    • ' +# ) +# } + +# bs4_navbar_links_html <- function(links, side = c("left", "right")) { +# as.character(bs4_navbar_links_tags(links, side = side), options = character()) +# } + +# bs4_navbar_links_tags <- function(links, depth = 0L, side = "left") { +# rlang::check_installed("htmltools") + +# if (is.null(links)) { +# return(htmltools::tagList()) +# } + +# # sub-menu +# is_submenu <- (depth > 0L) + +# # function for links +# tackle_link <- function(x, index, is_submenu, depth) { + +# if (has_name(x, "search")) { +# return(htmltools::HTML(menu_search(depth))) +# } + +# if (!is.null(x$menu)) { + +# if (is_submenu) { +# menu_class <- "dropdown-item" +# link_text <- bs4_navbar_link_text(x) +# } else { +# menu_class <- "nav-item dropdown" +# link_text <- bs4_navbar_link_text(x) +# } + +# submenuLinks <- bs4_navbar_links_tags( +# x$menu, +# depth = depth + 1L, +# side = side +# ) + +# dropdown_class <- "dropdown-menu" +# if (side == "right") { +# dropdown_class <- paste(dropdown_class, "dropdown-menu-end") +# } + +# return( +# htmltools::tags$li( +# class = menu_class, +# htmltools::tags$button( +# href = "#", +# class = "nav-link dropdown-toggle", +# `data-bs-toggle` = "dropdown", +# type = "button", +# `aria-expanded` = "false", +# `aria-haspopup` = "true", +# link_text, +# id = paste0("dropdown-", make_slug(link_text)), +# "aria-label" = x$`aria-label` %||% NULL +# ), +# htmltools::tags$div( +# class = dropdown_class, +# `aria-labelledby` = paste0("dropdown-", make_slug(link_text)), +# submenuLinks +# ) +# ) +# ) + +# } + +# if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) { + +# if (index == 1) { +# return(htmltools::tagList()) +# } else { +# return(htmltools::tags$div(class = "dropdown-divider")) +# } +# } + +# if (!is.null(x$text) && is.null(x$href)) { +# # header +# return(htmltools::tags$h6(class = "dropdown-header", `data-toc-skip` = NA, x$text)) +# } + +# # standard menu item +# textTags <- bs4_navbar_link_text(x) + +# if (is_submenu) { +# return( +# htmltools::tags$a( +# class = "dropdown-item", +# href = x$href, +# target = x$target, +# textTags, +# "aria-label" = x$`aria-label` %||% NULL +# ) +# ) +# } + +# htmltools::tags$li( +# class = "nav-item", +# htmltools::tags$a( +# class = "nav-link", +# href = x$href, +# target = x$target, +# textTags, +# "aria-label" = x$`aria-label` %||% NULL +# ) +# ) + +# } + +# tags <- purrr::map2(links, seq_along(links), tackle_link, is_submenu = is_submenu, depth = depth) +# htmltools::tagList(tags) +# } + +# bs4_navbar_link_text <- function(x, ...) { +# if (!is.null(x$icon)) { +# # Find the icon set +# classes <- strsplit(x$icon, " ")[[1]] +# icon_classes <- classes[grepl("-", classes)] +# iconset <- purrr::map_chr(strsplit(icon_classes, "-"), 1) +# class <- paste0(unique(c(iconset, classes)), collapse = " ") + +# text <- paste0(if (!is.null(x$text)) " ", x$text) +# htmltools::tagList(htmltools::tags$span(class = class), text, ...) +# } else { +# htmltools::tagList(x$text, ...) +# } +# } # Testing helpers --------------------------------------------------------- # Simulate minimal package structure so we can more easily test diff --git a/tests/testthat/_snaps/navbar-menu.md b/tests/testthat/_snaps/navbar-menu.md new file mode 100644 index 000000000..36a1b4e1f --- /dev/null +++ b/tests/testthat/_snaps/navbar-menu.md @@ -0,0 +1,68 @@ +# can construct menu with children + + Code + cat(navbar_html(menu)) + Output +
  • + + +
    • + +# can construct nested menu + + Code + cat(navbar_html(menu)) + Output +
  • + + +
    • + +# can construct bullets + + Code + cat(navbar_html(menu_icon("fa-question", "https://example.com", "label"))) + Output +
    • + Code + cat(navbar_html(menu_heading("Hi"))) + Output +
  • Hi
    • + Code + cat(navbar_html(menu_link("Hi", "https://example.com"))) + Output +
  • Hi
    • + +# simple components don't change without warning + + Code + cat(navbar_html_heading(menu_heading("a"))) + Output +
    a
    + Code + cat(navbar_html_link(menu_link("a", "b"))) + Output + a + Code + cat(navbar_html_separator()) + Output +
    + Code + cat(navbar_html_search()) + Output + + diff --git a/tests/testthat/_snaps/navbar.md b/tests/testthat/_snaps/navbar.md index 5e15ae36f..71569af7a 100644 --- a/tests/testthat/_snaps/navbar.md +++ b/tests/testthat/_snaps/navbar.md @@ -178,109 +178,3 @@ i See details in `vignette(pkgdown::customise)`. i Edit _pkgdown.yml to fix the problem. -# render_navbar_links BS3 & BS4 default - - Code - cat(render_navbar_links(x, pkg = list(bs_version = 3))) - Output -
  • - Get started -
    • -
  • - Reference -
    • -
  • - - -
    • -
  • - News -
    • - ---- - - Code - cat(render_navbar_links(x, pkg = list(bs_version = 4))) - Output -
  • - Get started -
    • -
  • - Reference -
    • -
  • - -
    - Auto-linking - Search - Metadata - Customize your pkgdown website -
    - More... -
    -
    • -
  • - News -
    • - -# render_navbar_links BS4 no divider before first element - - Code - cat(render_navbar_links(x, pkg = list(bs_version = 4))) - Output -
  • - -
    -
    First section
    - Search - Metadata - Customize your pkgdown website -
    - More... -
    -
    • - -# can specific link target - - Code - bs4_navbar_links_tags(list(menu = list(text = "text", href = "href", target = "_blank"))) - Output -
  • - text -
    • - Code - bs4_navbar_links_tags(list(menu = list(text = "text", href = "href", target = "_blank")), - depth = 1) - Output - text - -# can render search helper - - Code - bs4_navbar_links_tags(list(menu = list(search = TRUE))) - Output -
    • - diff --git a/tests/testthat/test-navbar-menu.R b/tests/testthat/test-navbar-menu.R new file mode 100644 index 000000000..a707052b6 --- /dev/null +++ b/tests/testthat/test-navbar-menu.R @@ -0,0 +1,162 @@ +test_that("can construct menu with children", { + menu <- menu_submenu( + "Title", + list( + menu_heading("Heading"), + menu_separator(), + menu_link("Link", "https://example.com") + ) + ) + expect_snapshot(cat(navbar_html(menu))) +}) + +test_that("can construct nested menu", { + menu <- menu_submenu( + "Title", + list( + menu_heading("Heading"), + menu_submenu("Submenu", list( + menu_link("Link", "https://example.com") + )) + ) + ) + expect_snapshot(cat(navbar_html(menu))) +}) + + +test_that("can construct bullets", { + expect_snapshot({ + cat(navbar_html(menu_icon("fa-question", "https://example.com", "label"))) + cat(navbar_html(menu_heading("Hi"))) + cat(navbar_html(menu_link("Hi", "https://example.com"))) + }) +}) + +test_that("bullet class varies based on depth", { + expect_equal( + navbar_html(menu_separator(), depth = 0), + '
    • ' + ) + + expect_equal( + navbar_html(menu_separator(), depth = 1), + '
    • ' + ) +}) + +test_that("simple components don't change without warning", { + expect_snapshot({ + cat(navbar_html_heading(menu_heading("a"))) + cat(navbar_html_link(menu_link("a", "b"))) + cat(navbar_html_separator()) + cat(navbar_html_search()) + }) +}) + +# Building blocks ----------------------------------------------------------- + +test_that("navbar_html_text() combines icons and text", { + expect_equal(navbar_html_text(list(text = "a")), 'a') + expect_equal( + navbar_html_text(list(icon = "fas-github")), + '' + ) + expect_equal( + navbar_html_text(list(text = "a", icon = "fas-github")), + ' a' + ) +}) + +test_that("navbar_html_text() escapes text", { + expect_equal(navbar_html_text(list(text = "<>")), '<>') +}) + +test_that("named arguments become attributes", { + expect_equal(html_tag("a"), '') + expect_equal(html_tag("a", x = NULL), '') + expect_equal(html_tag("a", x = NA), '') + expect_equal(html_tag("a", x = 1), '') +}) + +test_that("unnamed arguments become children", { + expect_equal(html_tag("a", "b"), 'b') + expect_equal(html_tag("a", "b", NULL), 'b') +}) + +test_that("class components are pasted together", { + expect_equal(html_tag("a", class = NULL), '') + expect_equal(html_tag("a", class = "a"), '') + expect_equal(html_tag("a", class = c("a", "b")), '') +}) + +# ------- + +# test_that("render_navbar_links BS3 & BS4 default", { +# x <- list( +# intro = list(text = "Get started", href = "articles/pkgdown.html"), +# reference = list(text = "Reference", href = "reference/index.html"), +# articles = list( +# text = "Articles", +# menu = list( +# list(text = "Auto-linking", href = "articles/linking.html"), +# list(text = "Search", href = "articles/search.html"), +# list(text = "Metadata", href = "articles/metadata.html"), +# list(text = "Customize your pkgdown website", href = "articles/customization.html"), +# list(text = "---------"), +# list(text = "More...", href = "articles/index.html") +# ) +# ), +# news = list(text = "News", href = "news/index.html") +# ) + +# expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 3)))) +# expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 4)))) +# }) + +# test_that("render_navbar_links BS4 no divider before first element", { +# x <- list( +# articles = list( +# text = "Articles", +# menu = list( +# list(text = "---------"), +# list(text = "First section"), +# list(text = "Search", href = "articles/search.html"), +# list(text = "Metadata", href = "articles/metadata.html"), +# list(text = "Customize your pkgdown website", href = "articles/customization.html"), +# list(text = "---------"), +# list(text = "More...", href = "articles/index.html") +# ) +# ) +# ) +# expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 4)))) +# }) + + +# test_that("can specific link target", { +# expect_snapshot({ +# bs4_navbar_links_tags( +# list(menu = list(text = "text", href = "href", target = '_blank')) +# ) +# bs4_navbar_links_tags( +# list(menu = list(text = "text", href = "href", target = '_blank')), +# depth = 1 +# ) +# }) +# }) + +# test_that("can render search helper", { +# expect_snapshot({ +# bs4_navbar_links_tags(list(menu = list(search = TRUE))) +# }) +# }) + +# test_that("icons extract icon set", { +# expect_equal( +# as.character(bs4_navbar_link_text(menu_icon("github", ""))), +# '' +# ) +# expect_equal( +# as.character(bs4_navbar_link_text(menu_icon("github", "", style = "fab"))), +# '' +# ) +# }) diff --git a/tests/testthat/test-navbar.R b/tests/testthat/test-navbar.R index 65a570fcd..59d46a3df 100644 --- a/tests/testthat/test-navbar.R +++ b/tests/testthat/test-navbar.R @@ -159,45 +159,6 @@ test_that("for bs4, default bg and type come from bootswatch", { expect_equal(style, list(bg = "primary", type = "light")) }) -test_that("render_navbar_links BS3 & BS4 default", { - x <- list( - intro = list(text = "Get started", href = "articles/pkgdown.html"), - reference = list(text = "Reference", href = "reference/index.html"), - articles = list( - text = "Articles", - menu = list( - list(text = "Auto-linking", href = "articles/linking.html"), - list(text = "Search", href = "articles/search.html"), - list(text = "Metadata", href = "articles/metadata.html"), - list(text = "Customize your pkgdown website", href = "articles/customization.html"), - list(text = "---------"), - list(text = "More...", href = "articles/index.html") - ) - ), - news = list(text = "News", href = "news/index.html") - ) - - expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 3)))) - expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 4)))) -}) - -test_that("render_navbar_links BS4 no divider before first element", { - x <- list( - articles = list( - text = "Articles", - menu = list( - list(text = "---------"), - list(text = "First section"), - list(text = "Search", href = "articles/search.html"), - list(text = "Metadata", href = "articles/metadata.html"), - list(text = "Customize your pkgdown website", href = "articles/customization.html"), - list(text = "---------"), - list(text = "More...", href = "articles/index.html") - ) - ) - ) - expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 4)))) -}) test_that("dropdowns on right are right-aligned", { x <- list( @@ -218,32 +179,3 @@ test_that("dropdowns on right are right-aligned", { expect_equal(xpath_attr(right, ".//div", "class"), "dropdown-menu dropdown-menu-end") expect_equal(xpath_attr(left, ".//div", "class"), "dropdown-menu") }) - -test_that("can specific link target", { - expect_snapshot({ - bs4_navbar_links_tags( - list(menu = list(text = "text", href = "href", target = '_blank')) - ) - bs4_navbar_links_tags( - list(menu = list(text = "text", href = "href", target = '_blank')), - depth = 1 - ) - }) -}) - -test_that("can render search helper", { - expect_snapshot({ - bs4_navbar_links_tags(list(menu = list(search = TRUE))) - }) -}) - -test_that("icons extract icon set", { - expect_equal( - as.character(bs4_navbar_link_text(menu_icon("github", ""))), - '' - ) - expect_equal( - as.character(bs4_navbar_link_text(menu_icon("github", "", style = "fab"))), - '' - ) -}) From 79bb92e6df8e9b9c303548cad0f7570b5f0547d5 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 15 May 2024 08:19:40 -0500 Subject: [PATCH 02/11] Plumb up to actual site --- R/navbar-menu.R | 16 +-- R/navbar.R | 181 ++------------------------- pkgdown/_pkgdown.yml | 17 +++ tests/testthat/_snaps/navbar-menu.md | 24 +--- tests/testthat/_snaps/navbar.md | 24 ++-- tests/testthat/test-navbar-menu.R | 16 +-- tests/testthat/test-navbar.R | 6 +- 7 files changed, 53 insertions(+), 231 deletions(-) diff --git a/R/navbar-menu.R b/R/navbar-menu.R index 7b6d7d3dd..0e2948808 100644 --- a/R/navbar-menu.R +++ b/R/navbar-menu.R @@ -13,7 +13,7 @@ menu_links <- function(text, href) { purrr::map2(text, href, menu_link) } menu_heading <- function(text, ...) list(text = text, ...) -menu_separator <- function() list(text = "----") +menu_separator <- function() list(text = "---------") menu_search <- function() list(search = list()) menu_icon <- function(icon, href, label) { list(icon = icon, href = href, "aria-label" = label) @@ -22,6 +22,9 @@ menu_icon <- function(icon, href, label) { menu_type <- function(x) { if (is.null(x)) { "NULL" + } else if (!is.null(x$menu)) { + # https://github.com/twbs/bootstrap/pull/6342 + cli::cli_abort("Nested menus are not supported in BS5.") } else if (!is.null(x$children)) { "menu" } else if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) { @@ -59,11 +62,10 @@ navbar_html <- function(x, path_depth = 0L, depth = 0L, side = c("left", "right" search = navbar_html_search(x, path_depth = path_depth) ) - if (type == "menu") { - class <- c(if (depth == 0L) "nav-item", "dropdown") - } else { - class <- if (depth == 0L) "nav-item" else "dropdown-item" - } + class <- c( + if (depth == 0L) "nav-item", + if (type == "menu") "dropdown" + ) html_tag("li", class = class, text) } @@ -92,7 +94,7 @@ navbar_html_menu <- function(x, path_depth = 0L, depth = 0L, side = "left") { navbar_html_text(x), ) - li <- navbar_html( + li <- navbar_html_list( x$children, path_depth = path_depth, depth = depth + 1, diff --git a/R/navbar.R b/R/navbar.R index 1954aed22..7383ccc43 100644 --- a/R/navbar.R +++ b/R/navbar.R @@ -108,7 +108,7 @@ render_navbar_links <- function(x, depth = 0L, pkg, side = c("left", "right")) { if (pkg$bs_version == 3) { rmarkdown::navbar_links_html(x) } else { - bs4_navbar_links_html(x, side = side) + navbar_html_list(x, path_depth = depth, side = side) } } @@ -126,7 +126,7 @@ navbar_components <- function(pkg = ".") { } if (!is.null(pkg$tutorials)) { - menu$tutorials <- menu( + menu$tutorials <- menu_submenu( tr_("Tutorials"), menu_links(pkg$tutorials$title, pkg$tutorials$file_out) ) @@ -135,7 +135,7 @@ navbar_components <- function(pkg = ".") { menu$github <- switch( repo_type(pkg), - github = menu_icon("fab fa-github fa-lb", repo_home(pkg), "GitHub"), + github = menu_icon("fab fa-github fa-lg", repo_home(pkg), "GitHub"), gitlab = menu_icon("fab fa-gitlab fa-lg", repo_home(pkg), "GitLab"), NULL ) @@ -161,7 +161,10 @@ navbar_articles <- function(pkg = ".") { meta <- pkg$meta if (!has_name(meta, "articles")) { vignettes <- vignettes[!pkg_intro, , drop = FALSE] - menu$articles <- menu(tr_("Articles"), menu_links(vignettes$title, vignettes$file_out)) + menu$articles <- menu_submenu( + tr_("Articles"), + menu_links(vignettes$title, vignettes$file_out) + ) } else { articles <- meta$articles @@ -189,180 +192,12 @@ navbar_articles <- function(pkg = ".") { ) ) } - menu$articles <- menu(tr_("Articles"), children) + menu$articles <- menu_submenu(tr_("Articles"), children) } } print_yaml(menu) } - -# # Menu helpers ------------------------------------------------------------- - -# menu <- function(text, children) { -# if (length(children) == 0) -# return() -# list(text = text, menu = children) -# } -# menu_link <- function(text, href) { -# list(text = text, href = href) -# } -# menu_links <- function(text, href) { -# purrr::map2(text, href, ~ list(text = .x, href = .y)) -# } -# menu_icon <- function(icon, href, style = "fas") { -# list(icon = paste0(style, " fa-", icon, " fa-lg"), href = href, "aria-label" = icon) -# } -# menu_text <- function(text) { -# list(text = text) -# } -# menu_spacer <- function() { -# menu_text("---------") -# } - -# menu_search <- function(depth = 0) { -# paste0( -# '
    • ' -# ) -# } - -# bs4_navbar_links_html <- function(links, side = c("left", "right")) { -# as.character(bs4_navbar_links_tags(links, side = side), options = character()) -# } - -# bs4_navbar_links_tags <- function(links, depth = 0L, side = "left") { -# rlang::check_installed("htmltools") - -# if (is.null(links)) { -# return(htmltools::tagList()) -# } - -# # sub-menu -# is_submenu <- (depth > 0L) - -# # function for links -# tackle_link <- function(x, index, is_submenu, depth) { - -# if (has_name(x, "search")) { -# return(htmltools::HTML(menu_search(depth))) -# } - -# if (!is.null(x$menu)) { - -# if (is_submenu) { -# menu_class <- "dropdown-item" -# link_text <- bs4_navbar_link_text(x) -# } else { -# menu_class <- "nav-item dropdown" -# link_text <- bs4_navbar_link_text(x) -# } - -# submenuLinks <- bs4_navbar_links_tags( -# x$menu, -# depth = depth + 1L, -# side = side -# ) - -# dropdown_class <- "dropdown-menu" -# if (side == "right") { -# dropdown_class <- paste(dropdown_class, "dropdown-menu-end") -# } - -# return( -# htmltools::tags$li( -# class = menu_class, -# htmltools::tags$button( -# href = "#", -# class = "nav-link dropdown-toggle", -# `data-bs-toggle` = "dropdown", -# type = "button", -# `aria-expanded` = "false", -# `aria-haspopup` = "true", -# link_text, -# id = paste0("dropdown-", make_slug(link_text)), -# "aria-label" = x$`aria-label` %||% NULL -# ), -# htmltools::tags$div( -# class = dropdown_class, -# `aria-labelledby` = paste0("dropdown-", make_slug(link_text)), -# submenuLinks -# ) -# ) -# ) - -# } - -# if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) { - -# if (index == 1) { -# return(htmltools::tagList()) -# } else { -# return(htmltools::tags$div(class = "dropdown-divider")) -# } -# } - -# if (!is.null(x$text) && is.null(x$href)) { -# # header -# return(htmltools::tags$h6(class = "dropdown-header", `data-toc-skip` = NA, x$text)) -# } - -# # standard menu item -# textTags <- bs4_navbar_link_text(x) - -# if (is_submenu) { -# return( -# htmltools::tags$a( -# class = "dropdown-item", -# href = x$href, -# target = x$target, -# textTags, -# "aria-label" = x$`aria-label` %||% NULL -# ) -# ) -# } - -# htmltools::tags$li( -# class = "nav-item", -# htmltools::tags$a( -# class = "nav-link", -# href = x$href, -# target = x$target, -# textTags, -# "aria-label" = x$`aria-label` %||% NULL -# ) -# ) - -# } - -# tags <- purrr::map2(links, seq_along(links), tackle_link, is_submenu = is_submenu, depth = depth) -# htmltools::tagList(tags) -# } - -# bs4_navbar_link_text <- function(x, ...) { -# if (!is.null(x$icon)) { -# # Find the icon set -# classes <- strsplit(x$icon, " ")[[1]] -# icon_classes <- classes[grepl("-", classes)] -# iconset <- purrr::map_chr(strsplit(icon_classes, "-"), 1) -# class <- paste0(unique(c(iconset, classes)), collapse = " ") - -# text <- paste0(if (!is.null(x$text)) " ", x$text) -# htmltools::tagList(htmltools::tags$span(class = class), text, ...) -# } else { -# htmltools::tagList(x$text, ...) -# } -# } - # Testing helpers --------------------------------------------------------- # Simulate minimal package structure so we can more easily test diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 7d3366acc..02f50ee56 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -50,6 +50,23 @@ articles: contents: - starts_with("test") +navbar: + structure: + right: [search, github, special] + components: + special: + text: Articles + menu: + - text: Category A + - text: Title A1 + href: articles/a1.html + - text: Title A2 + href: articles/a2.html + - text: ------- + - text: "Category B" + - text: Article B1 + href: articles/b1.html + reference: - title: Build desc: Build a complete site or one of its components. diff --git a/tests/testthat/_snaps/navbar-menu.md b/tests/testthat/_snaps/navbar-menu.md index 36a1b4e1f..59502ad2c 100644 --- a/tests/testthat/_snaps/navbar-menu.md +++ b/tests/testthat/_snaps/navbar-menu.md @@ -6,27 +6,9 @@
    • -
    • Heading
      • -
      • -
    • Link
      • -
    -
    • - -# can construct nested menu - - Code - cat(navbar_html(menu)) - Output -
  • - -
      -
    • Heading
      • -
    • - - -
      • +
    • Heading
      • +
      • +
    • Link
    • diff --git a/tests/testthat/_snaps/navbar.md b/tests/testthat/_snaps/navbar.md index 71569af7a..9e7067cd2 100644 --- a/tests/testthat/_snaps/navbar.md +++ b/tests/testthat/_snaps/navbar.md @@ -4,7 +4,7 @@ text: Reference href: reference/index.html search: - search: ~ + search: [] --- @@ -13,11 +13,11 @@ text: Reference href: reference/index.html search: - search: ~ + search: [] github: icon: fab fa-github fa-lg href: https://github.com/r-lib/pkgdown - aria-label: github + aria-label: GitHub --- @@ -26,11 +26,11 @@ text: Reference href: reference/index.html search: - search: ~ + search: [] github: icon: fab fa-gitlab fa-lg href: https://gitlab.com/r-lib/pkgdown - aria-label: gitlab + aria-label: GitLab # vignette with package name turns into getting started @@ -39,7 +39,7 @@ text: Reference href: reference/index.html search: - search: ~ + search: [] intro: text: Get started href: test.html @@ -52,7 +52,7 @@ Output articles: text: Articles - menu: + children: - text: Title a href: a.html - text: Title b @@ -77,7 +77,7 @@ Output articles: text: Articles - menu: + children: - text: Title a href: a.html - text: Title b @@ -92,7 +92,7 @@ Output articles: text: Articles - menu: + children: - text: '---------' - text: Label - text: Title a @@ -109,7 +109,7 @@ Output articles: text: Articles - menu: + children: - text: Title a href: a.html - text: '---------' @@ -138,10 +138,10 @@ data_navbar(pkg)[c("left", "right")] Output $left - [1] "
  • \n \n \n \n
    • \n
  • \n\n
    • " + [1] "
    • \n
  • \n\n
    • " $right - [1] "
  • \n Changelog\n
    • " + [1] "
  • Changelog
    • " # data_navbar() works with empty side diff --git a/tests/testthat/test-navbar-menu.R b/tests/testthat/test-navbar-menu.R index a707052b6..6565d7713 100644 --- a/tests/testthat/test-navbar-menu.R +++ b/tests/testthat/test-navbar-menu.R @@ -10,20 +10,6 @@ test_that("can construct menu with children", { expect_snapshot(cat(navbar_html(menu))) }) -test_that("can construct nested menu", { - menu <- menu_submenu( - "Title", - list( - menu_heading("Heading"), - menu_submenu("Submenu", list( - menu_link("Link", "https://example.com") - )) - ) - ) - expect_snapshot(cat(navbar_html(menu))) -}) - - test_that("can construct bullets", { expect_snapshot({ cat(navbar_html(menu_icon("fa-question", "https://example.com", "label"))) @@ -40,7 +26,7 @@ test_that("bullet class varies based on depth", { expect_equal( navbar_html(menu_separator(), depth = 1), - '
    • ' + '
    • ' ) }) diff --git a/tests/testthat/test-navbar.R b/tests/testthat/test-navbar.R index 59d46a3df..84199e09c 100644 --- a/tests/testthat/test-navbar.R +++ b/tests/testthat/test-navbar.R @@ -164,7 +164,7 @@ test_that("dropdowns on right are right-aligned", { x <- list( articles = list( text = "Articles", - menu = list( + children = list( list(text = "A"), list(text = "B"), list(text = "C") @@ -176,6 +176,6 @@ test_that("dropdowns on right are right-aligned", { right <- xml2::read_html(render_navbar_links(x, pkg = pkg, side = "right")) left <- xml2::read_html(render_navbar_links(x, pkg = pkg, side = "left")) - expect_equal(xpath_attr(right, ".//div", "class"), "dropdown-menu dropdown-menu-end") - expect_equal(xpath_attr(left, ".//div", "class"), "dropdown-menu") + expect_equal(xpath_attr(right, ".//ul", "class"), "dropdown-menu dropdown-menu-end") + expect_equal(xpath_attr(left, ".//ul", "class"), "dropdown-menu") }) From 5fcdf9ce84e1cdb901e72c68f7c9330b027df678 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 15 May 2024 08:31:15 -0500 Subject: [PATCH 03/11] Re-liven tests & add target support back --- R/navbar-menu.R | 5 +- tests/testthat/_snaps/navbar-menu.md | 18 ++--- tests/testthat/_snaps/navbar.md | 36 ++++++++++ tests/testthat/test-navbar-menu.R | 102 +++++++-------------------- tests/testthat/test-navbar.R | 22 ++++++ vignettes/customise.Rmd | 11 +-- 6 files changed, 103 insertions(+), 91 deletions(-) diff --git a/R/navbar-menu.R b/R/navbar-menu.R index 0e2948808..ad10ec19c 100644 --- a/R/navbar-menu.R +++ b/R/navbar-menu.R @@ -8,7 +8,9 @@ menu_submenu <- function(text, children) { list(text = text, children = children) } } -menu_link <- function(text, href) list(text = text, href = href) +menu_link <- function(text, href, target = NULL) { + purrr::compact(list(text = text, href = href, target = target)) +} menu_links <- function(text, href) { purrr::map2(text, href, menu_link) } @@ -115,6 +117,7 @@ navbar_html_link <- function(x, depth = 0) { "a", class = if (depth == 0) "nav-link" else "dropdown-item", href = x$href, + target = x$target, "aria-label" = x$`aria-label`, navbar_html_text(x) ) diff --git a/tests/testthat/_snaps/navbar-menu.md b/tests/testthat/_snaps/navbar-menu.md index 59502ad2c..64c1b8ef6 100644 --- a/tests/testthat/_snaps/navbar-menu.md +++ b/tests/testthat/_snaps/navbar-menu.md @@ -30,21 +30,21 @@ # simple components don't change without warning Code - cat(navbar_html_heading(menu_heading("a"))) + cat(navbar_html(menu_heading("a"))) Output -
    a
    +
  • a
    • Code - cat(navbar_html_link(menu_link("a", "b"))) + cat(navbar_html(menu_link("a", "b"))) Output - a +
  • a
    • Code - cat(navbar_html_separator()) + cat(navbar_html(menu_separator())) Output -
    +
    • Code - cat(navbar_html_search()) + cat(navbar_html(menu_search())) Output - + diff --git a/tests/testthat/_snaps/navbar.md b/tests/testthat/_snaps/navbar.md index 9e7067cd2..c60217d77 100644 --- a/tests/testthat/_snaps/navbar.md +++ b/tests/testthat/_snaps/navbar.md @@ -178,3 +178,39 @@ i See details in `vignette(pkgdown::customise)`. i Edit _pkgdown.yml to fix the problem. +# render_navbar_links BS3 & BS4 default + + Code + cat(render_navbar_links(x, pkg = list(bs_version = 3))) + Output +
  • + Get started +
    • +
  • + Reference +
    • +
  • Articles
    • +
  • + News +
    • + +--- + + Code + cat(render_navbar_links(x, pkg = list(bs_version = 4))) + Output +
  • Get started
    • +
  • Reference
    • +
  • + + +
    • +
  • News
    • + diff --git a/tests/testthat/test-navbar-menu.R b/tests/testthat/test-navbar-menu.R index 6565d7713..bf3963bde 100644 --- a/tests/testthat/test-navbar-menu.R +++ b/tests/testthat/test-navbar-menu.R @@ -30,12 +30,34 @@ test_that("bullet class varies based on depth", { ) }) +test_that("icons extract base iconset class automatically", { + expect_match( + navbar_html(menu_icon("fa-question", "https://example.com", "label")), + 'class="fa fa-question"', + fixed = TRUE + ) + + expect_match( + navbar_html(menu_icon("fab fab-github", "https://example.com", "label")), + 'class="fab fab-github"', + fixed = TRUE + ) +}) + +test_that("can specify link target", { + expect_match( + navbar_html(menu_link("a", "b", target = "_blank")), + 'target="_blank"', + fixed = TRUE + ) +}) + test_that("simple components don't change without warning", { expect_snapshot({ - cat(navbar_html_heading(menu_heading("a"))) - cat(navbar_html_link(menu_link("a", "b"))) - cat(navbar_html_separator()) - cat(navbar_html_search()) + cat(navbar_html(menu_heading("a"))) + cat(navbar_html(menu_link("a", "b"))) + cat(navbar_html(menu_separator())) + cat(navbar_html(menu_search())) }) }) @@ -74,75 +96,3 @@ test_that("class components are pasted together", { expect_equal(html_tag("a", class = "a"), '') expect_equal(html_tag("a", class = c("a", "b")), '') }) - -# ------- - -# test_that("render_navbar_links BS3 & BS4 default", { -# x <- list( -# intro = list(text = "Get started", href = "articles/pkgdown.html"), -# reference = list(text = "Reference", href = "reference/index.html"), -# articles = list( -# text = "Articles", -# menu = list( -# list(text = "Auto-linking", href = "articles/linking.html"), -# list(text = "Search", href = "articles/search.html"), -# list(text = "Metadata", href = "articles/metadata.html"), -# list(text = "Customize your pkgdown website", href = "articles/customization.html"), -# list(text = "---------"), -# list(text = "More...", href = "articles/index.html") -# ) -# ), -# news = list(text = "News", href = "news/index.html") -# ) - -# expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 3)))) -# expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 4)))) -# }) - -# test_that("render_navbar_links BS4 no divider before first element", { -# x <- list( -# articles = list( -# text = "Articles", -# menu = list( -# list(text = "---------"), -# list(text = "First section"), -# list(text = "Search", href = "articles/search.html"), -# list(text = "Metadata", href = "articles/metadata.html"), -# list(text = "Customize your pkgdown website", href = "articles/customization.html"), -# list(text = "---------"), -# list(text = "More...", href = "articles/index.html") -# ) -# ) -# ) -# expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 4)))) -# }) - - -# test_that("can specific link target", { -# expect_snapshot({ -# bs4_navbar_links_tags( -# list(menu = list(text = "text", href = "href", target = '_blank')) -# ) -# bs4_navbar_links_tags( -# list(menu = list(text = "text", href = "href", target = '_blank')), -# depth = 1 -# ) -# }) -# }) - -# test_that("can render search helper", { -# expect_snapshot({ -# bs4_navbar_links_tags(list(menu = list(search = TRUE))) -# }) -# }) - -# test_that("icons extract icon set", { -# expect_equal( -# as.character(bs4_navbar_link_text(menu_icon("github", ""))), -# '' -# ) -# expect_equal( -# as.character(bs4_navbar_link_text(menu_icon("github", "", style = "fab"))), -# '' -# ) -# }) diff --git a/tests/testthat/test-navbar.R b/tests/testthat/test-navbar.R index 84199e09c..7a9d2842f 100644 --- a/tests/testthat/test-navbar.R +++ b/tests/testthat/test-navbar.R @@ -160,6 +160,28 @@ test_that("for bs4, default bg and type come from bootswatch", { }) +test_that("render_navbar_links BS3 & BS4 default", { + x <- list( + intro = menu_link("Get started", "articles/pkgdown.html"), + reference = menu_link("Reference", "reference/index.html"), + articles = menu_submenu( + "Articles", + list( + menu_link("Auto-linking", "articles/linking.html"), + menu_link("Search", "articles/search.html"), + menu_link("Metadata", "articles/metadata.html"), + menu_link("Customize your pkgdown website", "articles/customization.html"), + menu_separator(), + menu_link("More...", "articles/index.html") + ) + ), + news = menu_link("News", "news/index.html") + ) + + expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 3)))) + expect_snapshot(cat(render_navbar_links(x, pkg = list(bs_version = 4)))) +}) + test_that("dropdowns on right are right-aligned", { x <- list( articles = list( diff --git a/vignettes/customise.Rmd b/vignettes/customise.Rmd index ea6448bbd..c3c691c75 100644 --- a/vignettes/customise.Rmd +++ b/vignettes/customise.Rmd @@ -281,14 +281,15 @@ navbar: Components uses the same syntax as [RMarkdown menus](https://bookdown.org/yihui/rmarkdown/rmarkdown-site.html#site-navigation). The elements of `menu` can be: -- A link (`text` + `href`) +- Linked text (`text`, `href`, and an optional `target`). -- A heading (just `text`) +- A linked icon (`icon`, `aria-label`, `href`, and an optional `target`). + You can find a list of available icons at [fontawesome](https://fontawesome.com/icons?d=gallery). Provide a text description of the icon in the `aria-label` field + for screenreader users. -- A separator (`text: ——–`) +- A heading (just `text`). -Instead of text, you can also use the name of an `icon`s from [fontawesome](https://fontawesome.com/icons?d=gallery). -You should also provide a textual description in the `aria-label` field for screenreader users. +- A separator (`text: ——–`). To add a new component to the navbar, you need to modify both `structure` and `components`. For example, the following yaml adds a new "twitter" component that appears to the left of the github icon. From 6e3c037c929b8dd132bb477de65152358ce3357a Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 15 May 2024 08:34:46 -0500 Subject: [PATCH 04/11] Refactoring --- R/navbar-menu.R | 39 +++++++++++++++---------------- tests/testthat/test-navbar-menu.R | 4 ++-- 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/R/navbar-menu.R b/R/navbar-menu.R index ad10ec19c..b2cce7418 100644 --- a/R/navbar-menu.R +++ b/R/navbar-menu.R @@ -22,11 +22,12 @@ menu_icon <- function(icon, href, label) { } menu_type <- function(x) { - if (is.null(x)) { - "NULL" + if (!is.list(x) || !is_named(x)) { + not <- obj_type_friendly(x) + cli::cli_abort("Navbar components must be named lists, not {not}.") } else if (!is.null(x$menu)) { # https://github.com/twbs/bootstrap/pull/6342 - cli::cli_abort("Nested menus are not supported in BS5.") + cli::cli_abort("Nested menus are not supported.") } else if (!is.null(x$children)) { "menu" } else if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) { @@ -46,48 +47,46 @@ menu_type <- function(x) { # Menu renderers -------------------------------------------------------------- -navbar_html <- function(x, path_depth = 0L, depth = 0L, side = c("left", "right")) { - side <- arg_match(side) - type <- menu_type(x) - - if (type == "NULL") { +navbar_html <- function(x, path_depth = 0L, menu_depth = 0L, side = c("left", "right")) { + if (is.null(x)) { return("") - } else if (type == "list") { - return(navbar_html_list(x, depth = depth, path_depth = path_depth, side = side)) } + side <- arg_match(side) + type <- menu_type(x) + text <- switch(type, - menu = navbar_html_menu(x, depth = depth, path_depth = path_depth, side = side), + menu = navbar_html_menu(x, menu_depth = menu_depth, path_depth = path_depth, side = side), heading = navbar_html_heading(x), - link = navbar_html_link(x, depth = depth), + link = navbar_html_link(x, menu_depth = menu_depth), separator = navbar_html_separator(), search = navbar_html_search(x, path_depth = path_depth) ) class <- c( - if (depth == 0L) "nav-item", + if (menu_depth == 0L) "nav-item", if (type == "menu") "dropdown" ) html_tag("li", class = class, text) } -navbar_html_list <- function(x, path_depth = 0L, depth = 0L, side = "left") { +navbar_html_list <- function(x, path_depth = 0L, menu_depth = 0L, side = "left") { tags <- purrr::map_chr( x, navbar_html, path_depth = path_depth, - depth = depth, + menu_depth = menu_depth, side = side ) paste0(tags, collapse = "\n") } -navbar_html_menu <- function(x, path_depth = 0L, depth = 0L, side = "left") { +navbar_html_menu <- function(x, path_depth = 0L, menu_depth = 0L, side = "left") { id <- paste0("dropdown-", make_slug(x$text)) button <- html_tag("button", type = "button", - class = c(if (depth == 0L) "nav-link", "dropdown-toggle"), + class = c(if (menu_depth == 0L) "nav-link", "dropdown-toggle"), id = id, `data-bs-toggle` = "dropdown", "aria-expanded" = "false", @@ -99,7 +98,7 @@ navbar_html_menu <- function(x, path_depth = 0L, depth = 0L, side = "left") { li <- navbar_html_list( x$children, path_depth = path_depth, - depth = depth + 1, + menu_depth = menu_depth + 1, side = side ) ul <- html_tag( @@ -112,10 +111,10 @@ navbar_html_menu <- function(x, path_depth = 0L, depth = 0L, side = "left") { paste0("\n", indent(paste0(button, "\n", ul), " "), "\n") } -navbar_html_link <- function(x, depth = 0) { +navbar_html_link <- function(x, menu_depth = 0) { html_tag( "a", - class = if (depth == 0) "nav-link" else "dropdown-item", + class = if (menu_depth == 0) "nav-link" else "dropdown-item", href = x$href, target = x$target, "aria-label" = x$`aria-label`, diff --git a/tests/testthat/test-navbar-menu.R b/tests/testthat/test-navbar-menu.R index bf3963bde..e4792e868 100644 --- a/tests/testthat/test-navbar-menu.R +++ b/tests/testthat/test-navbar-menu.R @@ -20,12 +20,12 @@ test_that("can construct bullets", { test_that("bullet class varies based on depth", { expect_equal( - navbar_html(menu_separator(), depth = 0), + navbar_html(menu_separator(), menu_depth = 0), '
    • ' ) expect_equal( - navbar_html(menu_separator(), depth = 1), + navbar_html(menu_separator(), menu_depth = 1), '
    • ' ) }) From e08472fb9895df8f8e23769a217fb0c1d5068695 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 15 May 2024 08:38:49 -0500 Subject: [PATCH 05/11] Use html_tag in navbar_html_search() --- R/navbar-menu.R | 34 ++++++++++++++++------------ tests/testthat/_snaps/navbar-menu.md | 2 +- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/R/navbar-menu.R b/R/navbar-menu.R index b2cce7418..e6a6f298a 100644 --- a/R/navbar-menu.R +++ b/R/navbar-menu.R @@ -136,20 +136,19 @@ navbar_html_separator <- function() { } navbar_html_search <- function(x, path_depth = 0) { - paste0( - '' + input <- html_tag( + "input", + type = "search", + class = "form-control", + name = "search-input", + id = "search-input", + autocomplete = "off", + "aria-label" = tr_("Search site"), + placeholder = tr_("Search for"), + "data-search-index" = paste0(up_path(path_depth), "search.json") ) + + html_tag("form", class = "form-inline", role = "search", "\n", input, "\n") } # Reused HTML components ----------------------------------------------------- @@ -173,10 +172,15 @@ html_tag <- function(tag, ..., class = NULL) { } else { html_attr <- "" } - + html_child <- paste0(purrr::compact(dots_child), collapse = " ") + needs_close <- !tag %in% "input" - paste0("<", tag, html_attr, ">", html_child, "") + paste0( + "<", tag, html_attr, ">", + html_child, + if (needs_close) paste0("") + ) } navbar_html_text <- function(x) { diff --git a/tests/testthat/_snaps/navbar-menu.md b/tests/testthat/_snaps/navbar-menu.md index 64c1b8ef6..155861b4a 100644 --- a/tests/testthat/_snaps/navbar-menu.md +++ b/tests/testthat/_snaps/navbar-menu.md @@ -45,6 +45,6 @@ cat(navbar_html(menu_search())) Output
    • From 5d7f0f41a7e1419ca28f43e9af371c4223f7a43f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 15 May 2024 08:45:19 -0500 Subject: [PATCH 06/11] Fix submenu definition --- R/navbar-menu.R | 25 ++++++++++++++----------- pkgdown/_pkgdown.yml | 1 + tests/testthat/_snaps/navbar-menu.md | 8 ++++++++ tests/testthat/test-navbar-menu.R | 10 ++++++++++ 4 files changed, 33 insertions(+), 11 deletions(-) diff --git a/R/navbar-menu.R b/R/navbar-menu.R index e6a6f298a..d152426a7 100644 --- a/R/navbar-menu.R +++ b/R/navbar-menu.R @@ -1,11 +1,11 @@ # Menu constructors ----------------------------------------------------------- # Helpers for use within pkgdown itself -menu_submenu <- function(text, children) { - if (length(children) == 0) { +menu_submenu <- function(text, menu) { + if (length(menu) == 0) { return() } else { - list(text = text, children = children) + list(text = text, menu = menu) } } menu_link <- function(text, href, target = NULL) { @@ -21,14 +21,17 @@ menu_icon <- function(icon, href, label) { list(icon = icon, href = href, "aria-label" = label) } -menu_type <- function(x) { +menu_type <- function(x, menu_depth = 0L) { if (!is.list(x) || !is_named(x)) { not <- obj_type_friendly(x) cli::cli_abort("Navbar components must be named lists, not {not}.") } else if (!is.null(x$menu)) { - # https://github.com/twbs/bootstrap/pull/6342 - cli::cli_abort("Nested menus are not supported.") - } else if (!is.null(x$children)) { +# https://github.com/twbs/bootstrap/pull/6342 + + if (menu_depth > 0) { + cli::cli_abort("Nested menus are not supported.") + } + "menu" } else if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) { "separator" @@ -53,7 +56,7 @@ navbar_html <- function(x, path_depth = 0L, menu_depth = 0L, side = c("left", "r } side <- arg_match(side) - type <- menu_type(x) + type <- menu_type(x, menu_depth = menu_depth) text <- switch(type, menu = navbar_html_menu(x, menu_depth = menu_depth, path_depth = path_depth, side = side), @@ -71,13 +74,13 @@ navbar_html <- function(x, path_depth = 0L, menu_depth = 0L, side = c("left", "r } navbar_html_list <- function(x, path_depth = 0L, menu_depth = 0L, side = "left") { - tags <- purrr::map_chr( + tags <- unwrap_purrr_error(purrr::map_chr( x, navbar_html, path_depth = path_depth, menu_depth = menu_depth, side = side - ) + )) paste0(tags, collapse = "\n") } @@ -96,7 +99,7 @@ navbar_html_menu <- function(x, path_depth = 0L, menu_depth = 0L, side = "left") ) li <- navbar_html_list( - x$children, + x$menu, path_depth = path_depth, menu_depth = menu_depth + 1, side = side diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 02f50ee56..b9eb19fb7 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -66,6 +66,7 @@ navbar: - text: "Category B" - text: Article B1 href: articles/b1.html + icon: fab-github reference: - title: Build diff --git a/tests/testthat/_snaps/navbar-menu.md b/tests/testthat/_snaps/navbar-menu.md index 155861b4a..4e0021530 100644 --- a/tests/testthat/_snaps/navbar-menu.md +++ b/tests/testthat/_snaps/navbar-menu.md @@ -12,6 +12,14 @@ +# submenus give clear error + + Code + navbar_html(menu) + Condition + Error in `menu_type()`: + ! Nested menus are not supported. + # can construct bullets Code diff --git a/tests/testthat/test-navbar-menu.R b/tests/testthat/test-navbar-menu.R index e4792e868..5290a3133 100644 --- a/tests/testthat/test-navbar-menu.R +++ b/tests/testthat/test-navbar-menu.R @@ -10,6 +10,16 @@ test_that("can construct menu with children", { expect_snapshot(cat(navbar_html(menu))) }) +test_that("submenus give clear error", { + menu <- menu_submenu( + "Title", + list( + menu_submenu("Heading", list(menu_heading("Hi"))) + ) + ) + expect_snapshot(navbar_html(menu), error = TRUE) +}) + test_that("can construct bullets", { expect_snapshot({ cat(navbar_html(menu_icon("fa-question", "https://example.com", "label"))) From 1ed881e23af9bb346cc94e2bbaff418ad6bad5b5 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 15 May 2024 08:49:52 -0500 Subject: [PATCH 07/11] Fix tests --- tests/testthat/_snaps/navbar.md | 36 +++++++++++++++++++++++++++------ tests/testthat/test-navbar.R | 9 +-------- 2 files changed, 31 insertions(+), 14 deletions(-) diff --git a/tests/testthat/_snaps/navbar.md b/tests/testthat/_snaps/navbar.md index c60217d77..45feb8853 100644 --- a/tests/testthat/_snaps/navbar.md +++ b/tests/testthat/_snaps/navbar.md @@ -52,7 +52,7 @@ Output articles: text: Articles - children: + menu: - text: Title a href: a.html - text: Title b @@ -77,7 +77,7 @@ Output articles: text: Articles - children: + menu: - text: Title a href: a.html - text: Title b @@ -92,7 +92,7 @@ Output articles: text: Articles - children: + menu: - text: '---------' - text: Label - text: Title a @@ -109,7 +109,7 @@ Output articles: text: Articles - children: + menu: - text: Title a href: a.html - text: '---------' @@ -138,7 +138,7 @@ data_navbar(pkg)[c("left", "right")] Output $left - [1] "
    • \n
  • \n\n
    • " + [1] "
    • \n
  • \n \n
    • " $right [1] "
  • Changelog
    • " @@ -189,7 +189,31 @@
  • Reference
    • -
  • Articles
    • +
  • + + +
  • News
    • diff --git a/tests/testthat/test-navbar.R b/tests/testthat/test-navbar.R index 7a9d2842f..cae05791d 100644 --- a/tests/testthat/test-navbar.R +++ b/tests/testthat/test-navbar.R @@ -184,14 +184,7 @@ test_that("render_navbar_links BS3 & BS4 default", { test_that("dropdowns on right are right-aligned", { x <- list( - articles = list( - text = "Articles", - children = list( - list(text = "A"), - list(text = "B"), - list(text = "C") - ) - ) + articles = menu_submenu("Articles", list(menu_heading("A"), menu_heading("B"))) ) pkg <- list(bs_version = 5) From 94c1c6ecf0be11748d33a60745af752de6f9dce8 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 15 May 2024 08:52:25 -0500 Subject: [PATCH 08/11] Revert site pkgdown yaml --- pkgdown/_pkgdown.yml | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index b9eb19fb7..7d3366acc 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -50,24 +50,6 @@ articles: contents: - starts_with("test") -navbar: - structure: - right: [search, github, special] - components: - special: - text: Articles - menu: - - text: Category A - - text: Title A1 - href: articles/a1.html - - text: Title A2 - href: articles/a2.html - - text: ------- - - text: "Category B" - - text: Article B1 - href: articles/b1.html - icon: fab-github - reference: - title: Build desc: Build a complete site or one of its components. From 05ed4ed779d4f7980cc43aff7159048b74d08a6f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 16 May 2024 10:58:07 -0400 Subject: [PATCH 09/11] Use have_name --- R/navbar-menu.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/navbar-menu.R b/R/navbar-menu.R index d152426a7..ee9711d9f 100644 --- a/R/navbar-menu.R +++ b/R/navbar-menu.R @@ -158,8 +158,8 @@ navbar_html_search <- function(x, path_depth = 0) { html_tag <- function(tag, ..., class = NULL) { dots <- list2(...) - dots_attr <- dots[names2(dots) != ""] - dots_child <- dots[names2(dots) == ""] + dots_attr <- dots[have_name(dots)] + dots_child <- dots[!have_name(dots)] if (!is.null(class)) { class <- paste0(class, collapse = " ") From ccee3e4a6e7c6f45595ea68322bc20dbb58f7416 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 16 May 2024 11:01:10 -0400 Subject: [PATCH 10/11] Test other errors --- tests/testthat/_snaps/navbar-menu.md | 14 ++++++++++++-- tests/testthat/test-navbar-menu.R | 10 +++++++--- 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/tests/testthat/_snaps/navbar-menu.md b/tests/testthat/_snaps/navbar-menu.md index 4e0021530..9a01cbfc5 100644 --- a/tests/testthat/_snaps/navbar-menu.md +++ b/tests/testthat/_snaps/navbar-menu.md @@ -12,10 +12,20 @@ -# submenus give clear error +# bad inputs give clear error Code - navbar_html(menu) + navbar_html(1) + Condition + Error in `menu_type()`: + ! Navbar components must be named lists, not the number 1. + Code + navbar_html(list(foo = 1)) + Condition + Error in `menu_type()`: + ! Unknown navbar component with names foo. + Code + navbar_html(submenu) Condition Error in `menu_type()`: ! Nested menus are not supported. diff --git a/tests/testthat/test-navbar-menu.R b/tests/testthat/test-navbar-menu.R index 5290a3133..bfeb4a635 100644 --- a/tests/testthat/test-navbar-menu.R +++ b/tests/testthat/test-navbar-menu.R @@ -10,14 +10,18 @@ test_that("can construct menu with children", { expect_snapshot(cat(navbar_html(menu))) }) -test_that("submenus give clear error", { - menu <- menu_submenu( +test_that("bad inputs give clear error", { + submenu <- menu_submenu( "Title", list( menu_submenu("Heading", list(menu_heading("Hi"))) ) ) - expect_snapshot(navbar_html(menu), error = TRUE) + expect_snapshot(error = TRUE, { + navbar_html(1) + navbar_html(list(foo = 1)) + navbar_html(submenu) + }) }) test_that("can construct bullets", { From d36a67b3768bfb8609a3e0eb92133e283fc935b4 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 16 May 2024 11:02:44 -0400 Subject: [PATCH 11/11] Clarifying comment --- R/navbar-menu.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/navbar-menu.R b/R/navbar-menu.R index ee9711d9f..7f500d0cc 100644 --- a/R/navbar-menu.R +++ b/R/navbar-menu.R @@ -1,6 +1,7 @@ # Menu constructors ----------------------------------------------------------- -# Helpers for use within pkgdown itself +# Helpers for use within pkgdown itself - these must stay the same as the +# yaml structure defined in vignette("customise") menu_submenu <- function(text, menu) { if (length(menu) == 0) { return()