Make get_hex and get_description more robust

Author: bschilder

NEWS.md

@@ -2,7 +2,12 @@
 
 ## Bug fixes
 
-- CRAN's VMs are having issues. 
+* CRAN's VMs are having issues. 
+* Reduce `docs` size by rendering PNG instead of html in `depgraph` vignette.
+* Get code coverage back up to 91%+
+* Revamp `get_hex` and `get_description` 
+  - Use lists more consistently
+  - More robust in general
 
 # rworkflows 0.99.11
 

R/check_paths.R

@@ -0,0 +1,12 @@
+check_paths <- function(refs,
+                        paths,
+                        verbose=TRUE){
+  if(!is.null(refs)){
+    if(length((paths))!=length(refs)){
+      messager("When refs is provided, paths must have the same length",
+               "(or be set to NULL).","Setting paths=NULL.",v=verbose)
+      paths <- list(NULL)
+    }
+  }
+  return(paths)
+}

R/get_authors.R

@@ -10,9 +10,11 @@
 get_authors <- function(ref=NULL,
                         add_html=FALSE){
 
-  d <- get_description(refs = ref[1])[[1]] 
+  d <- get_description(refs = ref, 
+                       paths = NULL)[[1]]
+  if(is.list(d)) d <- d[[1]]
   if(is.null(d)) return(NULL)
-  field <- grep("Authors",d$fields(),value = TRUE)[[1]] 
+  field <- grep("Authors",d$fields(),value = TRUE)
   if(length(field)>0){
    authors <- d$get_field(field)
    auths <- eval(parse(text = gsub('person','c',authors)));

R/get_description.R

@@ -41,9 +41,23 @@ get_description <- function(refs=NULL,
                             verbose=TRUE){
   # devoptera::args2vars(get_description)
 
+  paths <- check_paths(refs = refs,
+                       paths = paths, 
+                       verbose = verbose)
+  refs <- refs_to_list(refs = refs)
+  paths <- refs_to_list(refs = paths) 
+  if(methods::is(refs[[1]],"description")) {
+    refs <- get_description_check(dl = refs,
+                                  verbose = verbose) 
+    return(refs)
+  }
+  if(methods::is(paths[[1]],"description")) {
+    paths <- get_description_check(dl = paths,
+                                   verbose = verbose) 
+    return(paths) 
+  }
   if(all(is.na(refs))) refs <- NULL
-  if(methods::is(refs[[1]],"description")) return(refs)
-  if(methods::is(paths[[1]],"description")) return(paths) 
+  
   #### Method 1 ####
   dl1 <- get_description_manual(refs=refs,
                                 paths=paths,
@@ -52,13 +66,15 @@ get_description <- function(refs=NULL,
                                 use_wd=use_wd,
                                 verbose=verbose)
   dl1 <- get_description_check(dl = dl1,
-                               verbose=verbose)
-  if(!is.null(refs) && all(!sapply(dl1,is.null)) ){
-    if(all(basename(refs) %in% basename(names(dl1)))) {
+                               verbose=verbose) 
+  refs <- names(dl1)
+  if(!is.null(unlist(dl1))){
+    if(all(basename(unlist(refs)) %in% basename(names(dl1)))) {
       return(dl1)
     } 
   }
-  if(isFALSE(use_repos) || is.null(refs)){
+  if(isFALSE(use_repos) || 
+     is.null(refs)){
     return(dl1)
   } else {
     #### Method 2 ####

R/get_description_check.R

@@ -1,9 +1,10 @@
 get_description_check <- function(dl,
                                   verbose=TRUE){
   ### Make sure it gets a name ####
-  if(is.null(dl)) return(NULL)
-  for(i in seq_len(length(dl))){
-    if(is.null(names(dl[i])) && 
+  if(is.null(unlist(dl))) return(NULL)
+  for(i in seq(length(dl))){
+    nm <- names(dl[i])
+    if((is.null(nm) || nm=="NULL") && 
        methods::is(dl[[i]],"description") ){
       names(dl)[i] <- dl[[i]]$get_field("Package")
     } 

R/get_description_manual.R

@@ -21,7 +21,7 @@ get_description_manual <- function(refs=NULL,
                          refs),
          function(i){
     ref <- refs[[i]]
-    path <- paths[[i]]
+    path <- if(length(unlist(paths))==0) NULL else paths[[i]]
     wrn <- if(is.null(ref)){
       paste("Cannot import DESCRIPTION file:",paths)
     } else{

R/get_hex.R

@@ -24,22 +24,14 @@ get_hex <- function(refs=NULL,
                     verbose=TRUE){
   # devoptera::args2vars(get_hex)
 
+  if(isTRUE(hex_path)) hex_path <- "inst/hex/hex.png"
+  dl <- get_description(refs = refs,
+                        paths = paths)
+  refs <- names(dl)
   if(!is.null(refs)) {
     messager("Finding hex sticker(s) for",
              formatC(length(refs),big.mark = ","),"package(s).",v=verbose)
-  }
-  if(!is.null(refs)){
-    if(length((paths))!=length(refs)){
-      messager("When refs is provided, paths must have the same length",
-               "(or be set to NULL).","Setting paths=NULL.",v=verbose)
-      paths <- NULL
-    }
-  }
-  if(isTRUE(hex_path)){
-    hex_path <- "inst/hex/hex.png"
   } 
-  dl <- get_description(refs = refs,
-                        paths = paths)
   #### Iterate over refs ####
   hexes <- lapply(stats::setNames(seq_len(length(dl)),
                                   names(dl)),

R/refs_to_list.R

@@ -0,0 +1,11 @@
+refs_to_list <- function(refs){
+  if(is.list(refs)){ 
+    refs
+  } else if(is.null(refs)){
+    list(NULL)
+  } else if(is.character(refs)){
+    as.list(refs)
+  } else (
+    list(refs)
+  )
+}

reports/rworkflows_depgraph.png

@@ -0,0 +1,17 @@
+test_that("get_authors works", {
+  
+  true_auths <- "Brian Schilder, Alan Murphy, Nathan Skene"
+  #### ref is NULL ####
+  auths1 <- get_authors(ref = NULL)
+  testthat::expect_null(auths1)
+  #### Ref is filled: has authors ####
+  auths2 <- get_authors(ref = "rworkflows")
+  testthat::expect_equal(auths2, true_auths)
+  #### Ref is filled: has modified authors ####
+  d <- get_description(refs="neurogenomics/rworkflows")[[1]]
+  tmp <- tempfile(pattern = "DESCRIPTION")
+  d$del("Authors@R")
+  d$del("Author")
+  auths3 <- get_authors(ref = d)
+  testthat::expect_null(auths3)
+})