Fix description_extract

Author: bschilder

DESCRIPTION

@@ -52,7 +52,11 @@ Suggests:
     githubinstall,
     UpSetR,
     grDevices,
-    dlstats (>= 0.1.6)
+    dlstats (>= 0.1.6),
+    cranlogs,
+    BiocPkgTools
+Remotes:
+    github::neurogenomics/cranlogs
 RoxygenNote: 7.2.3
 VignetteBuilder: knitr
 License: GPL-3

NAMESPACE

@@ -15,11 +15,13 @@ export(github_pages_files)
 export(github_pages_vignettes)
 export(github_permissions)
 export(github_traffic)
+export(github_workflows)
 export(r_repos)
 export(r_repos_data)
 export(r_repos_downloads)
 export(r_repos_opts)
 export(readme_header)
+importFrom(RCurl,url.exists)
 importFrom(data.table,":=")
 importFrom(data.table,.SD)
 importFrom(data.table,as.data.table)
@@ -36,8 +38,10 @@ importFrom(methods,is)
 importFrom(parallel,mclapply)
 importFrom(stats,setNames)
 importFrom(stringr,str_split)
+importFrom(stringr,str_to_sentence)
 importFrom(testthat,is_testing)
 importFrom(utils,available.packages)
+importFrom(utils,capture.output)
 importFrom(utils,download.file)
 importFrom(utils,installed.packages)
 importFrom(utils,packageDescription)

NEWS.md

@@ -14,11 +14,16 @@
     - `r_repos_data`
     - `r_repos_downloads`
     - `r_repos_opts`
+* Added more robust func to get GH url: `get_github_url()`
 
 ## Bug fixes
 
 * Elevate `rvest` to *Imports*.
 * Add `parallel` to *Imports*. 
+* `r_repos_downloads_bioc`  / `r_repos_downloads_cran`
+    - Split queries into batches to prevent issues 
+        requesting with too many packages at once.
+    - Parallelise.
 
 # echogithub 0.99.0
 

R/description_extract.R

@@ -20,7 +20,7 @@ description_extract <- function(desc_file = NULL,
                                            "repo",
                                            "authors"),
                                 add_html = FALSE,
