R/build_dbs.R

In Bioconductor/biocViews: Categorized views of R package repositories

#' @name build-dbs
#'
#' @title Helper functions to generate HTML pages for reference manuals
#'
#' @param package_dir `character(1)` The local path to a package for which to
#'   build the aliases and cross-ref databases (`rds` files).
#'
#' @param reposRoot `character(1)` The path to the base hosting directory for
#'   the package repository. This is typically a location on the BBS server.
#'
#' @details
#' These functions are used to generate the `aliases.rds` and `rdxrefs.rds`
#' files for each package. These files are used to generate a metadata database
#' `Rds` file via the `build_meta_aliases_db` and `build_meta_rdxrefs_db`
#' functions for all packages. The `aliases.rds` file is a list of aliases
#' within each `.Rd` page in the package. The `rdxrefs.rds` file is a matrix of
#' cross-references between an external topic and the originating `.Rd` page.
#' The individual package databases are then combined into a single database
#' file for the entire repository. Each package's database is stored in the
#' `web/packages` directory in `reposRoot`. The collective metadata database
#' files are stored in the `src/contrib/Meta` directory in `reposRoot`.
#'
#' The alias and cross-reference files are generated from the package source
#' directory but may also be generated from a built package tarball
#' (functionality not included). The code is meant to run on the BBS, typically
#' after a package has been built or updated.
#'
#' @examples
#' if (interactive()) {
#'     library(BiocPkgTools)
#'     bioc_sub <- pkgBiocDeps(
#'         "SummarizedExperiment", pkgType = "software",
#'         recursive = TRUE, only.bioc = TRUE
#'     )
#'     bioc_sub <- unlist(bioc_sub, use.names = FALSE)
#'
#'     ## generate from Bioc package source dirs
#'     packages <- file.path(normalizePath("~/bioc"), bioc_sub)
#'     reposRoot <- "~/minibioc/packages/3.20/bioc"
#'
#'     for (package in packages) {
#'        build_db_from_source(package, reposRoot)
#'     }
#' }
#' @export
build_db_from_source <- function(package_dir, reposRoot) {
    tmp_dir <- tempdir()
    package <- basename(package_dir)
    package_web_dir <- file.path(reposRoot, "web", "packages", package)
    if (!dir.exists(package_web_dir))
        dir.create(package_web_dir, recursive = TRUE)
    db <- tools::Rd_db(dir = package_dir)

    ## aliases.rds
    aliases <- lapply(db, tools:::.Rd_get_metadata, "alias")
    afile <- file.path(tmp_dir, "aliases.rds")
    saveRDS(aliases, file = afile, version = 2)
    atofile <- file.path(package_web_dir, "aliases.rds")
    file.copy(
        from = afile,
        to = atofile
    )
    message(atofile)

    ## rdxrefs.rds
    rdxrefs <- lapply(db, tools:::.Rd_get_xrefs)
    rdxrefs <- cbind(do.call(rbind, rdxrefs),
                     Source = rep.int(names(rdxrefs), sapply(rdxrefs, NROW)))
    xfile <- file.path(tmp_dir, "rdxrefs.rds")
    saveRDS(rdxrefs, file = xfile, version = 2)
    xtofile <- file.path(package_web_dir, "rdxrefs.rds")
    file.copy(
        from = xfile,
        to = xtofile
    )
    message(xtofile)
}

#' @rdname build-dbs
#'
#' @param web_dir `character(1)` The `web/packages` local directory that is
#'   also hosted on the website e.g., for CRAN
#'   \url{https://cran.r-project.org/web/packages/}
#'
#' @param aliases_db_file `character(1)` The file path to `aliases.rds` file
#'   generated by the `build_db_from_source` function.
#'
#' @param force `logical(1)` If `FALSE`, the function will only update the
#'   database entries for which the aliases/rdxrefs file is more recent than the
#'   database file. If `TRUE`, the function will read all aliases/rdxrefs files.
#'
#' @examples
#' if (interactive()) {
#'     reposRoot <- "~/minibioc/packages/3.20/bioc/"
#'     web_dir <- file.path(reposRoot, "web", "packages")
#'
#'     meta_folder <- file.path(contrib.url(reposRoot), "Meta")
#'     if (!dir.exists(meta_folder)) dir.create(meta_folder, recursive = TRUE)
#'     aliases_db_file <- file.path(meta_folder, "aliases.rds")
#'
#'     meta_aliases_db <- build_meta_aliases_db(web_dir, aliases_db_file)
#'
#'     saveRDS(meta_aliases_db, aliases_db_file, version = 2)
#' }
#' @export
build_meta_aliases_db <-
    function(web_dir, aliases_db_file, force = FALSE)
{
    files <- Sys.glob(file.path(web_dir, "*", "aliases.rds"))
    packages <- basename(dirname(files))
    if (force || !is_file(aliases_db_file)) {
        db <- lapply(files, readRDS)
        names(db) <- packages
    } else {
        db <- readRDS(aliases_db_file)
        ## Drop entries in db not in package web area.
        db <- db[!is.na(match(names(db), packages))]
        ## Update entries for which aliases file is more recent than the
        ## db file.
        mtimes <- file.mtime(files)
        files <- files[mtimes >= file.mtime(aliases_db_file)]
        db[basename(dirname(files))] <- lapply(files, readRDS)
    }

    db[sort(names(db))]
}

is_file <- function(x) file.exists(x) && !file.info(x)[["isdir"]]

#' @rdname build-dbs
#'
#' @param rdxrefs_db_file `character(1)` The file path to `rdxrefs.rds` file
#'   generated by the `build_db_from_source` function.
#'
#' @examples
#' if (interactive()) {
#'     reposRoot <- "~/minibioc/packages/3.20/bioc/"
#'     web_dir <- file.path(reposRoot, "web", "packages")
#'
#'     meta_folder <- file.path(contrib.url(reposRoot), "Meta")
#'     if (!dir.exists(meta_folder)) dir.create(meta_folder, recursive = TRUE)
#'     rdxrefs_db_file <- file.path(meta_folder, "rdxrefs.rds")
#'
#'     meta_rdxrefs_db <- build_meta_rdxrefs_db(web_dir, rdxrefs_db_file)
#'
#'     saveRDS(meta_rdxrefs_db, rdxrefs_db_file, version = 2)
#' }
#' @export
build_meta_rdxrefs_db <-
    function(web_dir, rdxrefs_db_file, force = FALSE)
{
    files <- Sys.glob(file.path(web_dir, "*", "rdxrefs.rds"))
    packages <- basename(dirname(files))
    if(force || !is_file(rdxrefs_db_file)) {
        db <- lapply(files, readRDS)
        names(db) <- packages
    } else {
        db <- readRDS(rdxrefs_db_file)
        ## Drop entries in db not in package web area.
        db <- db[!is.na(match(names(db), packages))]
        ## Update entries for which rdxrefs file is more recent than the
        ## db file.
        mtimes <- file.mtime(files)
        files <- files[mtimes >= file.mtime(rdxrefs_db_file)]
        db[basename(dirname(files))] <- lapply(files, readRDS)
    }

    db[sort(names(db))]
}