R/utils_dep_pkg.r

In madlogos/aseshms: Toolkit for ASES HMS Team

#' Get dependent packages for the given packages
#'
#' Get a tibble of packages that the given packages depend on or import.
#' It makes use of \pkg{utils}::\code{\link[utils]{available.packages}} to get the full
#' package meta info list.
#' 
#' This function requires internet connection.
#' @param ... package names for process. Can be in the following forms: \describe{
#' \item{character vector/list}{E.g., c("tidyr", "dplyr") or list("tidyr", "dplyr")}
#' \item{characters}{E.g., "tidyr", "dplyr"}
#' \item{symbols}{E.g., tidyr, dplyr}
#' } 
#' @param pkg_type type of dependency, accecpts c("Depends", "Imports", "LinkingTo", 
#' "Suggests", "Enhances"). Default c('Depends', 'Imports').
#'
#' @return a tibble of dependent/import packages of the given \code{pkgs}. It has
#' 4 columns: \describe{
#' \item{pkg}{package name}
#' \item{pkg_type}{package type, e.g., "Depends", "Imports", "Suggests", etc}
#' \item{dep_pkg}{dependent/import package names}
#' \item{dep_ver}{version requirement for the dependent package}
#' }
#' @importFrom compiler cmpfun
#' @importFrom dplyr filter distinct
#' @export
#' @examples
#' \dontrun{
#' dep_pkgs(c("dplyr", "devtools"))
#' }
dep_pkgs <- function(..., pkg_type=c("Depends", "Imports")){
    pkgs <- as.character(substitute(list(...)))[-1]
    if (pkgs[1] %in% c("c", "list")) pkgs <- pkgs[-1]
    
    pkg_type <- match.arg(pkg_type, c(
        "Depends", "Imports", "LinkingTo", "Suggests",  "Enhances"), 
        several.ok=TRUE)
    
    if (! exists("avpkg", envir=aseshms_env)){
        assign("avpkg", structure(available.packages(),
                                  updated=Sys.time()), aseshms_env)
    }else{
        if (as.numeric(Sys.time()-attr(aseshms_env$avpkg, "updated"),
                       units="hours") > 1)
            assign("avpkg", structure(available.packages(),
                                      updated=Sys.time()), aseshms_env)
    }

    avpkg <- aseshms_env$avpkg
	if (! any(pkgs %in% rownames(avpkg))) {
		warning(pkgs, " cannot be found in available.packags().")
		return(NULL)
	}else{
		matched_pkgs <- intersect(pkgs, unique(rownames(avpkg)))
		if (length(pkgs) != length(matched_pkgs))
			warning(pkgs[! pkgs %in% matched_pkgs], " not matched in available.packages().")
		pkgs <- matched_pkgs
	}
	
    deps <- NULL
    new_pkgs <- pkgs
    .dep_pkg <- cmpfun(.dep_pkg)

    while (length(new_pkgs) > 0){
        deps <- deps %>%  
            rbind(lapply(new_pkgs, .dep_pkg, pkg_type=pkg_type, 
                         available_pkgs=avpkg) %>% 
                      do.call("rbind", .) %>%
					  filter(dep_pkg != "R"))
        new_pkgs <- deps %>% distinct(dep_pkg) %>% 
            filter(dep_pkg %in% rownames(avpkg) & ! dep_pkg %in% pkgs) %>% 
            `[[`(1)
        pkgs <- c(pkgs, new_pkgs)
    }
    
    return(deps)
}

#' @export
#' @rdname dep_pkgs
dep_pkg <- dep_pkgs

#' @importFrom magrittr %>%
#' @importFrom dplyr tibble
.dep_pkg <- function(pkg, pkg_type, available_pkgs){
    stopifnot(is.character(pkg))
    if (pkg %in% rownames(available_pkgs)){
		extract_pkginfo <- . %>%
            unname %>% trimws %>% strsplit("\\s*,\\s*") %>% 
            unlist %>% strsplit("\\s*[\\(\\)]\\s*")
        deps <- lapply(available_pkgs[pkg, pkg_type], extract_pkginfo)
        out <- lapply(seq_along(pkg_type), function(i){
			tibble(pkg=pkg, pkg_type=pkg_type[i], dep_pkg=sapply(deps[[i]], `[`, 1), 
                      dep_ver=gsub("\\n", " ", sapply(deps[[i]], `[`, 2)))
		}) %>% Reduce(rbind, .)
        return(out)
    }
}