Merge pull request #20 from KWB-R/clean

Clean (#20)

DESCRIPTION

@@ -27,7 +27,6 @@ Imports:
     kwb.utils,
     lubridate,
     magrittr,
-    packrat,
     plotly,
     purrr,
     remotes,
@@ -41,6 +40,7 @@ Suggests:
     htmlwidgets,
     jsonld,
     knitr,
+    packrat,
     pkgnet,
     printr,
     rmarkdown,

R/create_pkg_codemeta.R

@@ -9,30 +9,46 @@
 #' @importFrom glue glue
 #' @importFrom utils installed.packages
 #' @export
-create_pkg_codemeta <- function(pkgs = get_github_packages(),
-                                libpath = Sys.getenv("R_LIBS_USER"),
-                                dbg = TRUE) {
-  kwb.utils::catAndRun("Creating codemeta object",
-    expr = {
-      withr::with_libpaths(
-        new = libpath,
-        code = {
-          lapply(
-            pkgs$name,
-            function(x) {
-              if (x %in% utils::installed.packages()[, "Package"]) {
-                print(glue::glue("Writing codemeta for R package {x}"))
-                codemetar::create_codemeta(pkg = x)
-              }
-              else {
-                message(sprintf("Package '%s' is not installed in
-  %s", x, libpath))
-              }
-            }
-          )
-        }
-      )
-    },
-    dbg = dbg
-  )
+create_pkg_codemeta <- function(
+    pkgs = get_github_packages(),
+    libpath = Sys.getenv("R_LIBS_USER"),
+    dbg = TRUE
+)
+{
+  cat_and_run <- function(msg, expr) {
+    kwb.utils::catAndRun(msg, expr, dbg = dbg, newLine = 3L)
+  }
+
+  # Get package names from input data frame
+  packages <- kwb.utils::selectColumns(pkgs, "name")
+
+  cat_and_run("Creating codemeta object", {
+
+    withr::with_libpaths(libpath, {
+
+      package_db <- utils::installed.packages()
+
+      is_installed <- packages %in% package_db[, "Package"]
+
+      if (any(!is_installed)) {
+        n <- sum(!is_installed)
+        message(sprintf(
+          "%d %s not installed in '%s': %s",
+          n,
+          ifelse(n > 1L, "packages are", "package is"),
+          libpath,
+          kwb.utils::stringList(sort(packages[!is_installed]))
+        ))
+      }
+
+      lapply(packages[is_installed], function(package) {
+        cat_and_run(
+          sprintf("Writing codemeta for R package %s", package),
+          try(codemetar::create_codemeta(file.path(libpath, package)))
+        )
+      })
+
+    })
+
+  })
 }

R/create_universe_pkgs_json.R

@@ -12,14 +12,19 @@
 #' create_universe_pkgs_json()
 #'
 #'
-create_universe_pkgs_json <- function(group = "KWB-R",
-                                      ignore_pkgs = NULL,
-                                      non_r_packages = kwb.pkgstatus::get_non_r_packages(),
-                                      github_token = Sys.getenv("GITHUB_PAT")) {
-    get_github_packages(group = group,
-                        ignore_pkgs = ignore_pkgs,
-                        non_r_packages = non_r_packages,
-                        github_token = github_token) %>%
+create_universe_pkgs_json <- function(
+    group = "KWB-R",
+    ignore_pkgs = NULL,
+    non_r_packages = kwb.pkgstatus::get_non_r_packages(),
+    github_token = Sys.getenv("GITHUB_PAT")
+)
+{
+  get_github_packages(
+    group = group,
+    ignore_pkgs = ignore_pkgs,
+    non_r_packages = non_r_packages,
+    github_token = github_token
+  ) %>%
     dplyr::select(.data$name, .data$url) %>%
     dplyr::rename(package = .data$name) %>%
     jsonlite::toJSON(pretty = TRUE)

R/download_github.R

@@ -16,15 +16,18 @@
 #' @import remotes
 #' @importFrom stringr str_split
 #'
-download_github <- function(repo,
-                            ref = NULL,
-                            dest_dir = tempdir(),
-                            use_zip = FALSE,
-                            quiet = FALSE,
-                            auth_token = Sys.getenv("GITHUB_PAT")) {
-  repo_sep <- as.vector(stringr::str_split(repo, pattern = "/|@", n = 3, simplify = TRUE))
-
-
+download_github <- function(
+    repo,
+    ref = NULL,
+    dest_dir = tempdir(),
+    use_zip = FALSE,
+    quiet = FALSE,
+    auth_token = Sys.getenv("GITHUB_PAT")
+)
+{
+  repo_sep <- as.vector(
+    stringr::str_split(repo, pattern = "/|@", n = 3, simplify = TRUE)
+  )
 
   reference <- if (repo_sep[3] == "") {
     ref
@@ -41,8 +44,8 @@ download_github <- function(repo,
   )
 
   x$ref <- ifelse(is.null(ref), "" , sprintf("@%s", ref))
+
   # if(use_zip) {
-  #
   #   file_ext <- ".zip"
   #   src_dir <- "/zipball/"
   # } else {
@@ -53,7 +56,6 @@ download_github <- function(repo,
   file_ext <- ifelse(use_zip, ".zip", ".tar.gz")
   src_dir <- ifelse(use_zip, "/zipball/", "/tarball/")
 
-
   dest <- file.path(dest_dir, paste0(x$repo, file_ext))
 
   if (!quiet) {
@@ -63,8 +65,10 @@ download_github <- function(repo,
     )
   }
 
+  remotes_build_url <- utils::getFromNamespace("build_url", "remotes")
+  remotes_download <- utils::getFromNamespace("download", "remotes")
 
-  src_root <- remotes:::build_url(x$host, "repos", x$username, x$repo)
+  src_root <- remotes_build_url(x$host, "repos", x$username, x$repo)
   src <- paste0(src_root, src_dir, utils::URLencode(x$ref, reserved = TRUE))
-  remotes:::download(dest, src, auth_token = x$auth_token)
+  remotes_download(dest, src, auth_token = x$auth_token)
 }

R/get_gh_ratelimit.R

@@ -4,14 +4,15 @@
 #' Sys.getenv("GITHUB_PAT")
 #' @return overview of rate limit
 #' @export
+#' @importFrom dplyr bind_rows
 #' @importFrom gh gh
-#' @importFrom  dplyr bind_rows
+#' @importFrom kwb.utils selectElements
 #' @examples
 #' get_gh_ratelimit()
-get_gh_ratelimit <- function(github_token = Sys.getenv("GITHUB_PAT")) {
-
-  res <- gh::gh(endpoint = "https://api.github.com/rate_limit",
-         .token = github_token)
-
-  dplyr::bind_rows(res$resources,.id = "id")
+get_gh_ratelimit <- function(github_token = Sys.getenv("GITHUB_PAT"))
+{
+  "https://api.github.com/rate_limit" %>%
+    gh::gh(.token = github_token) %>%
+    kwb.utils::selectElements("resources") %>%
+    dplyr::bind_rows(.id = "id")
 }

R/get_github_packages.R

@@ -16,23 +16,30 @@
 #' head(pkgs)
 #' }
 #'
-get_github_packages <- function(group = "KWB-R",
-                                ignore_pkgs = NULL,
-                                non_r_packages = kwb.pkgstatus::get_non_r_packages(),
-                                github_token = Sys.getenv("GITHUB_PAT")) {
+get_github_packages <- function(
+    group = "KWB-R",
+    ignore_pkgs = NULL,
+    non_r_packages = kwb.pkgstatus::get_non_r_packages(),
+    github_token = Sys.getenv("GITHUB_PAT")
+)
+{
   repos <- kwb.pkgstatus::get_github_repos(group, github_token)
 
   pkgs <- repos[!repos$name %in% non_r_packages, ]
 
-  if (!is.null(ignore_pkgs)) {
-    ignore_condition <- pkgs$name %in% ignore_pkgs
-    if (any(ignore_condition)) {
-      message(sprintf(
-        "Ignoring R packages %s as requested!",
-        paste(ignore_pkgs, collapse = ", ")
-      ))
-      pkgs <- pkgs[!ignore_condition, ]
-    }
+  if (is.null(ignore_pkgs)) {
+    return(pkgs)
   }
-  return(pkgs)
+
+  if (any(is_ignored <- pkgs$name %in% ignore_pkgs)) {
+
+    message(sprintf(
+      "Ignoring R packages %s as requested!",
+      paste(ignore_pkgs, collapse = ", ")
+    ))
+
+    pkgs <- pkgs[!is_ignored, ]
+  }
+
+  pkgs
 }

R/get_pkg_dependencies.R

@@ -1,3 +1,5 @@
+# get_pkg_dependencies ---------------------------------------------------------
+
 #' Get package dependencies
 #'
 #' @param pkgs character vector with package names
@@ -13,23 +15,86 @@
 #' get_pkg_dependencies(pkgs$name)
 #' }
 #'
-get_pkg_dependencies <- function(pkgs,
-                                 library_path = .libPaths(),
-                                 dbg = TRUE,
-                                 ...) {
+get_pkg_dependencies <- function(
+    pkgs,
+    library_path = .libPaths(),
+    dbg = TRUE,
+    ...
+)
+{
+  get_pkg_dependencies_impl(
+    pkgs,
+    recursive = FALSE,
+    ...,
+    library_path = library_path,
+    dbg = dbg
+  )
+}
+
+# get_recursive_pkg_dependencies -----------------------------------------------
+
+#' Get recursive package dependencies
+#'
+#' @param pkgs character vector with package names
+#' @param library_path character vector with path(s) to R library (default: .libPaths())
+#' @param dbg logical if debug should be shown (default: TRUE)
+#' @param ... additional arguments passed to packrat:::getPackageDependencies()
+#' @return list with recursive package dependencies
+#' @importFrom stats setNames
+#' @export
+#' @examples
+#' \dontrun{
+#' pkgs <- pkgmeta::get_github_packages()
+#' get_recursive_pkg_dependencies(pkgs$name)
+#' }
+#'
+get_recursive_pkg_dependencies <- function(
+    pkgs,
+    library_path = .libPaths(),
+    dbg = TRUE,
+    ...
+)
+{
+  get_pkg_dependencies_impl(
+    pkgs,
+    recursive = TRUE,
+    ...,
+    library_path = library_path,
+    dbg = dbg
+  )
+}
 
+# get_pkg_dependencies_impl ----------------------------------------------------
+get_pkg_dependencies_impl <- function(
+    pkgs,
+    recursive,
+    ...,
+    library_path = .libPaths(),
+    dbg = TRUE
+)
+{
+  fun_name <- ifelse(
+    recursive,
+    "recursivePackageDependencies",
+    "getPackageDependencies"
+  )
 
-  pkgs_installed <- pkgs[pkgs %in% rownames(installed.packages(lib.loc = library_path))]
+  dependency_function <- utils::getFromNamespace(fun_name, "packrat")
 
-  stats::setNames(lapply(pkgs_installed, function(pkg) {
-    kwb.utils::catAndRun(sprintf("Getting recursive dependencies for '%s'", pkg),
-                         expr = {
-                           packrat:::getPackageDependencies(pkg,
-                                                            lib.loc = library_path,
-                                                            ...
-                                                            )
-                           },
-                         dbg = dbg)}),
-    nm = pkgs_installed)
+  package_db <- installed.packages(lib.loc = library_path)
+  pkgs_installed <- pkgs[pkgs %in% rownames(package_db)]
 
+  pkgs_installed %>%
+    lapply(function(pkg) {
+      kwb.utils::catAndRun(
+        sprintf(
+          "Getting %s dependencies for '%s'",
+          ifelse(recursive, "recursive", "non-recursive"),
+          pkg
+        ),
+        dependency_function(pkg, lib.loc = library_path, ...),
+        dbg = dbg
+      )
+    }) %>%
+    stats::setNames(pkgs_installed)
 }