R/54_pkg_document.R

In RSuite: Supports Developing, Building and Deploying R Solution

#----------------------------------------------------------------------------
# RSuite
# Copyright (c) 2017, WLOG Solutions
#
# Utilities related to package documentation building.
#----------------------------------------------------------------------------

#'
#' Builds package documentation if required.
#'
#' @param pkg_name name of package to build documentation for. (type: character)
#' @param pkg_path path to the package. (type: character)
#' @param rver R version to build package with. (type: character)
#' @param libpath library path to use during building. (type: character)
#' @param sboxpath library path there support packages can be found. (type: character)
#'
#' @return TRUE if documentation build was not required or built it succesfully.
#'
#' @keywords internal
#' @noRd
#'
pkg_build_docs <- function(pkg_name, pkg_path, rver, libpath, sboxpath) {
  # first remove Rd file built with roxygen
  removed <- lapply(X = list.files(file.path(pkg_path, "man"), ".+[.]Rd$", full.names = TRUE),
                    FUN = function(rd_file) {
                      if (!all(grepl("^% Generated by roxygen", readLines(rd_file, n = 1)))) {
                        return(FALSE)
                      }
                      unlink(rd_file, force = TRUE)
                      return(TRUE)
                    })

  ns_path <- file.path(pkg_path, "NAMESPACE")
  build_ns <- !file.exists(ns_path) || any(grepl("^# Generated by roxygen", trimws(readLines(ns_path))[1]))

  if (!build_ns && length(removed) != 0 && !any(unlist(removed))) {
    # documentation building is not required
    return(TRUE)
  }

  if (build_ns) {
    # put imports into NAMESPACE file as they will be needed to build
    # documentation properly.
    #
    desc_imps <- get_package_desc_imports(pkg_path)
    nspace_imps <- get_package_nspace_imports(pkg_path)

    ns_lines <- c("", sprintf("import(%s)", setdiff(desc_imps, nspace_imps)))
    if (!file.exists(ns_path)) {
      ns_lines <- c("# Generated by roxygen2: do not edit by hand", # for roxygen to regenerate it
                    ns_lines)
    }
    ns_con <- file(ns_path, open = "at")
    tryCatch({
      writeLines(ns_lines, con = ns_con)
    },
    finally = {
      close(ns_con)
    })
  }

  roclets <- c("collate", "namespace", "rd") # all default roclets
  dcf <- read.dcf(file.path(pkg_path, "DESCRIPTION"))
  if ("RoxygenExtraRoclets" %in% colnames(dcf)) {
    roclets <- c(roclets, trimws(strsplit(dcf[1, "RoxygenExtraRoclets"], ", ")[1]))
    pkg_loginfo("Will use following roclets for documentation building: %s", paste(roclets, collapse = ", "))
  }

  doc_res <- run_rscript(c("library(methods)", # devtools 2.0.1 requires methods to be loaded before
                           "devtools::document(%s, %s)",
                           "if (compareVersion(as.character(packageVersion('devtools')), '2.0.0') < 0) {",
                           "  devtools::unload(%s)",
                           "  devtools::clean_dll(%s)",
                           " } else {",
                           "  devtools::clean_dll(%s)",
                           "}"),

                         rscript_arg("pkg", pkg_path),
                         rscript_arg("roclets", roclets),
                         rscript_arg("pkg", pkg_path), # devtools version < 2.0.0
                         rscript_arg("pkg", pkg_path),
                         rscript_arg("path", pkg_path), # devtools version >= 2.0.0
                         rver = rver, ex_libpath = c(libpath, sboxpath))
  if (!is.null(doc_res)) {
    if (doc_res == FALSE) {
      pkg_logwarn("Document building aborted for %s", pkg_name)
    } else {
      pkg_logwarn("Document building for %s failed: %s", pkg_name, doc_res)
    }
    return(FALSE)
  }
  return(TRUE)
}

