Greater flexibility in repo specification (#1036)

maelle · cderv · web-flow · commit dfa56b5a9e4e · 2021-06-24T15:59:35.000+02:00
This adds support in `bs4_book()` for customizing base url, branch, subdir and icon all of which allow tweaking the look of the source edit button in the book

Co-authored-by: Christophe Dervieux &lt;christophe.dervieux@gmail.com&gt;
Co-authored-by: Christophe Dervieux &lt;cderv@rstudio.com&gt;
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: bookdown
 Type: Package
 Title: Authoring Books and Technical Documents with R Markdown
-Version: 0.22.4
+Version: 0.22.5
 Authors@R: c(
     person("Yihui", "Xie", role = c("aut", "cre"), email = "xie@yihui.name", comment = c(ORCID = "0000-0003-0645-5666")),
     person("JJ", "Allaire", role = "ctb"),
@@ -81,10 +81,13 @@ Suggests:
     testit (>= 0.9),
     tufte,
     xml2,
-    webshot
+    webshot,
+    testthat (>= 3.0.0),
+    withr (>= 2.3.0)
 URL: https://github.com/rstudio/bookdown, https://pkgs.rstudio.com/bookdown/
 BugReports: https://github.com/rstudio/bookdown/issues
 SystemRequirements: Pandoc (>= 1.17.2)
 RoxygenNote: 7.1.1
 Encoding: UTF-8
+Config/testthat/edition: 3
 VignetteBuilder: knitr
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,7 @@
 # CHANGES IN bookdown VERSION 0.23
 
+- `repo` specification in `bs4_book()` can now be done in a more flexible way: base url, branch name, subdir and icon can be specify. See `?bookdown::bs4_book()` for details (thanks, @maelle, #1036).
+
 - The `bookdown::gitbook` output format now supports an alternative search engine, namely `fuse.js`, which has several advantages over `lunr.js`, the previous search engine for `gitbook`. Using `fuse.js` will fix a number of long-standing issues such as #734, #735, and #792. To enable `fuse.js`, set the search engine to be `fuse` in `gitbook`'s config in YAML, e.g.,
 
   ```yaml
diff --git a/R/bs4_book.R b/R/bs4_book.R
@@ -35,22 +35,55 @@
 #'   The default, `bs4_book_theme()`, resets the base font size to 1rem to
 #'   make reading easier and uses a primary colour with greater constrast
 #'   against the background.
-#' @param repo Link to repository where book is hosted, used to generate
-#'   view source and edit buttons. Currently assumes GitHub and that the book
-#'   is in the root directory of the repo.
+#' @param repo Either link to repository where book is hosted, used to generate
+#'   view source and edit buttons or a list with repository `base` link, default
+#'   `branch`, `subdir` and `icon` (see "Specifying the repository").
 #' @param lib_dir,pandoc_args,extra_dependencies,... Passed on to
 #'   [rmarkdown::html_document()].
+#'
+#' @section Specifying the repository:
+#'
+#' If your book has a default branch called main you can use
+#'
+#' ```yaml
+#' bookdown::bs4_book:
+#'   repo:
+#'     base: https://github.com/hadley/ggplot2-book
+#'     branch: main
+#' ```
+#'
+#' If your book is furthermore located in a subdirectory called "book" you can use
+#'
+#' ```yaml
+#' bookdown::bs4_book:
+#'   repo:
+#'     base: https://github.com/hadley/ggplot2-book
+#'     branch: main
+#'     subdir: book
+#' ```
+#'
+#' By default if the repo URL contains "github" it will get a GitHub font-awesome
+#' icon, and otherwise a GitLab font-awesome icon.
+#' To use another icon, specify it with the correct prefix (`fas`, `fab`, ...) (Font Awesome 5).
+#'
+#' ```yaml
+#' bookdown::bs4_book:
+#'   repo:
+#'     base: https://github.com/hadley/ggplot2-book
+#'     branch: main
+#'     subdir: book
+#'     icon: "fas fa-air-freshener"
+#' ```
+#'
 #' @export
 #' @md
-bs4_book <- function(
-                     theme = bs4_book_theme(),
+bs4_book <- function(theme = bs4_book_theme(),
                      repo = NULL,
                      ...,
                      lib_dir = "libs",
                      pandoc_args = NULL,
-                     extra_dependencies = NULL
-                     ) {
-  check_packages(c("bslib", "downlit", "jsonlite", "xml2"))
+                     extra_dependencies = NULL) {
+  check_packages(bs4_book_deps())
   bs4_check_dots(...)
 
   # Allow theme specification in yaml metadata
@@ -102,8 +135,7 @@ bs4_book_theme <- function(primary = "#0068D9", ...) {
 bs4_book_build <- function(output = "bookdown.html",
                            repo = NULL,
                            lib_dir = "libs",
-                           output_dir = opts$get("output_dir")
-                           ) {
+                           output_dir = opts$get("output_dir")) {
   move_files_html(output, lib_dir)
 
   rmd_index <- new.env(parent = emptyenv())
@@ -121,7 +153,7 @@ bs4_book_build <- function(output = "bookdown.html",
     output_dir <- "_book"
   }
 
-  if (isTRUE(opts$get('preview'))) {
+  if (isTRUE(opts$get("preview"))) {
     bs4_chapter_tweak(
       output2,
       repo = repo,
@@ -179,8 +211,8 @@ build_toc <- function(output) {
   if (any(is_appendix)) {
     app <- toc[
       seq_along(is_appendix) > which(is_appendix)[[1]] &
-      toc$level == 1 &
-      !is.na(toc$num),
+        toc$level == 1 &
+        !is.na(toc$num),
     ]
     app$label <- LETTERS[seq_len(nrow(app))]
     # TODO: make less of a hack
@@ -202,17 +234,17 @@ build_toc <- function(output) {
   toc
 }
 
-bs4_book_page = function(head,
-                         toc,
-                         chapter,
-                         link_prev,
-                         link_next,
-                         rmd_cur,
-                         html_cur,
-                         foot,
-                         rmd_index = NULL) {
+bs4_book_page <- function(head,
+                          toc,
+                          chapter,
+                          link_prev,
+                          link_next,
+                          rmd_cur,
+                          html_cur,
+                          foot,
+                          rmd_index = NULL) {
   rmd_index[[html_cur]] <- rmd_cur
-  paste(c(head, toc, chapter, foot), collapse = '\n')
+  paste(c(head, toc, chapter, foot), collapse = "\n")
 }
 
 bs4_book_dependency <- function(theme) {
@@ -239,7 +271,6 @@ bs4_chapters_tweak <- function(output,
                                rmd_index = NULL,
                                repo = NULL,
                                output_dir = opts$get("output_dir")) {
-
   toc <- build_toc(output)
   files <- toc[!duplicated(toc$file_name) & !is.na(toc$file_name), ]
   files$path <- file.path(output_dir, files$file_name)
@@ -283,7 +314,6 @@ bs4_chapter_tweak <- function(path, toc, rmd_index = NULL, repo = NULL) {
     chapter = h1,
     path = basename(path)
   )
-
 }
 
 tweak_chapter <- function(html) {
@@ -390,17 +420,36 @@ tweak_tables <- function(html) {
 }
 
 tweak_navbar <- function(html, toc, active = "", rmd_index = NULL, repo = NULL) {
+  if (!is.null(repo) && length(repo) == 1) {
+    repo <- list(
+      base = repo,
+      branch = "master",
+      subdir = NULL
+    )
+  }
 
   # Source links ------------------------------------------------------------
   if (!is.null(repo) && active %in% names(rmd_index)) {
-    repo_edit <- paste0(repo, "/edit/master/", rmd_index[[active]])
-    repo_view <- paste0(repo, "/blob/master/", rmd_index[[active]])
+    if (!is.null(repo$subdir)) {
+      repo$subdir <- paste0(repo$subdir, "/")
+    }
+
+    repo_edit <- paste0(repo$base, "/edit/", repo$branch, "/", repo$subdir, rmd_index[[active]])
+    repo_view <- paste0(repo$base, "/blob/", repo$branch, "/", repo$subdir, rmd_index[[active]])
   } else {
     repo_edit <- NULL
     repo_view <- NULL
   }
 
-  template_link(html, ".//a[@id='book-repo']", repo)
+  if (!is.null(repo$base)) {
+    icon <- repo$icon %n%
+      ifelse(grepl("github\\.com", repo$base), "fab fa-github", "fab fa-gitlab")
+    template_link_icon(html, ".//a[@id='book-repo']", icon)
+    template_link_icon(html, ".//a[@id='book-source']", icon)
+    template_link_icon(html, ".//a[@id='book-edit']", icon)
+  }
+
+  template_link(html, ".//a[@id='book-repo']", repo$base)
   template_link(html, ".//a[@id='book-source']", repo_view)
   template_link(html, ".//a[@id='book-edit']", repo_edit)
 
@@ -516,10 +565,16 @@ template_link <- function(html, xpath, href) {
   }
 }
 
+template_link_icon <- function(html, xpath, icon) {
+  icon_node <- xml2::xml_child(xml2::xml_find_first(html, xpath))
+  xml2::xml_attr(icon_node, "class") <- icon
+}
+
 # index -------------------------------------------------------------------
 
 bs4_index_data <- function(node, chapter, path) {
-  children <- xml2::xml_find_all(node,
+  children <- xml2::xml_find_all(
+    node,
     "./*[not(self::div and contains(@class, 'section'))]"
   )
   if (length(children) == 0 || !is_heading(children[[1]])) {
@@ -616,3 +671,10 @@ bs4_check_dots <- function(...) {
     )
   }
 }
+
+# these dependencies are required to use bs4_book() but are suggested deps
+# of bookdown. Hence the need to check they are available
+# TODO: remove this and the check in bs4_book when we add them as Imports (if we do it)
+bs4_book_deps <- function() {
+  c("bslib", "downlit", "jsonlite", "xml2")
+}
diff --git a/R/skeleton.R b/R/skeleton.R
@@ -39,10 +39,11 @@ bookdown_skeleton = function(path) {
 #' @param chapters The chapter titles.
 #' @param documentclass The LaTeX document class.
 #' @param references The title of the references section.
+#' @param path The directory in which to create the book.
 #' @noRd
 book_skeleton = function(
   name, title, author, chapters = c('Preface {-}', 'Introduction'),
-  documentclass = 'book', references = 'References'
+  documentclass = 'book', references = 'References', path = getwd()
 ) {
   rmd_files = gsub('[^-a-zA-Z0-9]', '', gsub('\\s+', '-', c(chapters, references)))
   rmd_files = sprintf('%02d-%s.Rmd', seq_along(rmd_files) - 1, rmd_files)
@@ -55,20 +56,24 @@ book_skeleton = function(
   titles = paste('#', titles)
   for (i in seq_along(rmd_files)) {
     content = c(titles[i], '')
+    # special handling for file which will be index.Rmd
     if (i == 1) {
+      index_metadata = list(title = title, author = author,
+                            documentclass = documentclass,
+                            site = 'bookdown::bookdown_site')
       content = c(
-        '---', sprintf('title: "%s"', title), sprintf('author: "%s"', author),
-        sprintf('documentclass: "%s"', documentclass),
-        'site: bookdown::bookdown_site', '---', '', content,
+        '---', yaml::as.yaml(index_metadata), '---', '',
+        content,
         'Start writing your book here. If you are in RStudio,',
         'Click the Build button to build the book.'
       )
     }
-    write_file(content, rmd_files[i])
+    write_file(content, file.path(path, rmd_files[i]))
   }
   write_file(
-    sprintf('bookdown::%s: default', c('gitbook', 'pdf_book', 'epub_book')), '_output.yml'
+    sprintf('bookdown::%s: default', c('gitbook', 'pdf_book', 'epub_book', 'bs4_book')),
+    file.path(path, '_output.yml')
   )
-  write_file(sprintf('book_filename: %s', name), '_bookdown.yml')
+  write_file(sprintf('book_filename: %s', name), file.path(path, '_bookdown.yml'))
 }
 
diff --git a/man/bs4_book.Rd b/man/bs4_book.Rd
diff --git a/tests/testthat.R b/tests/testthat.R
@@ -0,0 +1,4 @@
+library(testthat)
+library(bookdown)
+
+test_check("bookdown")
diff --git a/tests/testthat/helper-bs4_book.R b/tests/testthat/helper-bs4_book.R
@@ -0,0 +1,36 @@
+# TODO: Replace if helper in testthat gets vectorised
+# https://github.com/r-lib/testthat/issues/1398
+skip_if_bs4_book_deps_missing <- function() {
+  check <- vapply(bs4_book_deps(), skip_if_not_installed, logical(1L), USE.NAMES = FALSE)
+  invisible(check)
+}
+
+local_bs4_book <- function(name = "book",
+                           title = "Awesome Cookbook",
+                           author = "Yoda",
+                           output_options = NULL,
+                           env = parent.frame()) {
+
+  # don't run test using this book skeleton when Pandoc is not available
+  skip_if_not_pandoc()
+
+  path <- withr::local_tempdir(.local_envir = env)
+
+  book_skeleton(
+    name = name,
+    title = title,
+    author = author,
+    path = path
+  )
+
+  suppressMessages(
+    render_book(
+      path,
+      output_format = "bookdown::bs4_book",
+      output_options = output_options,
+      quiet = TRUE
+    )
+  )
+
+  return(path)
+}
diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R
@@ -0,0 +1,25 @@
+# From rmarkdown helper.R
+
+# Use to test pandoc availability or version lower than
+skip_if_not_pandoc <- function(ver = NULL) {
+  if (!rmarkdown::pandoc_available(ver)) {
+    msg <- if (is.null(ver)) {
+      "Pandoc is not available"
+    } else {
+      sprintf("Version of Pandoc is lower than %s.", ver)
+    }
+    skip(msg)
+  }
+}
+
+# Use to test version greater than
+skip_if_pandoc <- function(ver = NULL) {
+  if (rmarkdown::pandoc_available(ver)) {
+    msg <- if (is.null(ver)) {
+      "Pandoc is available"
+    } else {
+      sprintf("Version of Pandoc is greater than %s.", ver)
+    }
+    skip(msg)
+  }
+}
diff --git a/tests/testthat/test-bs4_book.R b/tests/testthat/test-bs4_book.R
