Add r_repos func

Author: bschilder

DESCRIPTION

@@ -46,8 +46,12 @@ Suggests:
     badger,
     hexSticker,
     httr,
-    rvest
-RoxygenNote: 7.2.2
+    rvest,
+    BiocManager,
+    githubinstall,
+    UpSetR,
+    grDevices
+RoxygenNote: 7.2.3
 VignetteBuilder: knitr
 License: GPL-3
 Config/testthat/edition: 3

NAMESPACE

@@ -14,6 +14,7 @@ export(github_pages_files)
 export(github_pages_vignettes)
 export(github_permissions)
 export(github_traffic)
+export(r_repos)
 export(readme_header)
 importFrom(data.table,":=")
 importFrom(data.table,.SD)

NEWS.md

@@ -7,6 +7,7 @@
     - `github_metadata`
     - `github_commits`
     - `github_traffic`
+    - `r_repos`
 
 # echogithub 0.99.0
 

R/r_repos.R

@@ -0,0 +1,49 @@
+#' R repositories
+#' 
+#' Report on which repositories R packages are distributed through
+#'  (e.g. CRAN, Bioc, rOpenSci, and/or GitHub).
+#' @param save_path Path to save upset plot to.
+#' @param verbose Print messages.
+#' @returns Named list.
+#' 
+#' @export
+#' @importFrom data.table data.table
+#' @examples 
+#' report <- r_repos()
+r_repos <- function(save_path=tempfile(pattern = "upsetr.pdf"),
+                    verbose=TRUE){
+    
+    requireNamespace("UpSetR")
+    total <- percent_all <- percent_exclusive <-
+        count_exclusive <- count_all <- count_exclusive <- NULL;
+    
+    #### Gather data ####
+    pkgs <- r_repos_data(verbose = verbose) 
+    #### Upset plot ####
+    upset <- r_repos_upset(pkgs = pkgs,
+                           save_path = save_path, 
+                           verbose = verbose,
+                           sets.bar.color = "slategrey",
+                           main.bar.color = "slategrey",
+                           text.scale = 1.5,
+                           queries = list(list(query = UpSetR::intersects, 
+                                                  params = list("GitHub"),
+                                                  color = "darkred", 
+                                                  active = TRUE))
+                           ) 
+    upset_data <- upset$data
+    #### Compute percentages ####
+    stats_1repo <- colSums(upset_data[rowSums(upset_data)==1,])
+    repo_stats <- data.table::data.table(
+        repo=names(stats_1repo),
+        total=length(unique(pkgs$package)),
+        count_all=colSums(upset_data),
+        count_exclusive=stats_1repo
+    )[,percent_all:=(
+        count_all/total*100)][,percent_exclusive:=(
+            count_exclusive/total*100)]
+    #### Return ####
+    return(list(pkgs=pkgs, 
+                repo_stats=repo_stats,
+                upset=upset))
+}

R/r_repos_data.R

@@ -0,0 +1,65 @@
+r_repos_data <- function(verbose=TRUE){
+    requireNamespace("rvest")
+    requireNamespace("BiocManager")
+    requireNamespace("githubinstall")
+    # Get all packages per repo
+    
+    messager("Gathering R package repository data.",v=verbose)
+    #### Base R ####
+    baser <- rownames(installed.packages(priority="base")) 
+    
+    #### CRAN ####
+    cran <- utils::available.packages(
+        contriburl = "https://cran.rstudio.com/src/contrib") |> data.frame() 
+    
+    #### Bioc ####
+    # *Note*: This only retrieves Bioc packages in the currently installed 
+    # release of Bioconductor. Packages that are only in older versions of Bioc 
+    # (and were later deprecated) will not be listed here. 
+    ### This function gives all packages, including CRAN, Bioc,
+    # and anything currently installed. 
+    # bioc <- BiocManager::available()  
+    ### This only gives Bioc packages ####
+    repos <- BiocManager::repositories()
+    repos <- repos[names(repos)!="CRAN"]
+    bioc <- utils::available.packages(repos = repos) |> data.frame() 
+    
+    #### rOpenSci ####
+    ropensci <- 
+        rvest::read_html("https://docs.ropensci.org/") |>
+        rvest::html_element("#repolist") |>
+        rvest::html_children() |> 
+        rvest::html_text()  
+    
+    ## GitHub
+    
+    # > The githubinstall package uses Gepuro Task Views for getting the list of R packages on GitHub. Gepuro Task Views is crawling the GitHub and updates information every day. The package downloads the list of R packages from Gepuro Task Views each time it was loaded. Thus, you can always use the newest list of packages on a new R session.
+    # However, you may use an R session for a long time. In such case, gh_update_package_list() is useful.
+    # gh_update_package_list() updates the downloaded list of the R packages explicitly.
+    # 
+    # However this is not actually true, 
+    # as the file has not been updated since February 3rd 2018:
+    #     https://github.com/hoxo-m/githubinstall/issues/41
+    # 
+    # A Pull Request was made in 2019 but it was never integrated:
+    #     https://github.com/pabter/gepuro-task-views-copy/tree/76b7c4e48a704927432f328c6f898cbac0c5731c
+    
+    githubinstall::gh_update_package_list()
+    github <- githubinstall::gh_list_packages() 
+    
+    #### Merge all repos #### 
+    pkgs <- rbind(
+        cbind(package=baser,
+              repo="base"),
+        cbind(package=cran$Package,
+              repo="CRAN"),
+        cbind(package=bioc$Package,
+              repo="Bioc"),
+        cbind(package=ropensci,
+              repo="rOpenSci"),
+        cbind(package=github$package_name,
+              repo="GitHub")
+    ) |>
+        data.table::data.table()
+    return(pkgs)
+}

R/r_repos_upset.R

@@ -0,0 +1,35 @@
+r_repos_upset <- function(pkgs,
+                          save_path=tempfile(pattern = "upsetr.pdf"),
+                          verbose = TRUE,
+                          ...){
+    requireNamespace("UpSetR")
+    repo <- NULL;
+    
+    messager("Generating upset plot.",v=verbose)
+    upsetr_data <- lapply(stats::setNames(unique(pkgs$repo),
+                                          unique(pkgs$repo)),
+                          function(r){
+                              unique(subset(pkgs,repo==r)$package)
+                          }) |> UpSetR::fromList()
+    #### Plot ####
+    upset_plot <- UpSetR::upset(data = upsetr_data,
+                                ...)
+    #### Save ####
+    if(!is.null(save_path)){
+        requireNamespace("grDevices")
+        ## PDF
+        if(endsWith(save_path,".png")){
+            ## PNG
+            grDevices::png(save_path)
+            upset_plot
+            grDevices::dev.off()  
+        } else {
+            grDevices::pdf(save_path)
+            upset_plot
+            grDevices::dev.off() 
+        }
+    }
+    #### Return ####
+    return(list(data=upsetr_data,
+                plot=upset_plot))
+}

man/r_repos.Rd

@@ -0,0 +1,9 @@
+test_that("r_repos works", {
+  
+    report <- r_repos()
+    repos <- c("base","CRAN","Bioc","rOpenSci","GitHub")
+    testthat::expect_gte(nrow(report$pkgs),50000)
+    testthat::expect_true(all(repos %in% unique(report$pkgs$repo)))
+    testthat::expect_true(all(repos %in% report$repo_stats$repo))
+    testthat::expect_true(methods::is(report$upset$plot,"upset"))
+})