Merge pull request #121 from chainsawriot/desc

Add implementation of `as_pkgrefs("DESCRIPTION")` #113

R/as_pkgrefs.R

@@ -6,6 +6,8 @@
 #' @param x, currently supported data structure(s) are: output from [sessionInfo()], a character vector of package names
 #' @param bioc_version character. When x is a character vector, version of Bioconductor to search for package names. NULL indicates not
 #' search for Bioconductor.
+#' @param no_enhances logical, when parsing DESCRIPTION, whether to ignore packages in the "Enhances" field
+#' @param no_suggests logical, when parsing DESCRIPTION, whether to ignore packages in the "Suggests" field
 #' @param ..., not used
 #' @return a vector of package references
 #' @export
@@ -34,13 +36,17 @@ as_pkgrefs.default <- function(x, ...) {
 
 #' @rdname as_pkgrefs
 #' @export
-as_pkgrefs.character <- function(x, bioc_version = NULL, ...) {
+as_pkgrefs.character <- function(x, bioc_version = NULL, no_enhances = TRUE, no_suggests = TRUE, ...) {
     if(.is_renv_lockfile(x)) {
       return(.extract_pkgrefs_renv_lockfile(path = x))
     }
     if(.is_directory(x)) {
       return(.extract_pkgrefs_dir(x,bioc_version))
     }
+    if(.is_DESCRIPTION(x)) {
+        return(.extract_pkgrefs_DESCRIPTION(x, bioc_version, no_enhances = no_enhances,
+                                            no_suggests = no_suggests))
+    }
     return(.normalize_pkgs(pkgs = x, bioc_version = bioc_version))
 }
 
@@ -88,6 +94,39 @@ as_pkgrefs.sessionInfo <- function(x, ...) {
     return(paste0("cran::", handle))
 }
 
+.extract_pkgrefs_DESCRIPTION <- function(path, bioc_version = NULL, no_enhances = TRUE, no_suggests = TRUE) {
+    descr_df <- as.data.frame(read.dcf(path))
+    pkg_dep_df <- .parse_desc(descr_df, remotes = TRUE)
+    pkg_dep_df$y_pkgref <- .normalize_pkgs(pkg_dep_df$y, bioc_version = bioc_version)
+    pkgrefs <- .extract_queryable_dependencies(pkg_dep_df, no_enhances = no_enhances,
+                                               no_suggests = no_suggests)
+    if (isTRUE(is.null(pkgrefs))) {
+        stop("No queryable dependencies listed in the DESCRIPTION file.", call. = FALSE)
+    }
+    .remove_overlapped_pkgrefs(pkgrefs)
+}
+
+.remove_overlapped_pkgrefs <- function(pkgrefs) {
+    ## Eliminate all github/cran duplicates, github has precedence
+    grouped_pkgrefs <- .group_pkgrefs_by_source(pkgrefs)
+    if (is.null(grouped_pkgrefs$github)) {
+        ## no possible overlap
+        return(pkgrefs)
+    }
+    for (handle in grouped_pkgrefs$github) {
+        pkgname <- strsplit(handle, "/")[[1]][2]
+        cran_version <- paste0("cran::", pkgname)
+        bioc_version <- paste0("bioc::", pkgname)
+        if (cran_version %in% pkgrefs) {
+            pkgrefs <- setdiff(pkgrefs, cran_version)
+        }
+        if (bioc_version %in% pkgrefs) {
+            pkgrefs <- setdiff(pkgrefs, bioc_version)
+        }
+    }
+    return(pkgrefs)
+}
+
 .is_renv_lockfile <- function(path) {
     # assuming all renv lockfiles are called renv.lock and path is only length 1
     if(length(path)!=1) {
@@ -123,3 +162,17 @@ as_pkgrefs.sessionInfo <- function(x, ...) {
     warning("scanning directories for R packages cannot detect github packages.",call. = FALSE)
     return(.normalize_pkgs(pkgs = pkgs, bioc_version = bioc_version))
 }
+
+.is_DESCRIPTION <- function(path) {
+    # assuming all DESCRIPTION files are called DESCRIPTION and path is only length 1
+    if(length(path)!=1) {
+        return(FALSE)
+    }
+    if(isFALSE(file.exists(path))) {
+        return(FALSE)
+    }
+    if (isFALSE(basename(path) == "DESCRIPTION")) {
+        return(FALSE)
+    }
+    TRUE
+}

R/resolve.R

@@ -150,7 +150,7 @@
 }
 
 # parse a description file from github repo
-.parse_desc <- function(descr_df, snapshot_date) {
+.parse_desc <- function(descr_df, snapshot_date = "2019-08-31", remotes = FALSE) {
     types <- c("Depends","LinkingTo","Imports","Suggests","Enhances")
     depends <- descr_df[["Depends"]]
     imports <- descr_df[["Imports"]]
@@ -162,9 +162,14 @@
     if(!is.null(suggests)) suggests <- trimws(strsplit(suggests, ",[\n]*")[[1]])
     if(!is.null(enhances)) enhances <- trimws(strsplit(enhances, ",[\n]*")[[1]])
     if(!is.null(depends))  depends <- trimws(strsplit(depends, ",[\n]*")[[1]])
-    raw_deps <- list(
-        depends, linking, imports, suggests, enhances
-    )
+    if (isFALSE(remotes)) {
+        raw_deps <- list(depends, linking, imports, suggests, enhances)
+    } else {
+        types <- c(types, "Remotes")
+        remotes <- descr_df[["Remotes"]]
+        if(!is.null(remotes))  remotes <- trimws(strsplit(remotes, ",[\n]*")[[1]])
+        raw_deps <- list(depends, linking, imports, suggests, enhances, remotes)
+    }
     type <- lapply(seq_along(raw_deps), function(x) rep(types[x], length(raw_deps[[x]])))
     version <- vapply(unlist(raw_deps), .extract_version, character(1), USE.NAMES = FALSE)
     deps <- gsub("\\s*\\(.*\\)","",unlist(raw_deps))
@@ -203,17 +208,22 @@
 
 ## We should consider Imports, Depends, LinkingTo, and Enhances in normal cases
 
-.extract_queryable_dependencies <- function(dep_df, no_enhances = TRUE, no_suggests = TRUE) {
-    if (!"y" %in% colnames(dep_df)) {
-        return(NULL)
-    }
+.generate_disabled_types <- function(no_enhances = TRUE, no_suggests = TRUE) {
     disabled_types <- c()
     if (isTRUE(no_suggests)) {
         disabled_types <- c(disabled_types, "Suggests")
     }
     if (isTRUE(no_enhances)) {
         disabled_types <- c(disabled_types, "Enhances")
     }
+    return(disabled_types)
+}
+
+.extract_queryable_dependencies <- function(dep_df, no_enhances = TRUE, no_suggests = TRUE) {
+    if (!"y" %in% colnames(dep_df)) {
+        return(NULL)
+    }
+    disabled_types <- .generate_disabled_types(no_enhances = no_enhances, no_suggests = no_suggests)
     res <- dep_df[!dep_df$type %in% disabled_types &
                   dep_df$y != "R" & !(dep_df$y %in%
                                       c("datasets", "utils", "grDevices", "graphics", "stats", "methods", "tools",
@@ -310,7 +320,8 @@ resolve <- function(pkgs = ".", snapshot_date, no_enhances = TRUE, no_suggests =
     }
     snapshot_date <- .extract_date(pkgs = pkgs, date = snapshot_date, verbose = verbose)
     bioc_version <- .generate_bioc_version(snapshot_date = snapshot_date, pkgs = pkgs)
-    pkgrefs <- as_pkgrefs(pkgs, bioc_version = bioc_version)
+    pkgrefs <- as_pkgrefs(pkgs, bioc_version = bioc_version, no_enhances = no_enhances,
+                          no_suggests = no_suggests)
     .check_local_in_pkgrefs(pkgrefs)
     output <- list()
     output$call <- match.call()

tests/testdata/Rcpp/DESCRIPTION

@@ -0,0 +1,23 @@
+Package: Rcpp
+Title: Seamless R and C++ Integration
+Version: 1.0.10.4
+Date: 2023-03-26
+Author: Dirk Eddelbuettel, Romain Francois, JJ Allaire, Kevin Ushey, Qiang Kou,
+ Nathan Russell, Inaki Ucar, Douglas Bates and John Chambers
+Maintainer: Dirk Eddelbuettel <[email protected]>
+Description: The 'Rcpp' package provides R functions as well as C++ classes which
+ offer a seamless integration of R and C++. Many R data types and objects can be
+ mapped back and forth to C++ equivalents which facilitates both writing of new
+ code as well as easier integration of third-party libraries. Documentation
+ about 'Rcpp' is provided by several vignettes included in this package, via the
+ 'Rcpp Gallery' site at <https://gallery.rcpp.org>, the paper by Eddelbuettel and
+ Francois (2011, <doi:10.18637/jss.v040.i08>), the book by Eddelbuettel (2013,
+ <doi:10.1007/978-1-4614-6868-4>) and the paper by Eddelbuettel and Balamuta (2018,
+ <doi:10.1080/00031305.2017.1375990>); see 'citation("Rcpp")' for details.
+Imports: methods, utils
+Suggests: tinytest, inline, rbenchmark, pkgKitten (>= 0.1.2)
+URL: https://www.rcpp.org, https://dirk.eddelbuettel.com/code/rcpp.html, https://github.com/RcppCore/Rcpp
+License: GPL (>= 2)
+BugReports: https://github.com/RcppCore/Rcpp/issues
+MailingList: [email protected]
+RoxygenNote: 6.1.1

tests/testdata/chipseq/DESCRIPTION

@@ -0,0 +1,16 @@
+Package: chipseq
+Title: chipseq: A package for analyzing chipseq data
+Version: 1.49.0
+Author: Deepayan Sarkar, Robert Gentleman, Michael Lawrence, Zizhen Yao
+Description: Tools for helping process short read data for chipseq
+        experiments
+Depends: R (>= 2.10), methods, BiocGenerics (>= 0.1.0), S4Vectors (>= 0.17.25),
+        IRanges (>= 2.13.12), GenomicRanges (>= 1.31.8), ShortRead
+Imports: methods, stats, lattice, BiocGenerics, IRanges, GenomicRanges,
+        ShortRead
+Suggests: BSgenome, GenomicFeatures, TxDb.Mmusculus.UCSC.mm9.knownGene
+Maintainer: Bioconductor Package Maintainer
+        <[email protected]>
+License: Artistic-2.0
+LazyLoad: yes
+biocViews: ChIPSeq, Sequencing, Coverage, QualityControl, DataImport

tests/testdata/mzesalike/DESCRIPTION

@@ -0,0 +1,23 @@
+Package: mzesalike
+Title: Xaringan Template With MZES Theme
+Version: 0.0.3
+Authors@R: 
+    person(given = "Chung-hong",
+           family = "Chan",
+           role = c("aut", "cre"),
+           email = "[email protected]",
+           comment = c(ORCID = "0000-0002-6232-7530"))
+Description: Create professional looking HTML5 slides with MZES theme.
+License: GPL-3
+Encoding: UTF-8
+LazyData: true
+Imports:
+    xaringan,
+    xaringanExtra (>= 0.0.14),
+    leaflet,
+    fontawesome
+Remotes:
+    yihui/xaringan,
+    chainsawriot/xaringanExtra,
+    rstudio/fontawesome
+RoxygenNote: 7.1.0

tests/testdata/rrcompendium-complete/DESCRIPTION

@@ -0,0 +1,30 @@
+Package: rrcompendium
+Title: Partial Reproduction of Boettiger Ecology Letters 2018;21:1255–1267 with rrtools
+Version: 0.0.0.9000
+Authors@R:
+    person(given = "Anna",
+           family = "Krystalli",
+           role = c("aut", "cre"),
+           email = "[email protected]")
+Description: This repository contains the research compendium of the partial 
+    reproduction of Boettiger Ecology Letters 2018;21:1255–1267. The compendium 
+    contains all data, code, and text associated with this sub-section of the 
+    analysis.
+License: MIT + file LICENSE
+ByteCompile: true
+Encoding: UTF-8
+LazyData: true
+URL: https://github.com/annakrystalli/rrcompendium
+BugReports: https://github.com/annakrystalli/rrcompendium/issues
+Imports: 
+    bookdown,
+    dplyr,
+    readr,
+    ggplot2 (>= 3.0.0),
+    ggthemes (>= 3.5.0),
+    here (>= 0.1),
+    knitr (>= 1.20),
+    rticles (>= 0.6)
+RoxygenNote: 6.1.0
+Suggests: 
+    testthat

tests/testdata/rrcompendium-complete/README.md

@@ -0,0 +1,6 @@
+This is obtained from
+
+https://github.com/annakrystalli/rrcompendium-complete
+
+A complete research compendium prepared with rrtools.
+

tests/testthat/test_pkgref.R

@@ -139,6 +139,37 @@ test_that("as_pkgrefs directory", {
     expect_equal(res, c("bioc::BiocGenerics", "cran::rtoot"))
 })
 
+## as_pkgrefs.character (DESCRIPTION)
+test_that("as_pkgrefs DESCRIPTION", {
+    ## Real application
+    res <- suppressWarnings(as_pkgrefs("../testdata/rrcompendium-complete/DESCRIPTION"))
+    expect_equal(res, c("cran::bookdown", "cran::dplyr", "cran::readr", "cran::ggplot2", "cran::ggthemes", "cran::here", "cran::knitr", "cran::rticles"))
+    ## Less real application
+    res <- suppressWarnings(as_pkgrefs("../testdata/askpass/DESCRIPTION", bioc_version = "3.16"))
+    expect_equal(res, c("cran::sys"))
+    res <- suppressWarnings(as_pkgrefs("../testdata/askpass/DESCRIPTION", bioc_version = "3.16", no_suggests = FALSE))
+    expect_equal(res, c("cran::sys", "cran::testthat"))
+    ## Bioc
+    res <- suppressWarnings(as_pkgrefs("../testdata/chipseq/DESCRIPTION", bioc_version = "3.16"))
+    expect_equal(res, c("bioc::BiocGenerics", "bioc::S4Vectors", "bioc::IRanges", "bioc::GenomicRanges", "bioc::ShortRead", "cran::lattice"))
+    expect_error(suppressWarnings(as_pkgrefs("../testdata/Rcpp/DESCRIPTION",
+                                             bioc_version = "3.16", no_suggests = TRUE)))
+    expect_error(suppressWarnings(as_pkgrefs("../testdata/Rcpp/DESCRIPTION",
+                                             bioc_version = "3.16", no_suggests = FALSE)), NA)
+    ## Github precendence
+    res <- suppressWarnings(as_pkgrefs("../testdata/mzesalike/DESCRIPTION", bioc_version = "3.16"))
+    expect_equal(res, c("cran::leaflet", "github::yihui/xaringan", "github::chainsawriot/xaringanExtra",
+                        "github::rstudio/fontawesome"))
+    desc <- read.dcf("../testdata/chipseq/DESCRIPTION")
+    tempered_desc <- cbind(desc, matrix("Bioconductor/GenomicRanges"))
+    dimnames(tempered_desc)[[2]][13] <- "Remotes"
+    tempered_desc_path <- file.path(tempdir(), "DESCRIPTION")
+    write.dcf(tempered_desc, tempered_desc_path)
+    res <- suppressWarnings(as_pkgrefs(tempered_desc_path, bioc_version = "3.16"))
+    expect_false("bioc::GenomicRanges" %in% res)
+    expect_true("github::Bioconductor/GenomicRanges" %in% res)
+})
+
 ## .is_*
 
 test_that(".is_pkgref", {
@@ -184,3 +215,8 @@ test_that(".is_local precedes .is_github", {
     expect_false(.is_github("~/helloworld"))
     expect_false(.is_github("./helloworld"))
 })
+
+test_that(".is_DESCRIPTION", {
+    expect_true(.is_DESCRIPTION("../testdata/mzesalike/DESCRIPTION"))
+    expect_false(.is_DESCRIPTION("../testdata/rang_6.RDS"))
+})