#'
#' Retrieves all package imports declared in DESCRIPTION file.
#'
#' @param pkg_path path to the package. (type: character)
#'
#' @return character vector with all the package declared imports.
#'
#' @keywords internal
#' @noRd
#'
get_package_desc_imports <- function(pkg_path, field = "Imports") {
  desc_file <- file.path(pkg_path, "DESCRIPTION")
  stopifnot(file.exists(desc_file))

  desc_imports <- read.dcf(desc_file, fields = field)[1, field]
  desc_imports <- unlist(strsplit(desc_imports, ","))
  desc_imports <- trimws(gsub("\\(.+\\)", "", desc_imports)) # remove ver spec ans ws
  desc_imports <- desc_imports[!is.na(desc_imports)]
  return(desc_imports)
}

#'
#' Retrieves all package imports specified in NAMESPACE file.
#'
#' @param pkg_path path to the package. (type: character)
#'
#' @return character vector with all the package declared imports.
#'
#' @keywords internal
#' @noRd
#'
get_package_nspace_imports <- function(pkg_path) {
  ns_file <- file.path(pkg_path, "NAMESPACE")
  if (!file.exists(ns_file)) {
    return(character(0))
  }

  ns_lines <- readLines(ns_file)
  ns_imports <- ns_lines[grepl("^\\s*import[(]\\s*.+\\s*[)]\\s*$", ns_lines)
                         | grepl("^\\s*importFrom[(]\\s*[^,]+,.+\\s*[)]\\s*$", ns_lines)]
  ns_imports <- gsub("^\\s*import(From)?[(]\\s*([^,]+)\\s*(,.+\\s*)?[)]\\s*$", "\\2", ns_imports)
  ns_imports <- trimws(unlist(strsplit(ns_imports, ",")))
  ns_imports <- ns_imports[!grepl("^except\\s*=\\s*.*", ns_imports)] # remove except parts
  ns_imports <- unique(gsub('["\']', "", ns_imports))
  return(ns_imports)
}


#'
#' Checks if package imports declaration is consistent with namespace.
#' If imports declared but not present in NAMESPACE it gets updated.
#'
#' Base packages are omitted from the check.
#'
#' Logs warning message describing all inconsistencies.
#'
#' @param pkg_name name of package. (type: character)
#' @param pkg_path path to package folder. (type: character)
#'
#' @return TRUE if declarations are consitent, FALSE overvise.
#'
#' @keywords internal
#' @noRd
#'
validate_package_imports <- function(pkg_name, pkg_path) {
  desc_imports <- get_package_desc_imports(pkg_path)
  ns_imports <- get_package_nspace_imports(pkg_path)

  desc_not_ns <- setdiff(desc_imports, ns_imports)
  if (length(desc_not_ns) > 0) {
    pkg_logwarn("Updating NAMESPACE file of %s package to contain %s",
                pkg_name, paste(desc_not_ns, collapse = ", "))
    ns_con <- file(file.path(pkg_path, "NAMESPACE"),  open = "at")
    tryCatch({
      writeLines(c("", sprintf("import(%s)", desc_not_ns)),
                 con = ns_con)
    },
    finally = {
      close(ns_con)
    })
  }

  ns_not_desc <- setdiff(ns_imports, desc_imports)

  base_pkgs <- utils::installed.packages(lib.loc = c(.Library.site, .Library), priority = "base")[, "Package"]
  ns_not_desc <- setdiff(ns_not_desc, base_pkgs)
  if (length(ns_not_desc) == 0) {
    return(TRUE)
  }

  desc_depends <- get_package_desc_imports(pkg_path, field = "Depends")
  ns_non_desc <- setdiff(ns_not_desc, desc_depends)
  if (length(ns_non_desc) == 0) {
    pkg_logwarn("Imports present in NAMESPACE are declared in DESCRIPTION (Depends) of %s", pkg_name)
    return(TRUE)
  }

  pkg_logerror("Imports present in NAMESPACE are not declared in DESCRIPTION (neither Imports nor Depends) of %s: %s",
               pkg_name, paste(ns_not_desc, collapse = ", "))
  return(TRUE)
}


