R/build-home.R

Defines functions tweak_homepage_html build_home

Documented in build_home

#' Build home page
#'
#' First looks for \code{index.Rmd} or \code{README.Rmd}, then
#' \code{index.md} or \code{README.md}. If none are found, falls back to the
#' description field in \code{DESCRIPTION}.
#'
#' @section YAML config:
#' To tweak the home page, you need a section called \code{home}.
#'
#' The sidebar links are automatically generated by inspecting the
#' \code{URL} and \code{BugReports} fields of the \code{DESCRIPTION}.
#' You can add additional links with a subsection called \code{links},
#' which should contain a list of \code{text} + \code{href} elements:
#'
#' \preformatted{
#' home:
#'   links:
#'   - text: Link text
#'     href: http://website.com
#' }
#'
#' The "developers" list is populated by the maintainer ("cre"), authors
#' ("aut"), and funder ("fnd").
#'
#' @inheritParams build_articles
#' @export
build_home <- function(pkg = ".", path = "docs", depth = 0L, encoding = "UTF-8") {
  old <- set_pkgdown_env("true")
  on.exit(set_pkgdown_env(old))

  rule("Building home")

  pkg <- as_pkgdown(pkg)
  path <- rel_path(path, pkg$path)
  data <- data_home(pkg)

  # Copy license file, if present
  license_path <- file.path(pkg$path, "LICENSE")
  if (file.exists(license_path)) {
    file.copy(license_path, path)
  }

  # Build authors page
  build_authors(pkg, path = path, depth = depth)

  if (is.null(data$path)) {
    data$index <- pkg$desc$get("Description")[[1]]
    render_page(pkg, "home", data, out_path(path, "index.html"), depth = depth)
  } else {
    file_name <- tools::file_path_sans_ext(basename(data$path))
    file_ext <- tools::file_ext(data$path)

    if (file_ext == "md") {
      data$index <- markdown(path = data$path, depth = 0L, index = pkg$topics)
      if (!is.null(pkg[['meta']][['DESCRIPTION']][['Description']])) {
        data$description <- pkg[['meta']][['DESCRIPTION']][['Description']]
      } else {
        data$description <- as.character(read_desc()$get("Description"))
      }
      data$keywords <- getGitHubTopics(pkg[['meta']][['navbar']][['right']][[1]][['href']])
      data$repo_name <- tail(unlist(strsplit(pkg[['meta']][['navbar']][['right']][[1]][['href']], "/")), 1)
      render_page(pkg, "home", data, out_path(path, "index.html"), depth = depth)
    } else if (file_ext == "Rmd") {
      if (identical(file_name, "README")) {
        # Render once so that .md is up to date
        message("Updating ", file_name, ".md")
        callr::r_safe(
          function(input, encoding) {
            rmarkdown::render(
              input,
              output_options = list(html_preview = FALSE),
              quiet = TRUE,
              encoding = encoding
            )
          },
          args = list(
            input = data$path,
            encoding = encoding
          )
        )
      }

      input <- file.path(path, basename(data$path))
      file.copy(data$path, input)
      on.exit(unlink(input))

      render_rmd(pkg, input, "index.html",
        depth = depth,
        data = data,
        toc = FALSE,
        strip_header = TRUE,
        encoding = encoding
      )
    }
  }

  update_homepage_html(
    out_path(path, "index.html"),
    isTRUE(pkg$meta$home$strip_header)
  )

  invisible()
}

tweak_homepage_html <- function(html, strip_header = FALSE) {
  first_para <- xml2::xml_find_first(html, "//p")
  badges <- first_para %>% xml2::xml_children()
  has_badges <- length(badges) > 0 && all(xml2::xml_name(badges) %in% "a")

  if (has_badges) {
    list <- list_with_heading(badges, "Dev status")
    list_div <- paste0("<div>", list, "</div>")
    list_html <- list_div %>% xml2::read_html() %>% xml2::xml_find_first(".//div")

    sidebar <- html %>% xml2::xml_find_first(".//div[@id='sidebar']")
    list_html %>%
      xml2::xml_children() %>%
      purrr::walk(~ xml2::xml_add_child(sidebar, .))

    xml2::xml_remove(first_para)
  }

  header <- xml2::xml_find_first(html, ".//h1")
  if (strip_header) {
    xml2::xml_remove(header, free = TRUE)
  } else {
    page_header_text <- paste0("<div class='page-header'>", header, "</div>")
    page_header <- xml2::read_html(page_header_text) %>% xml2::xml_find_first("//div")
    xml2::xml_replace(header, page_header)
  }

  # Fix relative image links
  imgs <- xml2::xml_find_all(html, ".//img")
  urls <- xml2::xml_attr(imgs, "src")
  new_urls <- gsub("^vignettes/", "articles/", urls)
  new_urls <- gsub("^man/figures/", "reference/figures/", new_urls)
  purrr::map2(imgs, new_urls, ~ (xml2::xml_attr(.x, "src") <- .y))

  tweak_tables(html)

  invisible()
}

