Merge pull request #155 from phuse-org/v0-2-0

update main to v0.2.0

.github/workflows/R-CMD-check.yaml

@@ -52,6 +52,7 @@ jobs:
 
       - uses: r-lib/actions/setup-tinytex@v1
       - run: tlmgr --version
+      - run: tlmgr update -self
       - run: tlmgr install multirow
 
       - uses: r-lib/actions/setup-pandoc@master

.github/workflows/pkgdown.yaml

@@ -21,6 +21,7 @@ jobs:
 
       - uses: r-lib/actions/setup-tinytex@v1
       - run: tlmgr --version
+      - run: tlmgr update -self
       - run: tlmgr install multirow
 
       - uses: r-lib/actions/setup-pandoc@master

.github/workflows/test-coverage.yaml

@@ -26,6 +26,7 @@ jobs:
 
       - uses: r-lib/actions/setup-tinytex@v1
       - run: tlmgr --version
+      - run: tlmgr update -self
       - run: tlmgr install multirow
 
       - uses: r-lib/actions/setup-pandoc@master

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: valtools
 Title: Automate Validated Package Creation
-Version: 0.1.0
+Version: 0.2.0
 Authors@R: 
     c(
     person(given = "Ellis",

NAMESPACE

@@ -1,14 +1,17 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(format,rd_section_coverage)
+S3method(format,rd_section_deprecate)
 S3method(format,rd_section_editDate)
 S3method(format,rd_section_editor)
 S3method(format,rd_section_riskAssessment)
 S3method(roxy_tag_parse,roxy_tag_coverage)
+S3method(roxy_tag_parse,roxy_tag_deprecate)
 S3method(roxy_tag_parse,roxy_tag_editDate)
 S3method(roxy_tag_parse,roxy_tag_editor)
 S3method(roxy_tag_parse,roxy_tag_riskAssessment)
 S3method(roxy_tag_rd,roxy_tag_coverage)
+S3method(roxy_tag_rd,roxy_tag_deprecate)
 S3method(roxy_tag_rd,roxy_tag_editDate)
 S3method(roxy_tag_rd,roxy_tag_editor)
 S3method(roxy_tag_rd,roxy_tag_riskAssessment)

R/config-files.R

@@ -76,14 +76,8 @@ vt_add_file_to_config <- function(filename, before = NULL, after = NULL){
     abort("Must supply only one of `before` and `after`.")
   } else if (has_before) {
     where2 <- min(unname(eval_select(.before, validation_file_list)))
-    if(is.infinite(where2)){
-      where2 <- 0
-    }
   } else if (has_after) {
     where2 <- max(unname(eval_select(.after, validation_file_list))) + 1
-    if(is.infinite(where2)){
-      where2 <- length(validation_file_list) + 1
-    }
   } else {
     where2 <- length(validation_file_list) + 1
   }
@@ -190,7 +184,3 @@ get_config_validation_files <- function(){
 get_config_report_naming_format <- function(){
   read_validation_config()$report_naming_format
 }
-
-is_empty_env <- function(env){
-  length(ls(envir = env)) == 0
-}

R/config-user.R

@@ -203,7 +203,7 @@ get_config_user <- function(username){
 
   if( !username %in% names(users)){
 
-    if(is_interactive()){
+    if(is_interactive()){  # nocov start
 
 
       inform(
@@ -228,7 +228,7 @@ get_config_user <- function(username){
         )
       }
 
-    }else{
+    }else{   # nocov end
       abort(
         paste0("User `",username,"` does not exist in the config file.\n",
                "Add `",username,"` to the config file with `vt_add_user_to_config(\"",username,"\")`."),
@@ -260,6 +260,8 @@ ask_user_name_title_role <- function(username = whoami::username(), name, title,
     )
   }
 
+  # nocov start
+
   message(paste(collapse = "\n",c("",
                                   "Please supply some information for recording users within the package.",
                                   "Note, that this information can be updated at any time though `vt_add_user_to_config()`"
@@ -283,7 +285,7 @@ ask_user_name_title_role <- function(username = whoami::username(), name, title,
   cat("\n")
 
   vt_user(username = username, name = name, title = title, role = role)
-
+  # nocov end
 }
 
 #' @noRd

R/config.R

@@ -83,7 +83,7 @@ vt_use_config <- function(pkg = ".",
       package <- desc::desc_get_field(file = file.path(pkg,"DESCRIPTION"),"Package")
     }else{
       if(interactive()){
-        package <- ask_package()
+        package <- ask_package()  # nocov
       }else{
         package <- ""
       }
@@ -249,7 +249,7 @@ read_validation_config <- function(){
 
 #' @importFrom rlang abort
 
-ask_package <- function(pkg = NULL){
+ask_package <- function(pkg = NULL){ # nocov start
 
   if(is.null(pkg)){
     pkg <- readline("Which package do you intend to validate?")
@@ -275,7 +275,7 @@ ask_package <- function(pkg = NULL){
     }
   }
   pkg
-}
+}  # nocov end
 
 ### Accessor functions for internal use
 

R/coverage-matrix.R

@@ -5,25 +5,39 @@
 #' @return a data.frame mapping requirement ids to test case ids.
 #' @importFrom rlang list2 := !!
 #' @export
-vt_scrape_coverage_matrix <- function(type = c("long", "wide"), reference = NULL, src = ".", ref = vt_path()){
+vt_scrape_coverage_matrix <- function(type = c("long", "wide"),
+                                      reference = NULL, src = ".", ref = vt_path()){
 
   ## helper functions
   split_vals <- function(vals){
     do.call("rbind", apply(vals, 1, FUN = function(x){
+
       this_row <- strsplit(x[["coverage"]], split = ":")[[1]]
+      if(length(this_row) == 1){
+        this_row <- rep(this_row, 2)
+
+      } else if(length(this_row) != 2){
+        rlang::abort(paste("Coverage details must follow format Test_Case:Requirement.",
+                           "See", x[["tc_title"]]),
+                     class = "vt.coverage_format")
+      }
       names(this_row) <- c("tc_id", "req_id")
       this_row["tc_id"] <- trimws(this_row["tc_id"])
 
       this_row["tc_title"] <- x["tc_title"]
+      this_row["deprecate"] <- x["deprecate"]
       as.data.frame(t(this_row), stringsAsFactors = FALSE)
     }))
   }
 
   split_req <- function(vals){
     do.call("rbind", apply(vals, 1, FUN = function(x){
+
+
       req_one_row <- data.frame(tc_title = x[["tc_title"]],
                                 tc_id = x[["tc_id"]],
                                 req_id = strsplit(trimws(x[["req_id"]]), split = ", ")[[1]],
+                                deprecate = x[["deprecate"]],
                                 stringsAsFactors = FALSE)
       req_one_row$req_title <- paste0("Requirement ", gsub(req_one_row$req_id,
                                                            pattern = "^(\\d+)\\.*.*",
@@ -35,11 +49,13 @@ vt_scrape_coverage_matrix <- function(type = c("long", "wide"), reference = NULL
   # avoids dependency on tidyr::pivot_wider
   make_wider <- function(long_vals){
     list_x <- apply(long_vals, 1, FUN = function(x){
-      as.data.frame(list2(req_id = x[["req_id"]],
+
+      out <- as.data.frame(list2(req_id = x[["req_id"]],
                           req_title = x[["req_title"]],
                           !!x[["tc_id"]] := "x"),
                     check.names = FALSE,
                     stringsAsFactors = FALSE)
+      out
     })
 
     all_names <- unique(unlist(lapply(list_x, names)))
@@ -55,30 +71,35 @@ vt_scrape_coverage_matrix <- function(type = c("long", "wide"), reference = NULL
 
   ## end helper functions
 
-  cov_raw_values <- do.call("rbind", vt_scrape_tags_from(type = "test_cases", tags =  c("title", "coverage"),
-                                               src = src, ref = vt_path()))[, c("title", "coverage")]
-
+  cov_raw_values <- do.call("rbind", vt_scrape_tags_from(type = "test_cases", tags =  c("title", "coverage", "deprecate"),
+                                               src = src, ref = vt_path()))[, c("title", "coverage", "deprecate")]
   indiv_vals <- do.call("rbind", apply(cov_raw_values, 1, FUN = function(x){
+
     data.frame(tc_title = x[["title"]],
-               coverage = strsplit(x[["coverage"]], split = "\n")[[1]], check.names = FALSE,
+               coverage = strsplit(trimws(x[["coverage"]]), split = "\n")[[1]], check.names = FALSE,
+               deprecate = x[["deprecate"]],
                stringsAsFactors = FALSE)
+
   }))
+  indiv_vals$deprecate[is.na(indiv_vals$deprecate)] <- ""
+  vals_title <- dynamic_reference_rendering(indiv_vals[!is.na(indiv_vals$coverage),],
+                                            reference = reference)
 
-  vals_title <- dynamic_reference_rendering(indiv_vals, reference = reference)
   numbered_cov_vals <- split_vals(vals_title)
-  vals_all <- split_req(numbered_cov_vals)
 
 
+  vals_all <- split_req(numbered_cov_vals)
+
   if(type[1] == "long"){
     out_data <- vals_all[order(vals_all$req_id),]
     row.names(out_data) <- 1:nrow(out_data)
-    out_data <- out_data[, c("req_title", "req_id", "tc_title", "tc_id")]
+    out_data <- out_data[, c("req_title", "req_id", "tc_title", "tc_id", "deprecate")]
     attr(out_data, "table_type") <- "long"
   } else if(type[1] == "wide"){
 
     out_data <- make_wider(vals_all)
     attr(out_data, "table_type") <- "wide"
-    this_tc_title <- unique(vals_all[,c("tc_id", "tc_title")])
+    this_tc_title <- unique(vals_all[,c("tc_id", "tc_title", "deprecate")])
     this_tc_title <- this_tc_title[order(this_tc_title$tc_id),]
     row.names(this_tc_title) <- 1:nrow(this_tc_title)
     attr(out_data, "tc_title") <- this_tc_title
@@ -104,10 +125,16 @@ vt_kable_coverage_matrix <- function(x, format = vt_render_to()){
 
 
 kable_cov_matrix_long <- function(x, format = vt_render_to()){
+  this_col_names <- c("Requirement Name", "Requirement ID", "Test Case Name", "Test Cases")
+  if(all(x$deprecate == "")){
+    x <- x[,-which(names(x) == "deprecate")]
+  } else {
+    this_col_names <- c(this_col_names, "Comment")
+  }
   out_tab <- kable(x,
         format = format,
         longtable =  TRUE,
-        col.names = c("Requirement Name", "Requirement ID", "Test Case Name", "Test Cases") )
+        col.names = this_col_names )
   out_tab <- kable_styling(out_tab, font_size = 6)
   out_tab <- collapse_rows(out_tab, c(1, 3))
   out_tab
@@ -117,8 +144,19 @@ kable_cov_matrix_long <- function(x, format = vt_render_to()){
 
 kable_cov_matrix_wide<- function(x, format = vt_render_to()){
   this_tc_title <- attr(x, "tc_title")
+
+  lapply(split(this_tc_title, this_tc_title$tc_id),
+         FUN = function(x){
+           if(nrow(x) > 1){
+             abort(paste0("Multiple test cases mapped to single test code identifier in wide coverage table - ",
+                          unique(x$tc_id), ". Filter for '",
+                          paste(x$tc_title, collapse = "' or '"),
+                          "' before running 'vt_kable_coverage_matrix()'."),
+                   class = "vt.coverage_matrix_kable")
+           }
+         })
   # enforce consistent ordering with object
-  this_tc_title <- this_tc_title[this_tc_title$tc_id == names(x)[!names(x) %in% c("req_title", "req_id")],]
+  this_tc_title <- this_tc_title[this_tc_title$tc_id %in% names(x)[!names(x) %in% c("req_title", "req_id", "tc_title")],]
 
   this_header_info <- data.frame(count = sapply(unique(this_tc_title$tc_title),
                                                  function(y){nrow(this_tc_title[this_tc_title$tc_title == y,])}),

R/file_and_path_utils.R

@@ -136,7 +136,7 @@ find_file <- function(filename, ref = ".", full_names = FALSE){
 ## it is source by whether it lives in the "Working" or "output" dir
 ## if not interactive, select file that is within the wd
 config_selector <- function(files, is_live = interactive()){
-  if (is_live) {
+  if (is_live) {  # nocov start
 
     files[sapply(files,
                  function(config_file) {
@@ -148,7 +148,7 @@ config_selector <- function(files, is_live = interactive()){
                      FALSE
                    }
                  })]
-  } else{
+  } else{ # nocov end
     wd <- normalizePath(do.call('file.path', as.list(split_path(getwd()))), winslash = "/")
     files <- files[grepl(wd, normalizePath(files, winslash = "/"), fixed = TRUE)]
     if(length(files) > 1){

R/init.R

@@ -89,13 +89,13 @@ vt_create_package <- function(pkg = ".", ..., fields = list(), rstudio = rstudio
 
 #' Internal wrapper function to call vt_create_package().
 #' To be used by RStudio project wizard, preventing opening the project twice.
-#' 
+#'
 #' @param path Project directory, collected through project wizard
-#' 
+#'
 #' @noRd
 vt_create_package_wizard <- function(path, ...){
-  vt_create_package(pkg= path, open= FALSE, ...)
+  vt_create_package(pkg= path, open= FALSE, ...)   # nocov
 }
-                              
+
 
 

R/parse_roxygen.R

@@ -161,25 +161,34 @@ parse_roxygen.r <- function(text){
 #' @importFrom utils capture.output
 #' @noRd
 parse_roxygen.r_test_code <- function(text){
-
   roxyblocks <- roxygen2::parse_text(text,env = NULL)
   roxyblocks <- cleanup_section_last_update(roxyblocks)
+  roxyblocks <- lapply(seq_along(roxyblocks), function(i, file){
+    this_block <- roxyblocks[[i]]
+    test <- tryCatch({
+      as.list(this_block$call)[[2]]
+    }, error = function(e){
 
-  roxyblocks <- lapply(roxyblocks,function(block){
+      roxygen2::block_get_tag(this_block, "title")$val
+    })
 
-    test <- as.list(block$call)[[2]]
+    if(is.null(this_block$call)){
+      this_block$call <- call("test_that", "empty test", {})
+    }
 
-    block$object <- structure(
+    this_block$object <- structure(
       list(alias = test,
            topic = test,
-           value = block$call,
-           methods = NULL
+           value =  this_block$call,
+           methods = NULL,
+           file = file,
+           block_id = i
            ),
       class = c("test_code","function","object"))
 
-    block
+    this_block
 
-  })
+  }, file = attr(text, "file"))
 
   ## confirm no duplicated test names
   roxy_test_names <- sapply(roxyblocks, function(block) block$object$alias)
@@ -293,7 +302,7 @@ cleanup_section_last_update <- function(blocks){
       section_tags <- block_get_tags(block = block, tags = "section")
 
       content <- do.call('c',lapply(section_tags, function(tags){
-        section_split <- strsplit(tags[["val"]],":\n",fixed = TRUE)[[1]]
+        section_split <- strsplit(tags[["val"]],"[:]\\s*\\n")[[1]]
         selection <- section_split[[2]]
         names(selection) <- section_split[[1]]
         selection