-                                as_datatable = FALSE,
+                                as_datatable = FALSE, 
                                 verbose = TRUE){ 
     #### Find or read DESCRIPTION file ####
     if(is.null(desc_file)){
@@ -29,52 +29,47 @@ description_extract <- function(desc_file = NULL,
                                       verbose = verbose)
     }
     force(desc_file)
+    all_fields <- unique(c("owner","repo","authors","github_url",
+                           names(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 <- all_fields
+    } 
     fields <- unique(fields)
-    fields <- fields[fields %in% c("owner","repo",names(desc_file))]
+    fields <- fields[fields %in% all_fields]
     #### 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)
         #### Check fields ####
-        if(f=="owner") {
-            i <- 2
-        } else if(f=="repo") {
-            i <- 1
-        } else if(f %in% c("authors","Authors@R")) {
+        if(f %in% c("authors","Authors@R","Author")) {
             authors <- description_authors(desc_file = desc_file,
                                            add_html = add_html) 
             return(authors)
         } else if(f %in% names(desc_file)){
             return(desc_file[[f]])
-        } else {
-          stp <- paste("fields must be one of:",
-                       paste("\n -",c(
-                           eval(formals(description_extract)$fields),
-                           names(desc_file)
-                       ), collapse = ""))
-          stop(stp)
-        }
-        #### Parse info #### 
-        URL <- desc_file$URL
-        if(is.na(URL)){
-            stp <- "Cannot find URL field in DESCRIPTION file."
-            stop(stp)
+        } else if(f=="github_url"){
+            gh_url <- get_github_url(desc_file = desc_file)
+            return(gh_url)
+        } else if(f=="owner"){
+            gh_url <- get_github_url(desc_file = desc_file)
+            if(is.null(gh_url)) {
+                return(NULL)
+            } else {
+                return(rev(strsplit(gh_url,"/")[[1]])[2])
+            }  
+        } else if(f=="repo"){
+            gh_url <- get_github_url(desc_file = desc_file)
+            if(is.null(gh_url)) {
+                return(NULL)
+            } else {
+                return(rev(strsplit(gh_url,"/")[[1]])[1])
+            }  
         } 
-        i <- if(f=="owner") 2 else if(f=="repo") 1 else {
-            stp <- "fields must be 'owner' or 'repo'"
-            stop(stp)
-        }
-        info <- rev(strsplit(URL,"/")[[1]])[i]    
-        # messager(paste0("+ ",f,":"),info,v=verbose)
-        return(info)
     })
     #### Return ####
     if(isTRUE(as_datatable)){

R/get_github_url.R

@@ -0,0 +1,18 @@
+get_github_url <- function(desc_file){
+    if(length(grep("github",desc_file$URL))>0){
+        return(desc_file$URL)
+    } else if (length(grep("github",desc_file$BugReports))>0){
+        return(
+            trimws(gsub("issues$","",desc_file$BugReports),
+                   whitespace = "/")
+        )
+    } else if (!is.null(desc_file$git_url)){
+        return(
+            paste("https://github.com",
+                  strsplit(desc_file$git_url,"[.]")[[1]][[2]],
+                  basename(desc_file$git_url),sep="/")
+        ) 
+    } else {
+        return(NULL)
+    }
+}

R/github_workflows.R

@@ -0,0 +1,58 @@
+#' GitHub workflows
+#' 
+#' Get metadata on workflows that have been run via GitHub Actions.
+#' This includes the "conclusion" columns showing whether 
+#' the workflow is currently passing.
+#' @param latest_only Only return the latest run of each workflow.
+#' @param workflows Select which workflows to return metadata for.
+#' @inheritParams github_files
+#' @returns \link[data.table]{data.table} containing workflow metadata.
+#' 
+#' @export
+#' @importFrom gh gh gh_token
+#' @importFrom data.table .SD rbindlist setnames
+#' @examples 
+#' dt <- github_workflows(owner="neurogenomics", repo="orthogene")
+github_workflows <- function(owner,
+                             repo,
+                             token = gh::gh_token(),
+                             latest_only = TRUE,
+                             workflows = NULL,
+                             verbose = TRUE){
+    
+    conclusion <- name <- NULL;
+    
+    messager("Searching for GitHub Actions in:",paste(owner,repo,sep="/"),
+             v=verbose)
+    ##### Check inputs ####
+    out <- check_owner_repo(owner = owner, 
+                            repo = repo, 
+                            verbose = verbose)
+    owner <- out$owner
+    repo <- out$repo
+    #### Iterate over repos ####
+    wdt <- lapply(seq_len(length(repo)), function(i){
+        endpoint <- paste("https://api.github.com/repos",
+                          owner[i],repo[i],"actions/runs",sep="/")
+        gh_response <- gh::gh(endpoint = endpoint,
+                              .token = token,
+                              per_page = 100)
+        dt <- gh_to_dt(gh_response$workflow_runs) 
+        dt <- cbind(owner=owner[i], repo=repo[i], dt)
+        #### Filter ####
+        if(isTRUE(latest_only)){
+            dt <- dt[conclusion!="cancelled",.SD[1], by="name"]
+        }
+        if(!is.null(workflows)){
+            dt <- dt[name %in% workflows,]
+        }
+        return(dt)
+    }) |> data.table::rbindlist(fill=TRUE)
+    #### Check rows ####
+    if(nrow(wdt)==0){
+        messager("No matching workflows identified.",v=verbose)
+    } else {
+        data.table::setnames(wdt,"name","workflow")
+    }
+  return(wdt)
+}

R/is_url.R

@@ -6,6 +6,7 @@
 #' Borrowed from \code{seqminer} internal function}
 #' 
 #' @keywords internal
+#' @importFrom RCurl url.exists
 is_url <- function(path,
                    protocols=c("http","https",
                                "ftp","ftps",
@@ -15,8 +16,7 @@ is_url <- function(path,
     if(is.null(path)) return(FALSE)
     pattern <- paste(paste0("^",protocols,"://"),collapse = "|")
     if (grepl(pattern = pattern, x = path, ignore.case = TRUE)) {
-        if(isTRUE(check_exists)){
-            requireNamespace("RCurl")
+        if(isTRUE(check_exists)){ 
             return(RCurl::url.exists(path))
         }
         return(TRUE)

R/r_repos.R

@@ -3,11 +3,18 @@
 #' Report on which repositories R packages are distributed through
 #'  (i.e. base R, CRAN, Bioc, rOpenSci, R-Forge, and/or GitHub).
 #' @param which Which R repositories to extract data from.
+#' @param add_downloads Add the number of downloads from each repository.
+#' @param add_descriptions Add metadata from \emph{DESCRIPTION} files.
+#' @param add_github Add metadata from the respective GitHub repository 
+#' for each R package (if any exists).
 #' @param upset_plot Whether to create an upset plot 
 #' showing R package overlap between repositories.
 #' @param show_plot Print the plot.
 #' @param save_path Path to save upset plot to.
 #' @param verbose Print messages.
+#' @param height Saved plot height.
+#' @param width Saved plot width.
+#' @param nThread Number of threads to parallelise data queries across.
 #' @inheritParams BiocManager::repositories
 #' @returns Named list.
 #' 
@@ -17,9 +24,15 @@
 #' report <- r_repos()
 r_repos <- function(which=r_repos_opts(),
                     version=NULL,
+                    add_downloads=FALSE,
+                    add_descriptions=FALSE,
+                    add_github=FALSE,
                     upset_plot=TRUE,
                     show_plot=TRUE,
                     save_path=tempfile(fileext = "upsetr.pdf"),
+                    height=7,
+                    width=10,
+                    nThread=1,
                     verbose=TRUE){
 
     if(isTRUE(upset_plot)) requireNamespace("UpSetR")
@@ -28,14 +41,20 @@ r_repos <- function(which=r_repos_opts(),
 
     #### Gather data ####
     pkgs <- r_repos_data(which = which,
+                         add_downloads =  add_downloads,
+                         add_descriptions = add_descriptions,
+                         add_github = add_github,
                          version = version,
+                         nThread = nThread,
                          verbose = verbose)  
     #### Upset plot ####
     if(isTRUE(upset_plot)){
         upset <- r_repos_upset(pkgs = pkgs,
                                save_path = save_path, 
                                show_plot = show_plot,
                                verbose = verbose,
+                               height = height,
+                               width = width,
                                sets.bar.color = "slategrey",
                                main.bar.color = "slategrey",
                                text.scale = 1.5,