update_homepage_html <- function(path, strip_header = FALSE) {
  html <- xml2::read_html(path, encoding = "UTF-8")
  tweak_homepage_html(html, strip_header = strip_header)

  xml2::write_html(html, path, format = FALSE)
  path
}

data_home <- function(pkg = ".") {
  pkg <- as_pkgdown(pkg)

  path <- find_first_existing(pkg$path,
    c("index.Rmd", "README.Rmd", "index.md", "README.md")
  )

  print_yaml(list(
    pagetitle = pkg$desc$get("Title")[[1]],
    sidebar = data_home_sidebar(pkg),
    path = path
  ))
}

data_home_sidebar <- function(pkg = ".") {
  if (!is.null(pkg$meta$home$sidebar))
    return(pkg$meta$home$sidebar)

  paste0(
    data_home_sidebar_authors(pkg),
    data_home_sidebar_license(pkg),
    data_home_sidebar_links(pkg),
    collapse = "\n"
  )
}

data_home_sidebar_license <- function(pkg = ".") {
  pkg <- as_pkgdown(pkg)

  paste0(
    "<h2>License</h2>\n",
    "<p>", autolink_license(pkg$desc$get("License")[[1]]), "</p>\n"
  )
}

data_home_sidebar_links <- function(pkg = ".") {
  pkg <- as_pkgdown(pkg)

  links <- c(
    data_link_cran(pkg),
    data_link_github(pkg),
    data_link_bug_report(pkg),
    data_link_meta(pkg)
  )

  list_with_heading(links, "Links")
}

list_with_heading <- function(bullets, heading) {
  if (length(bullets) == 0)
    return(character())

  paste0(
    "<h2>", heading, "</h2>",
    "<ul class='list-unstyled'>\n",
    paste0("<li>", bullets, "</li>\n", collapse = ""),
    "</ul>\n"
  )
}

data_link_meta <- function(pkg = ".") {
  pkg <- as_pkgdown(pkg)
  links <- pkg$meta$home$links

  if (length(links) == 0)
    return(character())

  links %>%
    purrr::transpose() %>%
    purrr::pmap_chr(link_url)
}

data_link_github <- function(pkg = ".") {
  pkg <- as_pkgdown(pkg)

  urls <- pkg$desc$get("URL") %>%
    strsplit(",\\s+") %>%
    `[[`(1)

  github <- grep("github", urls[!grepl("github\\.io", urls)], value=TRUE)

  if (length(github)==0) return(character())

  link_url("View source code", github)
}

data_link_bug_report <- function(pkg = ".") {
  pkg <- as_pkgdown(pkg)

  bug_reports <- pkg$desc$get("BugReports")[[1]]

  if (is.na(bug_reports))
    return(character())

  link_url("Report an issue", bug_reports)
}

data_link_cran <- function(pkg = ".") {
  pkg <- as_pkgdown(pkg)

  name <- pkg$desc$get("Package")[[1]]
  if (!on_cran(name))
    return(list())

  link_url(
    paste(name, "on CRAN"),
    paste0("https://cran.r-project.org/package=", name)
  )
}


cran_mirror <- function() {
  cran <- as.list(getOption("repos"))[["CRAN"]]
  if (is.null(cran) || identical(cran, "@CRAN@")) {
    "https://cran.rstudio.com"
  } else {
    cran
  }
}
on_cran <- function(pkg, cran = cran_mirror()) {
  pkgs <- utils::available.packages(
    type = "source",
    contriburl = paste0(cran, "/src/contrib"))
  pkg %in% rownames(pkgs)
}


link_url <- function(text, href) {
  label <- gsub("(/+)", "\\1&#8203;", href)
  paste0("<a href='", href, "'>", text, "</a>")
}
CenterForAssessment/packagePages documentation built on May 31, 2022, 1:56 p.m.