merge

DESCRIPTION

@@ -8,6 +8,7 @@ Authors@R: c(
            comment = c(ORCID = "0000-0002-6299-179X")),
     person("Maëlle", "Salmon", role = "aut",
            comment = c(ORCID = "0000-0002-2815-0399")),
+    person("Olivier", "Roy", role = "aut"),
     person("Posit Software, PBC", role = c("cph", "fnd"))
   )
 Description: Generate an attractive and useful website from a source

NEWS.md

@@ -1,5 +1,10 @@
 # pkgdown (development version)
 
+* `build_reference()` does a better job of parsing `\value{}` blocks (#2371).
+* When built on GitHub, source urls now use the name of the current upstream branch (rather than `HEAD`), which is more likely to generate correct links (#2597).
+* New `vignette("non-english")` that discusses non-English sites including how to submit new translations (#2605).
+* `build_reference()` now generates the usage that users actually type for infix and replacement methods (#2303).
+* @olivroy is now a pkgdown author in recognition of his contributions. 
 * `pkgdown_sitrep()`/`check_pkgdown()` now check that you have up-to-date favicons if you have a package logo.
 * pkgdown now uses httr2 instead of httr (#2600).
 * New `template.math-rendering` allows you to control how math is rendered across your site. The default uses `mathml` which is low-dependency, but has the lowest fidelity. You can also use `mathjax`, the previous default, and `katex`, a faster alternative. (#1966).

R/rd-data.R

@@ -78,25 +78,46 @@ as_data.tag_value <- function(x, ...) {
 }
 
 describe_contents <- function(x, ..., id_prefix = NULL) {
-  # Drop pure whitespace nodes between items
-  is_ws <- purrr::map_lgl(x, is_whitespace)
-
-  # Group contiguous \items{}/whitespace into a <dl>
-  is_item <- purrr::map_lgl(x, inherits, "tag_item") | is_ws
-  changed <- is_item[-1] != is_item[-length(is_item)]
-  group <- cumsum(c(TRUE, changed))
-
-  parse_piece <- function(x) {
-    if (length(x) == 0) {
-      NULL
-    } else if (any(purrr::map_lgl(x, inherits, "tag_item"))) {
-      paste0("<dl>\n", parse_descriptions(x, ..., id_prefix = id_prefix), "</dl>")
+  if (length(x) == 0) {
+    return("")
+  }
+
+  # Group contiguous \items{}/whitespace into a <dl>; everything else
+  # is handled as is
+  block_id <- integer(length(x))
+  block_id[[1]] <- 1
+  cur_block_is_dl <- inherits(x[[1]], "tag_item")
+
+  for (i in seq2(2, length(x))) {
+    is_item <- inherits(x[[i]], "tag_item")
+    if (cur_block_is_dl) {
+      same_type <- is_item || is_whitespace(x[[i]])
+    } else {
+      same_type <- !is_item
+    }
+
+    if (same_type) {
+      block_id[[i]] <- block_id[[i - 1]]
+    } else {
+      block_id[[i]] <- block_id[[i - 1]] + 1
+      cur_block_is_dl <- !cur_block_is_dl
+    }
+  }
+
+  parse_block <- function(x) {
+    is_dl <- any(purrr::map_lgl(x, inherits, "tag_item"))
+    if (is_dl) {
+      paste0(
+        "<dl>\n",
+        parse_descriptions(x, ..., id_prefix = id_prefix),
+        "</dl>"
+      )
     } else {
       flatten_para(x, ...)
     }
   }
-  pieces <- split(x, group)
-  out <- purrr::map(pieces, parse_piece)
+  blocks <- split(x, block_id)
+  out <- purrr::map(blocks, parse_block)
 
   paste(unlist(out), collapse = "\n")
 }

R/repo.R

@@ -63,7 +63,7 @@ package_repo <- function(pkg) {
   # Use metadata if available
   repo <- config_pluck_list(pkg, "repo")
   url <- config_pluck_list(pkg, "repo.url")
-  branch <- config_pluck_string(pkg, "repo.branch", default = "HEAD")
+
 
   if (!is.null(url)) {
     return(repo)
@@ -77,6 +77,7 @@ package_repo <- function(pkg) {
 
   gh_links <- grep("^https?://git(hub|lab)\\..+/", urls, value = TRUE)
   if (length(gh_links) > 0) {
+    branch <- config_pluck_string(pkg, "repo.branch")
     return(repo_meta_gh_like(gh_links[[1]], branch))
   }
 
@@ -96,7 +97,8 @@ repo_meta <- function(home = NULL, source = NULL, issue = NULL, user = NULL) {
 
 repo_meta_gh_like <- function(link, branch = NULL) {
   gh <- parse_github_like_url(link)
-  branch <- branch %||% "HEAD"
+  branch <- branch %||% gha_current_branch()
+
   repo_meta(
     paste0(gh$host, "/", gh$owner, "/", gh$repo, "/"),
     paste0(gh$host, "/", gh$owner, "/", gh$repo, "/blob/", branch, "/"),
@@ -105,6 +107,22 @@ repo_meta_gh_like <- function(link, branch = NULL) {
   )
 }
 
+gha_current_branch <- function() {
+  # Only set in pull requests
+  ref <- Sys.getenv("GITHUB_HEAD_REF")
+  if (ref != "") {
+    return(ref)
+  }
+
+  # Set everywhere but might not be a branch
+  ref <- Sys.getenv("GITHUB_REF_NAME")
+  if (ref != "") {
+    return(ref)
+  }
+
+  "HEAD"
+}
+
 parse_github_like_url <- function(link) {
   supports_subgroups <- grepl("^https?://gitlab\\.", link)
   rx <- paste0(

R/usage.R

@@ -1,10 +1,27 @@
 # Reference page ---------------------------------------------------------------
 
+# For testing
+usage2text <- function(x) {
+  rd <- rd_text(paste0("\\usage{", x, "}"), FALSE)[[1]]
+  strip_html_tags(as_data(rd))
+}
+
 #' @export
 as_data.tag_usage <- function(x, ...) {
   text <- paste(flatten_text(x, ..., escape = FALSE), collapse = "\n")
   text <- str_trim(text)
 
+  # Look for single line calls to non-syntactic functions and then use
+  # deparse1 to convert to standard style. We want to avoid reparsing 
+  # any other lines to avoid losing whitespace, comments etc. (These
+  # are not generated by roxygen but can be added by the user.)
+  lines <- strsplit(text, "\n", fixed = TRUE)[[1]]
+  parsed <- lapply(lines, function(x) tryCatch(parse(text = x)[[1]], error = function(e) NULL))
+  needs_tweak <- vapply(parsed, function(x) is_call(x) && !is_syntactic(x[[1]]), logical(1))
+  lines[needs_tweak] <- vapply(parsed[needs_tweak], deparse1, character(1))
+
+  text <- paste(lines, collapse = "\n")
+
   highlight_text(text)
 }
 
@@ -16,15 +33,21 @@ as_html.tag_S3method <- function(x, ...) method_usage(x, "S3")
 as_html.tag_S4method <- function(x, ...) method_usage(x, "S4")
 
 method_usage <- function(x, type) {
-  fun <- as_html(x[[1]])
-  class <- as_html(x[[2]])
+  # Despite these being called from the as_html() generic, the target isn't
+  # actually HTML, but R code, which is turned into HTML by the syntax
+  # highlighting in as as_data.tag_usage()
+  fun <- as_html(x[[1]], escape = FALSE)
+  class <- as_html(x[[2]], escape = FALSE)
 
   if (x[[2]] == "default") {
     method <- sprintf(tr_("# Default %s method"), type)
   } else {
     method <- sprintf(tr_("# %s method for class '%s'"), type, class)
   }
 
+  if (!is_syntactic(fun)) {
+    fun <- paste0("`", fun, "`")
+  }
   paste0(method, "\n", fun)
 }
 

inst/BS5/assets/pkgdown.scss

@@ -438,9 +438,16 @@ pre, pre code {
   word-wrap: normal;
 }
 
-[data-bs-theme="dark"] pre {
-  background-color: RGBA(var(--bs-body-color-rgb), 0.1);
-  border-color: var(--bs-border-color);
+// Default dark mode styling does not look good for code
+[data-bs-theme="dark"] {
+  pre, code {
+    background-color: RGBA(var(--bs-body-color-rgb), 0.1); 
+  }
+  // don't double apply transparency
+  pre code {
+    background: transparent;
+  }
+
 }
 
 code {

pkgdown/_pkgdown.yml

@@ -12,8 +12,6 @@ authors:
     href: https://hadley.nz
   Posit Software, PBC:
     href: https://posit.co
-    html: >-
-      <img src='https://www.tidyverse.org/posit-logo.svg' alt='Posit' width='62' height='16' style="margin-bottom: 3px;" />
 
 template:
   bootstrap: 5
@@ -35,6 +33,7 @@ articles:
   navbar: ~
   contents:
   - customise
+  - translations
   - accessibility
   - linking
   - metadata

tests/testthat/_snaps/usage.md

@@ -1,15 +1,18 @@
-# usage escapes special characters
+# usage generates user facing code for S3/S4 infix/replacement methods
 
     Code
-      # Parseable
-      cat(strip_html_tags(usage2html("# <>\nx")))
+      cat(usage2text("\\S3method{$}{indexed_frame}(x, name)"))
     Output
-      # &lt;&gt;
-      x
+      # S3 method for class 'indexed_frame'
+      x$name
     Code
-      # Unparseable
-      cat(strip_html_tags(usage2html("# <>\n<")))
+      cat(usage2text("\\method{[[}{indexed_frame}(x, i) <- value"))
     Output
-      # &lt;&gt;
-      &lt;
+      # S3 method for class 'indexed_frame'
+      x[[i]] &lt;- value
+    Code
+      cat(usage2text("\\S4method{>=}{MyType,numeric}(e1, e2)"))
+    Output
+      # S4 method for class 'MyType,numeric'
+      e1 &gt;= e2
 

tests/testthat/test-rd-data.R

@@ -48,7 +48,6 @@ test_that("leading whitespace doesn't break items", {
     value2html("\n\\item{a}{b}\n\n\\item{c}{d}\n\n\\item{e}{f}"),
     c(
       "<dl>",
-        "",
         "<dt>a</dt>", "<dd><p>b</p></dd>", "", "",
         "<dt>c</dt>", "<dd><p>d</p></dd>", "", "",
         "<dt>e</dt>", "<dd><p>f</p></dd>",
@@ -57,14 +56,10 @@ test_that("leading whitespace doesn't break items", {
   )
 })
 
-test_that("whitespace between text is preserved", {
+test_that("whitespace between text is not preserved", {
   expect_equal(
     value2html("a\n\nb\n\nc"),
-    c(
-      "<p>a</p>", "", "",
-      "<p>b</p>", "", "",
-      "<p>c</p>"
-    )
+    c("<p>a</p>", "<p>b</p>", "<p>c</p>")
   )
 })
 
@@ -82,3 +77,15 @@ test_that("can have multiple interleaved blocks", {
     )
   )
 })
+
+test_that("other tags don't affect breaking (#2371)", {
+  expect_equal(
+    value2html("1\\code{xxx}\n2\n3"),
+    c("<p>1<code>xxx</code>", "2", "3</p>")
+  )
+  # additionally teading whitespace
+  expect_equal(
+    value2html("1\\code{xxx}\n  2\n  3"),
+    c("<p>1<code>xxx</code>", "2", "3</p>")
+  )
+})

tests/testthat/test-repo.R

@@ -47,6 +47,7 @@ test_that("Jira issues are automatically linked", {
 # repo_source -------------------------------------------------------------
 
 test_that("repo_source() truncates automatically", {
+  withr::local_envvar(GITHUB_HEAD_REF = "HEAD")
   pkg <- list(repo = repo_meta_gh_like("https://github.com/r-lib/pkgdown"))
 
   expect_snapshot({
@@ -81,6 +82,7 @@ test_that("repo_source() uses the branch setting in meta", {
 # package_repo ------------------------------------------------------------
 
 test_that("can find github from BugReports or URL", {
+  withr::local_envvar(GITHUB_HEAD_REF = "HEAD")
   expected <- repo_meta_gh_like("https://github.com/r-lib/pkgdown")
 
   pkg <- local_pkgdown_site(desc = list(
@@ -103,11 +105,27 @@ test_that("can find github from BugReports or URL", {
 })
 
 test_that("can find gitlab url", {
+  withr::local_envvar(GITHUB_HEAD_REF = "HEAD")
   url <- "https://gitlab.com/msberends/AMR"
   pkg <- local_pkgdown_site(desc = list(URL = url))
   expect_equal(package_repo(pkg), repo_meta_gh_like(url))
 })
 
+test_that("uses GITHUB env vars if set", {
+  withr::local_envvar(GITHUB_HEAD_REF = NA, GITHUB_REF_NAME = "abc")
+  expect_equal(
+    repo_meta_gh_like("https://github.com/r-lib/pkgdown")$url$source,
+    "https://github.com/r-lib/pkgdown/blob/abc/"
+  )
+
+  withr::local_envvar(GITHUB_HEAD_REF = "xyz")
+  expect_equal(
+    repo_meta_gh_like("https://github.com/r-lib/pkgdown")$url$source,
+    "https://github.com/r-lib/pkgdown/blob/xyz/"
+  )
+
+})
+
 test_that("GitLab subgroups are properly parsed", {
   issue_url <- function(...) {
     pkg <- local_pkgdown_site(desc = list(...))
@@ -124,6 +142,8 @@ test_that("GitLab subgroups are properly parsed", {
 })
 
 test_that("can find github enterprise url", {
+  withr::local_envvar(GITHUB_HEAD_REF = "HEAD")
+
   url <- "https://github.acme.com/roadrunner/speed"
   pkg <- local_pkgdown_site(desc = list(BugReports = url))
   expect_equal(package_repo(pkg), repo_meta_gh_like(url))

tests/testthat/test-usage.R

@@ -2,17 +2,26 @@
 # Reference --------------------------------------------------------------------
 
 test_that("usage escapes special characters", {
+  # parseable
+  expect_equal(usage2text("# <"), "# &lt;")
+  #unparseable
+  expect_equal(usage2text("<"), "&lt;")
+})
+
+test_that("usage re-renders non-syntactic calls", {
+  expect_equal(usage2text("`<`(x, y)"), "x &lt; y")
+  expect_equal(usage2text("`[`(x, y)"), "x[y]")
+})
 
-  usage2html <- function(x) {
-    rd <- rd_text(paste0("\\usage{", x, "}"), FALSE)[[1]]
-    as_data(rd)
-  }
+test_that("usage doesn't re-renders syntactic calls", {
+  expect_equal(usage2text("foo(x , y) # hi"), "foo(x , y) # hi")
+})
 
+test_that("usage generates user facing code for S3/S4 infix/replacement methods", {
   expect_snapshot({
-    "Parseable"
-    cat(strip_html_tags(usage2html("# <>\nx")))
-    "Unparseable"
-    cat(strip_html_tags(usage2html("# <>\n<")))
+    cat(usage2text("\\S3method{$}{indexed_frame}(x, name)"))
+    cat(usage2text("\\method{[[}{indexed_frame}(x, i) <- value"))
+    cat(usage2text("\\S4method{>=}{MyType,numeric}(e1, e2)"))
   })
 })
 
@@ -54,6 +63,13 @@ test_that("default methods get custom text", {
   expect_equal(out[1], "# Default S4 method")
 })
 
+test_that("non-syntactic functions get backquoted, not escaped", {
+  out <- rd2html("\\S3method{<}{foo}(x, y)")
+  expect_equal(out[[2]], "`<`(x, y)")
+
+  out <- rd2html("\\S4method{bar<-}{foo}(x, y)")
+  expect_equal(out[[2]], "`bar<-`(x, y)")
+})
 
 # Reference index --------------------------------------------------------------