add R/r_repos_data_cast.R

bschilder · bschilder · commit 8a1cac73eb57 · 2022-12-15T22:12:42.000-05:00
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -35,7 +35,8 @@ Imports:
     stringr,
     testthat (>= 3.0.0),
     RCurl,
-    rvest
+    rvest,
+    parallel
 Suggests:
     markdown,
     rmarkdown,
diff --git a/NAMESPACE b/NAMESPACE
@@ -33,7 +33,6 @@ importFrom(data.table,setnames)
 importFrom(gh,gh)
 importFrom(gh,gh_token)
 importFrom(methods,is)
-importFrom(parallel,detectCores)
 importFrom(parallel,mclapply)
 importFrom(stats,setNames)
 importFrom(stringr,str_split)
diff --git a/NEWS.md b/NEWS.md
@@ -18,6 +18,7 @@
 ## Bug fixes
 
 * Elevate `rvest` to *Imports*.
+* Add `parallel` to *Imports*. 
     
 # echogithub 0.99.0
 
diff --git a/R/check_pkgs.R b/R/check_pkgs.R
@@ -0,0 +1,4 @@
+check_pkgs <- function(pkgs){
+    if(is.character(pkgs)) pkgs <- data.table::data.table(package=pkgs)
+    return(pkgs)
+}
diff --git a/R/description_extract.R b/R/description_extract.R
@@ -3,46 +3,58 @@
 #' Extract information from an R package's DESCRIPTION file.
 #' @param fields Fields to extract.
 #' @param add_html Add HTML styling to certain fields (e.g "authors").
+#' @param as_datatable Convert the results into a \link[data.table]{data.table}.
 #' @inheritParams description_find
 #' @inheritParams github_files
+#' @returns A named list or \link[data.table]{data.table}.
+#' 
 #' @export
+#' @importFrom data.table as.data.table
 #' @examples  
 #'\dontrun{
 #' res <- description_extract(repo="echolocatoR")
 #'}