#'
#' Builds package vignettes and vignette index if required.
#'
#' @param pkg_name name of the package. (type: character)
#' @param pkg_path path to the package. (type: character)
#' @param rver R version to build package with. (type: character)
#' @param ex_libpath extra library path to inclide while building vignettes. (type: character)
#'
#' @return function to execute then build finishes to cleanup or NULL if none is required.
#'
#' @keywords internal
#' @noRd
#'
pkg_build_vignettes <- function(pkg_name, pkg_path, rver, ex_libpath) {
  if (!dir.exists(file.path(pkg_path, "vignettes"))) {
    return(NULL) # has no vignettes
  }

  unlink_paths <- c()
  for (subdir in c("doc", "Meta", "inst")) {
    if (!dir.exists(file.path(pkg_path, subdir))) {
      unlink_paths <- c(unlink_paths, file.path(pkg_path, subdir))
    }
  }

  vign_res <- run_rscript(c("devtools::build_vignettes(%s)"),
                          rscript_arg("pkg", pkg_path),
                          rver = rver, ex_libpath = ex_libpath)
  if (!is.null(vign_res)) {
    if (vign_res == FALSE) {
      pkg_logwarn("Building vignettes aborted for %s", pkg_name)
    } else {
      pkg_logwarn("Building vignettes for %s failed: %s", pkg_name, vign_res)
    }
    return(function() {
      unlink(unlink_paths, recursive = TRUE, force = TRUE)
    })
  }

  if (file.exists(file.path(pkg_path, "build", "vignette.rds"))) {
    # vignette index is enforced by the package: no need to build it
    return(function() {
      unlink(unlink_paths, recursive = TRUE, force = TRUE)
    })
  }

  if (!file.exists(file.path(pkg_path, "Meta", "vignette.rds"))) {
    # devtools created no vignette index: assume no vignettes in package to build
    return(function() {
      unlink(unlink_paths, recursive = TRUE, force = TRUE)
    })
  }

  # devtools creates builds vignettes for loading, not for package building
  # to build package they have to be moved arround:
  #   - vignette index should be in build/vignette.rds instead of Meta/vignette.rds
  #   - docks generated should be in inst/doc instread of doc

  # first copy vignette index into proper location
  if (!dir.exists(file.path(pkg_path, "build"))) {
    dir.create(file.path(pkg_path, "build"), recursive = TRUE, showWarnings = FALSE)
    unlink_paths <- c(unlink_paths, file.path(pkg_path, "build"))
  } else {
    unlink_paths <- c(unlink_paths, file.path(pkg_path, "build", "vignette.rds"))
  }

  file.copy(from = file.path(pkg_path, "Meta", "vignette.rds"),
            to = file.path(pkg_path, "build", "vignette.rds"),
            overwrite = TRUE)

  # then contents of <pkg_dir>/doc into <pkg_dir>/inst/doc
  if (!dir.exists(file.path(pkg_path, "inst", "doc"))) {
    dir.create(file.path(pkg_path, "inst", "doc"), recursive = TRUE, showWarnings = FALSE)
    unlink_paths <- c(unlink_paths, file.path(pkg_path, "inst", "doc"))
  }

  for (f in list.files(file.path(pkg_path, "doc"))) {
    if (file.exists(file.path(pkg_path, "inst", "doc", f))) {
      next
    }

    dst_doc_file <- file.path(pkg_path, "inst", "doc", f)
    file.copy(file.path(pkg_path, "doc", f), dst_doc_file)
    unlink_paths <- c(unlink_paths, dst_doc_file)
  }


  return(function() {
    unlink(unlink_paths, recursive = TRUE, force = TRUE)
  })
}