tweak-tags.R

tweak_anchors <- function(html) {
  headings <- xml2::xml_find_all(html, ".//h1|.//h2|.//h3|.//h4|.//h5|.//h6")
  # Find all headings that are contained in a div with an id and
  # have class 'section'
  is_ok <- xml2::xml_find_lgl(headings,
    "boolean(parent::div[contains(@class, 'section') and @id])"
  )
  headings <- headings[is_ok]
  if (length(headings) == 0) {
    return(invisible())
  }

  id <- xml2::xml_find_chr(headings, "string(parent::div/@id)")

  # Update ids: dot in the anchor breaks scrollspy and rd translation
  # doesn't have enough information to generate unique ids
  new_id <- make.unique(gsub(".", "-", id, fixed = TRUE), "-")

  # Move ids to headings so that the js TOC doesn't add create new ids
  divs <- xml2::xml_parent(headings)
  xml2::xml_attr(divs, "id") <- NULL
  xml2::xml_attr(headings, "id") <- new_id

  # Insert anchors
  anchor <- paste0(
    "<a class='anchor' aria-label='anchor' href='#", new_id, "'></a>"
  )
  for (i in seq_along(headings)) {
    heading <- headings[[i]]
    if (length(xml2::xml_contents(heading)) == 0) {
      # skip empty headings
      next
    }
    # Insert anchor in first element of header
    xml2::xml_add_child(heading, xml2::read_xml(anchor[[i]]))
  }
  invisible()
}

tweak_link_md <- function(html) {
  links <- xml2::xml_find_all(html, ".//a")
  if (length(links) == 0)
    return()

  hrefs <- xml2::xml_attr(links, "href")
  needs_tweak <- grepl("\\.md$", hrefs) & xml2::url_parse(hrefs)$scheme == ""

  fix_links <- function(x) {
    x <- gsub("\\.md$", ".html", x)
    x <- gsub("\\.github/", "", x)
    x
  }

  if (any(needs_tweak)) {
    purrr::walk2(
      links[needs_tweak],
      fix_links(hrefs[needs_tweak]),
      xml2::xml_set_attr,
      attr = "href"
    )
  }

  invisible()
}

tweak_link_external <- function(html, pkg = list()) {
  links <- xml2::xml_find_all(html, ".//a")
  if (length(links) == 0)
    return()

  links <- links[!has_class(links, "external-link")]

  hrefs <- xml2::xml_attr(links, "href")
  links <- links[!is_internal_link(hrefs, pkg = pkg)]

  # Users might have added absolute URLs to e.g. the Code of Conduct
  tweak_class_prepend(links, "external-link")

  invisible()
}

# Fix relative image links
tweak_img_src <- function(html) {
  imgs <- xml2::xml_find_all(html, ".//img[not(starts-with(@src, 'http'))]")
  urls <- xml2::xml_attr(imgs, "src")
  new_urls <- gsub("(^|/)vignettes/", "\\1articles/", urls, perl = TRUE)
  new_urls <- gsub("(^|/)man/figures/", "\\1reference/figures/", new_urls, perl = TRUE)
  purrr::map2(imgs, new_urls, ~ xml2::xml_set_attr(.x, "src", .y))

  invisible()
}

tweak_link_absolute <- function(html, pkg = list()) {
  # If there's no URL links can't be made absolute
  if (is.null(pkg$meta$url)) {
    return()
  }

  url <- paste0(pkg$meta$url, "/")

  # <a> + <link> use href
  href <- xml2::xml_find_all(html, ".//a | .//link")
  xml2::xml_attr(href, "href") <- xml2::url_absolute(xml2::xml_attr(href, "href"), url)

  # <img> + <script> uses src
  src <- xml2::xml_find_all(html, ".//script | .//img")
  xml2::xml_attr(src, "src") <- xml2::url_absolute(xml2::xml_attr(src, "src"), url)

  invisible()
}

tweak_link_R6 <- function(html, cur_package) {
  r6_span <- xml2::xml_find_all(html, ".//span[@class=\"pkg-link\"]")
  if (length(r6_span) == 0) {
    return()
  }

  pkg <- xml2::xml_attr(r6_span, "data-pkg")
  topic <- xml2::xml_attr(r6_span, "data-topic")
  id <- xml2::xml_attr(r6_span, "data-id")

  url <- paste0(topic, ".html")
  external <- pkg != cur_package
  if (any(external)) {
    url[external] <- purrr::map2_chr(topic[external], pkg[external], downlit::href_topic)
  }
  url <- paste0(url, ifelse(is.na(id), "", "#method-"), id)

  r6_a <- xml2::xml_find_first(r6_span, "./a")
  xml2::xml_attr(r6_a, "href") <- url

  invisible()
}

tweak_tables <- function(html) {
  # Ensure all tables have class="table" apart from arguments
  table <- xml2::xml_find_all(html, ".//table")
  table <- table[!has_class(table, "ref-arguments")]

  tweak_class_prepend(table, "table")

  invisible()
}

# from https://github.com/rstudio/bookdown/blob/ed31991df3bb826b453f9f50fb43c66508822a2d/R/bs4_book.R#L307
tweak_footnotes <- function(html) {
  container <- xml2::xml_find_all(html, ".//div[@class='footnotes']")
  if (length(container) != 1) {
    return()
  }
  # Find id and contents
  footnotes <- xml2::xml_find_all(container, ".//li")
  id <- xml2::xml_attr(footnotes, "id")
  xml2::xml_remove(xml2::xml_find_all(footnotes, "//a[@class='footnote-back']"))
  contents <- vapply(footnotes, FUN.VALUE = character(1), function(x) {
    as.character(xml2::xml_children(x), options = character())
  })
  # Add popover attributes to links
  for (i in seq_along(id)) {
    links <- xml2::xml_find_all(html, paste0(".//a[@href='#", id[[i]], "']"))
    xml2::xml_attr(links, "href") <- NULL
    xml2::xml_attr(links, "id") <- NULL
    xml2::xml_attr(links, "tabindex") <- "0"
    xml2::xml_attr(links, "data-bs-toggle") <- "popover"
    xml2::xml_attr(links, "data-bs-content") <- contents[[i]]
  }
  # Delete container
  xml2::xml_remove(container)
}

tweak_strip <- function(html, in_dev = FALSE) {
  to_remove <- if (in_dev) "pkgdown-release" else "pkgdown-devel"
  xpath <- paste0(
    ".//*[contains(@class, '", to_remove, "')]|",
    ".//*[contains(@class, 'pkgdown-hide')]"
  )
  nodes <- xml2::xml_find_all(html, xpath)
  xml2::xml_remove(nodes)
}