Add BS4 templates and assets (with help from @jayhesselberth).

Co-authored-by: Hadley Wickham <h.wickham@gmail.com>

DESCRIPTION

@@ -27,12 +27,14 @@ BugReports: https://github.com/r-lib/pkgdown/issues
 Depends: 
     R (>= 3.1.0)
 Imports: 
+    bslib,
     callr (>= 2.0.2),
     crayon,
     desc,
     digest,
     downlit,
     fs (>= 1.3.0),
+    htmltools,
     httr (>= 1.4.2),
     magrittr,
     memoise,

NAMESPACE

@@ -132,6 +132,8 @@ export(template_navbar)
 export(template_reference)
 import(fs)
 import(rlang)
+importFrom(htmltools,tagList)
+importFrom(htmltools,tags)
 importFrom(magrittr,"%>%")
 importFrom(memoise,memoise)
 importFrom(utils,installed.packages)

NEWS.md

@@ -1,5 +1,11 @@
 # pkgdown (development version)
 
+* pkgdown now contains templates using Bootstrap 4 (with help from @jayhesselberth).
+   * Easy customisation of colours and fonts with bslib
+   * Thoughtful typography to make the contents as easy as possible to read, regardless of the size of your device.
+   * R syntax highlighting and autolinking by downlit is now paired with an [accessible colour scheme designed by Alison Hill](https://apreshill.github.io/rmda11y/arrow.html).
+   (#1536)
+
 * `build_articles()` again sets the `theme` argument of the document format 
   to `NULL` when `as_is: true` but lets users override this via the `theme`
   argument of the output format.

R/build-articles.R

@@ -267,7 +267,7 @@ build_article <- function(name,
       template <- rmarkdown_template(pkg, "article", depth = depth, data = data)
       output <- purrr::pluck(front, "output")
       # no option for the output
-      if (is(output, "character")) {
+      if (is.character(output)) {
         output_name <- output
         theme <- NULL
       } else {

R/build-home-index.R

@@ -25,7 +25,8 @@ build_home_index <- function(pkg = ".", quiet = TRUE) {
     dst_path,
     tweak_homepage_html,
     strip_header = strip_header,
-    sidebar = !isFALSE(pkg$meta$home$sidebar)
+    sidebar = !isFALSE(pkg$meta$home$sidebar),
+    bs_version = pkg$bs_version
   )
 
   invisible()

R/build-news.R

@@ -169,7 +169,12 @@ data_news <- function(pkg = ".") {
   }
 
   html <- sections %>%
-    purrr::walk2(versions, tweak_news_heading, timeline = timeline) %>%
+    purrr::walk2(
+      versions,
+      tweak_news_heading,
+      timeline = timeline,
+      bs_version = pkg$bs_version
+    ) %>%
     purrr::map_chr(as.character) %>%
     purrr::map_chr(repo_auto_link, pkg = pkg)
 
@@ -256,28 +261,43 @@ pkg_timeline <- function(package) {
   )
 }
 
-tweak_news_heading <- function(x, versions, timeline) {
+tweak_news_heading <- function(x, versions, timeline, bs_version) {
+
+  class <- if (bs_version == 3) "page-header" else "pb-2 mt-4 mb-2 border-bottom"
+
   x %>%
     xml2::xml_find_all(".//h1") %>%
-    xml2::xml_set_attr("class", "page-header")
+    xml2::xml_set_attr("class", class)
 
   x %>%
     xml2::xml_find_all(".//h1") %>%
     xml2::xml_set_attr("data-toc-text", versions)
 
-  if (is.null(timeline))
+  if (is.null(timeline)) {
     return(x)
+  }
 
   date <- timeline$date[match(versions, timeline$version)]
   date_str <- ifelse(is.na(date), "Unreleased", as.character(date))
 
-  date_nodes <- paste(" <small>", date_str, "</small>", collapse = "") %>%
-    xml2::read_html() %>%
-    xml2::xml_find_all(".//small")
+  if (bs_version == 3) {
+    date_nodes <- paste(" <small>", date_str, "</small>", collapse = "") %>%
+      xml2::read_html() %>%
+      xml2::xml_find_all(".//small")
 
-  x %>%
-    xml2::xml_find_all(".//h1") %>%
-    xml2::xml_add_child(date_nodes, .where = 1)
+    x %>%
+      xml2::xml_find_all(".//h1") %>%
+      xml2::xml_add_child(date_nodes, .where = 1)
+  } else {
+    cran_release_string <-  sprintf("<h6 class='text-muted' data-toc-skip> CRAN release: %s</h6>", date_str)
+    date_nodes <- cran_release_string %>%
+      xml2::read_html() %>%
+      xml2::xml_find_all(".//h6")
+
+    x %>%
+      xml2::xml_find_all(".//h1") %>%
+      xml2::xml_add_sibling(date_nodes, .where = "after")
+  }
 
   invisible()
 }

R/build-search-docs.R

@@ -16,7 +16,7 @@ build_docsearch_json <- function(pkg = ".") {
     "config",
     "docsearch",
     ext = ".json",
-    bs_version = get_bs_version(pkg)
+    bs_version = pkg$bs_version
   )
 
   json <- render_template(template, data)

R/html-tweak.R

@@ -159,7 +159,10 @@ tweak_rmarkdown_html <- function(html, input_path, pkg = pkg) {
   invisible()
 }
 
-tweak_homepage_html <- function(html, strip_header = FALSE, sidebar = TRUE) {
+tweak_homepage_html <- function(html,
+                                strip_header = FALSE,
+                                sidebar = TRUE,
+                                bs_version = 3) {
 
   html <- tweak_sidebar_html(html, sidebar = sidebar)
 
@@ -172,7 +175,7 @@ tweak_homepage_html <- function(html, strip_header = FALSE, sidebar = TRUE) {
   if (strip_header) {
     xml2::xml_remove(header, free = TRUE)
   } else {
-    page_header_text <- paste0("<div class='page-header'>", header, "</div>")
+    page_header_text <- class_page_header(bs_version = bs_version, header = header)
     page_header <- xml2::read_html(page_header_text) %>% xml2::xml_find_first("//div")
     xml2::xml_replace(header, page_header)
   }
@@ -189,6 +192,14 @@ tweak_homepage_html <- function(html, strip_header = FALSE, sidebar = TRUE) {
   invisible()
 }
 
+class_page_header <- function(bs_version, header) {
+  if (bs_version == 3) {
+    return(paste0("<div class='page-header'>", header, "</div>"))
+  }
+  sprintf("<div class='pb-2 mt-4 mb-2 border-bottom'>%s</div>", header)
+
+}
+
 tweak_sidebar_html <- function(html, sidebar) {
   if (!sidebar) {
     return(html)

R/init.R

@@ -59,7 +59,7 @@ copy_assets <- function(pkg = ".") {
 
   # Copy default assets
   if (!identical(template$default_assets, FALSE)) {
-    copy_asset_dir(pkg, path_pkgdown("assets"))
+    copy_asset_dir(pkg, path_pkgdown("assets", paste0("BS", pkg$bs_version)))
   }
 
   # Copy extras
@@ -74,8 +74,12 @@ copy_assets <- function(pkg = ".") {
   if (!is.null(template$package)) {
     copy_asset_dir(
       pkg,
-      path_package_pkgdown(template$package, bs_version = NULL, "assets")
+      path_package_pkgdown(
+        template$package,
+        bs_version = pkg$bs_version,
+        "assets"
       )
+    )
   }
 }
 

R/navbar.R

@@ -18,14 +18,25 @@ data_navbar <- function(pkg = ".", depth = 0L) {
   left <- navbar$left %||% components[left_comp]
   right <- navbar$right %||% components[right_comp]
 
+  if (pkg$bs_version == 3) {
+    return(
+      list(
+        type = navbar$type %||% "default",
+        left = render_navbar_links(left, depth = depth, bs_version = pkg$bs_version),
+        right = render_navbar_links(right, depth = depth, bs_version = pkg$bs_version)
+      )
+    )
+  }
+
   list(
-    type = navbar$type %||% "default",
-    left = render_navbar_links(left, depth = depth),
-    right = render_navbar_links(right, depth = depth)
+    type = navbar$type %||% "light",
+    bg = navbar$bg %||% "light",
+    left = render_navbar_links(left, depth = depth, pkg$bs_version),
+    right = render_navbar_links(right, depth = depth, pkg$bs_version)
   )
 }
 
-render_navbar_links <- function(x, depth = 0L) {
+render_navbar_links <- function(x, depth = 0L, bs_version) {
   stopifnot(is.integer(depth), depth >= 0L)
 
   tweak <- function(x) {
@@ -43,7 +54,13 @@ render_navbar_links <- function(x, depth = 0L) {
   if (depth != 0L) {
     x <- lapply(x, tweak)
   }
-  rmarkdown::navbar_links_html(x)
+
+  if (bs_version == 3) {
+    return(rmarkdown::navbar_links_html(x))
+  }
+
+  bs4_navbar_links_html(x)
+
 }
 
 # Default navbar ----------------------------------------------------------
@@ -146,7 +163,7 @@ menu_text <- function(text) {
   list(text = text)
 }
 menu_spacer <- function() {
-   menu_text("---------")
+  menu_text("---------")
 }
 
 
@@ -167,12 +184,105 @@ pkg_navbar <- function(meta = NULL, vignettes = pkg_navbar_vignettes(),
   )
 }
 
-pkg_navbar_vignettes <- function(
-                                 name = character(),
+pkg_navbar_vignettes <- function(name = character(),
                                  title = NULL,
                                  file_out = NULL) {
   title <- title %||% paste0("Title ", name)
   file_out <- file_out %||% paste0(name, ".html")
 
   tibble::tibble(name = name, title = title, file_out)
 }
+
+bs4_navbar_links_html <- function(links) {
+  as.character(bs4_navbar_links_tags(links))
+}
+
+#' @importFrom htmltools tags tagList
+bs4_navbar_links_tags <- function(links, depth = 0L) {
+
+  if (is.null(links)) {
+    return(tagList())
+  }
+
+  # sub-menu
+  is_submenu <- (depth > 0L)
+
+  # function for links
+  tackle_link <- function(x, is_submenu, 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)
+
+      return(
+        tags$li(
+          class = menu_class,
+          tags$a(
+            href = "#", class = "nav-link dropdown-toggle",
+            `data-toggle` = "dropdown", role = "button",
+            `aria-expanded` = "false", `aria-haspopup` = "true",
+            link_text
+          ),
+          tags$div(
+            class = "dropdown-menu",
+            `aria-labelledby` ="navbarDropdown",
+            submenuLinks
+          )
+        )
+      )
+
+    }
+
+    if (!is.null(x$text) && grepl("^\\s*-{3,}\\s*$", x$text)) {
+      # divider
+      return(tags$div(class = "dropdown-divider"))
+    }
+
+    if (!is.null(x$text) && is.null(x$href)) {
+      # header
+      return(tags$h6(class = "dropdown-header", `data-toc-skip` = NA, x$text))
+    }
+
+    # standard menu item
+    textTags <- bs4_navbar_link_text(x)
+
+    if (is_submenu) {
+      return(tags$a(class = "dropdown-item", href = x$href, textTags))
+    }
+
+    tags$li(
+      class = "nav-item",
+      tags$a(class = "nav-link", href = x$href, textTags)
+    )
+
+  }
+
+  tags <- lapply(links, tackle_link, is_submenu = is_submenu, depth = depth)
+  tagList(tags)
+
+}
+
+bs4_navbar_link_text <- function(x, ...) {
+
+  if (!is.null(x$icon)) {
+    # find the iconset
+    split <- strsplit(x$icon, "-")
+    if (length(split[[1]]) > 1) {
+      iconset <- split[[1]][[1]]
+    }
+    else {
+      iconset <- ""
+    }
+    tagList(tags$span(class = paste(iconset, x$icon)), " ", x$text, ...)
+  }
+  else
+    tagList(x$text, ...)
+}

R/package.r

@@ -44,8 +44,7 @@ as_pkgdown <- function(pkg = ".", override = list()) {
 
   install_metadata <- meta$deploy$install_metadata %||% FALSE
 
-  structure(
-    list(
+  pkg_list <- list(
       package = package,
       version = version,
 
@@ -62,7 +61,12 @@ as_pkgdown <- function(pkg = ".", override = list()) {
       topics = package_topics(pkg, package),
       tutorials = package_tutorials(pkg, meta),
       vignettes = package_vignettes(pkg)
-    ),
+    )
+
+  pkg_list$bs_version <- get_bs_version(pkg_list)
+
+  structure(
+    pkg_list,
     class = "pkgdown"
   )
 }