-description_extract <- function(desc_file,
+description_extract <- function(desc_file = NULL,
                                 repo = NULL,
                                 fields = c("owner",
                                            "repo",
                                            "authors"),
                                 add_html = FALSE,
+                                as_datatable = FALSE,
                                 verbose = TRUE){ 
     #### Find or read DESCRIPTION file ####
-    # desc_file <- description_find(repo = repo, 
-    #                               desc_file = desc_file, 
-    #                               verbose = verbose) 
+    if(is.null(desc_file)){
+        desc_file <- description_find(repo = repo,
+                                      desc_file = desc_file,
+                                      verbose = verbose)
+    }
     force(desc_file)
     if(is.null(desc_file)) {
         stopper("desc_file is required for description_extract")
     }
+    if(is.null(fields)) { 
+        fields <- c("owner","repo",names(desc_file))
+    }
+    fields <- unique(fields)
+    fields <- fields[fields %in% c("owner","repo",names(desc_file))]
     #### Extract info ####
+    messager("Extracting",length(fields),"field(s).",v=verbose)
     res <- lapply(stats::setNames(fields,
                                   fields), 
                   function(f){
-        messager("Inferring",f,"from DESCRIPTION file.",v=verbose)
+        # messager("Inferring",f,"from DESCRIPTION file.",v=verbose)
         #### Check fields ####
         if(f=="owner") {
             i <- 2
         } else if(f=="repo") {
             i <- 1
-        } else if(f=="authors") {
+        } else if(f %in% c("authors","Authors@R")) {
             authors <- description_authors(desc_file = desc_file,
-                                           add_html = add_html)
-            messager("+ Inferred authors:",authors)
+                                           add_html = add_html) 
             return(authors)
         } else if(f %in% names(desc_file)){
             return(desc_file[[f]])
-        }else {
+        } else {
           stp <- paste("fields must be one of:",
                        paste("\n -",c(
                            eval(formals(description_extract)$fields),
@@ -61,9 +73,13 @@ description_extract <- function(desc_file,
             stop(stp)
         }
         info <- rev(strsplit(URL,"/")[[1]])[i]    
-        messager(paste0("+ Inferred ",f,":"),info,v=verbose) 
+        # messager(paste0("+ ",f,":"),info,v=verbose)
         return(info)
     })
     #### Return ####
-    return(res)
+    if(isTRUE(as_datatable)){
+        return(data.table::as.data.table(res))
+    } else {
+        return(res)
+    }
 }
diff --git a/R/description_extract_multi.R b/R/description_extract_multi.R
@@ -0,0 +1,26 @@
+description_extract_multi <- function(pkgs,
+                                      nThread=1,
+                                      verbose=TRUE){
+    requireNamespace("parallel")
+    
+    pkgs <- check_pkgs(pkgs = pkgs)    
+    meta_desc <- parallel::mclapply(pkgs$package, 
+                        function(p){
+                            tryCatch({
+                                description_extract(repo = p,
+                                                    fields = NULL,
+                                                    as_datatable = TRUE,
+                                                    verbose = FALSE)
+                            }, error=function(e){messager(e,v=verbose);NULL})
+                        }, mc.cores = nThread) |> 
+        data.table::rbindlist(fill = TRUE) |>
+        data.table::setnames("Package","package",
+                             skip_absent = TRUE) 
+    if(nrow(meta_desc)==0){
+        messager("WARNING: No metadata retrieved from any DESCRIPTION files.",
+                 v=verbose)
+    } else {
+        data.table::setkeyv(meta_desc,"package")
+    }
+    return(meta_desc)
+}
diff --git a/R/description_find.R b/R/description_find.R
@@ -17,7 +17,7 @@
 #' desc_file <- description_find(repo="data.table") 
 description_find <- function(desc_file = NULL,
                              owner = NULL,
-                             repo = NULL,
+                             repo = NULL, 
                              use_github = FALSE,
                              verbose = TRUE){
     
@@ -56,12 +56,14 @@ description_find <- function(desc_file = NULL,
         return(dfile)
     #### From local file ####
     } else if(!is.null(desc_file) && 
-              file.exists(desc_file)) {
+              file.exists(desc_file) &&
+              any(description_read(dcf = desc_file)$Package==repo)) {
         messager("Getting DESCRIPTION file from a local file.",v=verbose)
         dfile <- description_read(dcf = desc_file)
         return(dfile)
     #### From remote file ####
-    } else if(file.exists("DESCRIPTION")) {
+    } else if(file.exists("DESCRIPTION") &&
+              any(description_read(dcf = desc_file)$Package==repo)) {
         messager("Getting DESCRIPTION file from a local file in the",
                  "current working directory.",v=verbose)
         dfile <- description_read(dcf = "DESCRIPTION")
@@ -73,7 +75,8 @@ description_find <- function(desc_file = NULL,
         dfile <- description_read(dcf = file)
         return(dfile)
     #### From GitHub Repo ####
-    } else if (!is.null(owner) && !is.null(repo)){
+    } else if (!is.null(owner) &&
+               !is.null(repo)){
         messager("Getting DESCRIPTION file from GitHub repository.",v=verbose)
         dt <- github_files(owner = owner,
                            repo = repo, 
diff --git a/R/github_dependencies.R b/R/github_dependencies.R
@@ -69,11 +69,17 @@ github_dependencies <- function(owner,
             workflow_url=workflow_url,
             d)  
     }) |> data.table::rbindlist(fill = TRUE) 
+    #### Add owner/repo for each action ####
+    dt <- cbind(dt,
+          data.table::data.table(
+              stringr::str_split(dt$action,"/", simplify = TRUE)
+          )|> `colnames<-`(c("owner","repo")))
     ## Unsure why some rows have the branch name instead of a number.
     #### Report ####
     messager("Found",formatC(nrow(dt),big.mark = ","),
              "dependencies across",
-             formatC(dt$workflow,big.mark = ","),"workflows.",v=verbose)
+             formatC(length(unique(dt$workflow)),big.mark = ","),
+             "workflows.",v=verbose)
     #### Return ####
     return(dt)
 }
diff --git a/R/github_files_download.R b/R/github_files_download.R
@@ -7,7 +7,7 @@
 #' 
 #' @export
 #' @importFrom stringr str_split
-#' @importFrom parallel detectCores mclapply
+#' @importFrom parallel mclapply
 #' @importFrom utils download.file 
 #' @examples
 #' dt <- github_files(owner = "RajLabMSSM",
diff --git a/R/r_repos_data.R b/R/r_repos_data.R
@@ -2,23 +2,35 @@
 #' 
 #' Gather data on which repositories R packages are distributed through
 #'  (e.g. CRAN, Bioc, rOpenSci, and/or GitHub).
+#' @param include A subset of packages to return data for.
 #' @param add_downloads Add the number of downloads from each repository.
+#' @param add_descriptions Add metadata extracted from \emph{DESCRIPTION} files.
+#' @param cast Cast the results to wide format
+#'  so that each package only appears in one row.
+#' @param nThread Number of threads to parallelise \code{add_descriptions} 
+#' step across.
 #' @param verbose Print messages.
 #' @inheritParams r_repos
 #' @inheritParams BiocManager::repositories
 #' @returns data.table
 #' 
 #' @export
 #' @importFrom utils installed.packages available.packages
+#' @importFrom data.table merge.data.table
 #' @examples 
 #' pkgs <- r_repos_data()
-r_repos_data <- function(add_downloads=FALSE,
+r_repos_data <- function(include=NULL,
+                         add_downloads=FALSE,
+                         add_descriptions=FALSE,
                          which=r_repos_opts(),
+                         cast=FALSE,
                          version=NULL,
+                         nThread=1,
                          verbose=TRUE){
     requireNamespace("rvest")
     requireNamespace("BiocManager")
     requireNamespace("githubinstall")
+    installed <- package <- NULL;
     
     which <- tolower(which)
     res <- list()
@@ -79,16 +91,42 @@ r_repos_data <- function(add_downloads=FALSE,
         github <- githubinstall::gh_list_packages() 
         res[["GitHub"]] <- data.table::data.table(package=github$package_name)
     }
+    #### GitHub ####
+    if("local" %in% which){  
+        messager("Gathering R packages: local",v=verbose)
+        # githubinstall::gh_update_package_list()
+        local <- utils::installed.packages()
+        res[["local"]] <- data.table::data.table(package=rownames(local))
+    }
     #### Merge all repos #### 
     pkgs <- data.table::rbindlist(res, 
                                   fill = TRUE,
                                   use.names = TRUE, 
                                   idcol = "r_repo") 
+    if(!is.null(include)) pkgs <- pkgs[package %in% include]
+    #### Add installed info ####
+    pkgs[,installed:=package %in% rownames(utils::installed.packages())]
     #### Add downloads ####
     if(isTRUE(add_downloads)){
         pkgs <- r_repos_downloads(pkgs = pkgs,
                                   which = which,
                                   verbose = verbose)
     }
+    #### Cast wider ####
+    if(isTRUE(cast)){ 
+        pkgs <- r_repos_data_cast(pkgs = pkgs,
+                                  verbose = verbose)
+       
+    }
+    #### Add DESRIPTION metadata ####
+    if(isTRUE(add_descriptions)){
+        meta_desc <- description_extract_multi(pkgs = unique(pkgs$package),
+                                               nThread = nThread,
+                                               verbose = verbose)
+        pkgs <- data.table::merge.data.table(meta_desc,
+                                             pkgs,
+                                             all = TRUE,
+                                             by="package")
+    }
     return(pkgs)
 }
diff --git a/R/r_repos_data_cast.R b/R/r_repos_data_cast.R
@@ -0,0 +1,27 @@
+r_repos_data_cast <- function(pkgs,
+                              verbose=TRUE){
+    dummy <- NULL;
+    
+    if("downloads" %in% names(pkgs)){
+        messager(
+            "Casting data: numbers represent downloads in each r_repo.",
+            v=verbose)
+        pkgs <- data.table::dcast.data.table(
+            pkgs, 
+            formula = "package + installed ~ r_repo",
+            value.var = "downloads")
+    } else { 
+        messager(
+            "Casting data: present=TRUE and absent=FALSE in each r_repo.",
+            v=verbose)
+        r_repo_vars <- unique(pkgs$r_repo)
+        pkgs[,dummy:=TRUE]
+        pkgs <- data.table::dcast.data.table(
+            pkgs, 
+            formula = "package + installed ~ r_repo", 
+            fun.aggregate = length,
+            value.var = "dummy") 
+        pkgs[,(r_repo_vars):=lapply(.SD, as.logical),.SDcols=r_repo_vars]
+    }
+    return(pkgs)
+}
diff --git a/R/r_repos_downloads.R b/R/r_repos_downloads.R
@@ -9,22 +9,29 @@
 #' 
 #' @export
 #' @importFrom data.table rbindlist data.table setnames dcast merge.data.table
+#' @importFrom data.table :=
 #' @examples 
 #' pkgs <- r_repos_data()[r_repo=="CRAN",][seq_len(5),]
 #' pkgs2 <- r_repos_downloads(pkgs = pkgs)
 r_repos_downloads <- function(pkgs,
                               which=r_repos_opts(),
                               use_cache=TRUE,
                               verbose=TRUE){ 
+    
+    requireNamespace("dlstats")
     downloads <- NULL;
     
+    #### Check args ####
+    pkgs <- check_pkgs(pkgs = pkgs)    
     if(all(is.null(which))) return(NULL)
-    requireNamespace("dlstats")
     which <- tolower(which)
     res <- list()
     #### GitHub ####
     if("github" %in% which){
         res[["GitHub"]] <- r_repos_downloads_github(pkgs=pkgs,
+                                                    fields=c("Package",
+                                                             "owner",
+                                                             "repo"),
                                                     verbose=verbose)         
     }
     #### CRAN ####
@@ -41,21 +48,17 @@ r_repos_downloads <- function(pkgs,
     }
     #### rbind ####    
     dat <- data.table::rbindlist(res, 
-                                 fill = TRUE, use.names = TRUE, 
+                                 fill = TRUE, 
+                                 use.names = TRUE, 
                                  idcol = "r_repo") 
     #### Aggregate and cast data ####
     dat_agg <- dat[,list(downloads=sum(downloads)),
-               by=c("r_repo","package")] #|> 
-        # data.table::dcast(formula = "package ~ repo", 
-        #                   fill = NA,
-        #                   value.var = "downloads") |>
-        # data.table::setnames(
-        #     old = c("Bioc","CRAN","GitHub"), 
-        #     new = c("downloads_bioc","downloads_cran","downloads_github"),
-        #     skip_absent = TRUE)
+               by=c("r_repo","package")]
     #### Merge with input data ####
+    by <- c("package","r_repo")
+    
     pkgs <- data.table::merge.data.table(pkgs,dat_agg,
-                                         by=c("package","r_repo"),
+                                         by=by[by %in% names(pkgs)],
                                          all.x = TRUE)
     return(pkgs) 
 }
diff --git a/R/r_repos_downloads_bioc.R b/R/r_repos_downloads_bioc.R
@@ -21,4 +21,4 @@ r_repos_downloads_bioc <- function(pkgs,
         bioc <- null_dt
     }
     return(bioc)
-}
+}
diff --git a/R/r_repos_downloads_github.R b/R/r_repos_downloads_github.R
diff --git a/R/r_repos_opts.R b/R/r_repos_opts.R
diff --git a/man/description_extract.Rd b/man/description_extract.Rd
diff --git a/man/r_repos_data.Rd b/man/r_repos_data.Rd
diff --git a/tests/testthat/test-r_repos_data.R b/tests/testthat/test-r_repos_data.R
diff --git a/tests/testthat/test-r_repos_downloads.R b/tests/testthat/test-r_repos_downloads.R
