R/build-home.R

#' Build home page
#'
#' First looks for `index.Rmd` or `README.Rmd`, then
#' `index.md` or `README.md`. If none are found, falls back to the
#' description field in `DESCRIPTION`.
#'
#' @section YAML config:
#' To tweak the home page, you need a section called `home`.
#'
#' The sidebar will default to containing five sections: links,
#' code license, citation rules, developers, and dev status.
#' You can override this ordering or suppress some sections by
#' adding a subsection called `sections`, which should contain a
#' list of section name elements:
#'
#' \preformatted{
#' home:
#'   sections:
#'     - links
#'     - license
#'     - citation
#'     - authors
#'     - dev_status
#' }
#'
#' The default links are, in order: CRAN / Bioconductor package
#' download links; GitHub / BitBucket repo links (generated by
#' inspecting the `URL` fields of the `DESCRIPTION` file); bug
#' report links (generated by inspecting the `BugReports` field
#' of the `DESCRIPTION` file); and any custom links you provide.
#'
#' You can change the order of the links or suppress some
#' by adding a subsection called `link_order`, which should
#' consists of a list of section name elements:
#'
#' \preformatted{
#' home:
#'   link_order:
#'     - repo
#'     - github
#'     - bug_report
#'     - custom
#' }
#'
#' You can add additional links with a subsection called
#' `links`, which should contain a list of `text` + `href`
#' elements:
#'
#' \preformatted{
#' home:
#'   links:
#'   - text: Link text
#'     href: http://website.com
#' }
#'
#' The code license section is generated by reading the
#' `LICENSE` field of the `DESCRIPTION` file. Standard
#' licenses are automatically linked.
#'
#' The citation section is generated by reading the
#' `inst/CITATION` file from the package.
#'
#' The "developers" list is by default populated by the maintainer
#' ("cre"), authors ("aut"), and funder ("fnd") but you can
#' override this with a section called `roles_include`, which
#' should contain a list of members:
#'
#' \preformatted{
#' roles_include:
#'   - cre
#'   - aut
#'   - fnd
#' }
#'
#' This section must be in the base level of the YML file, not
#' a subsection under `home`: this is because in addition to
#' populating the "developers" list, these names also populate
#' the page footer developer list.
#'
#' Dev status is populated by pulling any badges from the home
#' page contents into the sidebar.
#'
#' @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))

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

  rule("Building home")
  scoped_package_context(pkg$package, pkg$topic_index, pkg$article_index)
  scoped_file_context(depth = depth)

  # Copy license file, if present
  license_path <- file.path(pkg$path, "LICENSE")
  if (file.exists(license_path)) {
    render_page(pkg, "license",
      data = list(
        pagetitle = "License",
        license = read_file(license_path)
      ),
      path = file.path(path, "LICENSE.html")
    )
  }

  # Build authors page
  if (has_citation(pkg$path)) {
    build_citation_authors(pkg, path = path, depth = depth)
  } else {
    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)
      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()
}

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)

  sections <- pkg$meta$home$sections %||% c("links", "license",
                                            "citation", "authors",
                                            "dev_status")

  map_func <- list(links = data_home_sidebar_links,
                   license = data_home_sidebar_license,
                   citation = data_home_sidebar_citation,
                   authors = data_home_sidebar_authors,
                   dev_status = data_home_sidebar_dev_status)

  sections <- sections[sections %in% ls(map_func)]

  map_func[sections] %>%
    purrr::map(do.call,
               list(pkg = pkg)) %>%
    unlist() %>%
    paste0(collapse = "\n")
}

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

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

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

  link_order <- pkg$meta$home$link_order %||% c("repo", "github",
                                                "bug_report", "custom")

  map_func <- list(repo = data_link_repo,
                   github = data_link_github,
                   bug_report = data_link_bug_report,
                   custom = data_link_meta)

  link_order <- link_order[link_order %in% ls(map_func)]

  links <- map_func[link_order] %>%
    purrr::map(do.call,
               list(pkg = pkg)) %>%
    unlist()

  paste0(
    '<div id="sidebar_links">\n',
    list_with_heading(links, "Links"),
    '\n</div>'
  )
}

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 <- grepl("github\\.com", urls)

  if (!any(github))
    return(character())

  link_url(paste0("Help develop ", pkg$package), urls[which(github)[[1]]])
}

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 a bug", bug_reports)
}

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

  name <- pkg$desc$get("Package")[[1]]
  repo_result <- repo_url(name)

  if (is.null(repo_result))
    return(list())

  if (names(repo_result) == "CRAN")
    repo_link <- paste0("https://cran.r-project.org/package=", name)
  else if (names(repo_result) == "BIOC")
    repo_link <- paste0("https://www.bioconductor.org/packages/", name)
  else
    stop("Package link not supported")

  link_url(
    paste0("Download from ", names(repo_result)),
    repo_link
  )
}

data_home_sidebar_dev_status <- function(pkg = ".") {
  paste0(
    '<div id="sidebar_dev_status">\n',
    '</div>'
  )
}

cran_mirror <- function() {
  cran <- as.list(getOption("repos"))[["CRAN"]]
  if (is.null(cran) || identical(cran, "@CRAN@")) {
    "https://cran.rstudio.com"
  } else {
    cran
  }
}

bioc_mirror <- function() {
  if (requireNamespace("BiocInstaller", quietly = TRUE)) {
    bioc <- BiocInstaller::biocinstallRepos()[["BioCsoft"]]
  } else {
    bioc <- "https://bioconductor.org/packages/release/bioc"
  }
  bioc
}

repo_url <- function(pkg, cran = cran_mirror(), bioc = bioc_mirror()) {
  bioc_pkgs <- utils::available.packages(contriburl = paste0(bioc, "/src/contrib"))
  cran_pkgs <- utils::available.packages(contriburl = paste0(cran, "/src/contrib"))
  avail <- if (pkg %in% rownames(cran_pkgs)) {
    c(CRAN = paste0(cran, "/web/packages/", pkg, "/index.html"))
  } else if (pkg %in% rownames(bioc_pkgs)) {
    c(BIOC = paste0(bioc, "/html/", pkg, ".html"))
  } else { NULL }
  return(avail)
}

link_url <- function(text, href) {
  paste0("<a href='", href, "'>", text, "</a>")
}
aaronrudkin/pkgdown documentation built on May 23, 2019, 4:23 p.m.