Improvements post flusight testing

DESCRIPTION

@@ -1,13 +1,18 @@
 Package: hubValidations
 Title: Testing framework for hubverse hub validations
-Version: 0.0.0.9000
+Version: 0.0.0.9001
 Authors@R: c(
     person(
         given = "Anna", 
         family = "Krystalli", 
         email = "[email protected]", 
         role = c("aut", "cre"),
         comment = c(ORCID = "0000-0002-2378-4915")),
+    person(
+        given = "Evan", 
+        family = "Ray", 
+        email = "[email protected]", 
+        role = c("aut")),
     person(
         given = "Hugo",
         family = "Gruson",

NEWS.md

@@ -1,3 +1,7 @@
+# hubValidations 0.0.0.9001
+
+* Release of first draft `hubValidations` package
+
 # hubValidations 0.0.0.9000
 
 * Added a `NEWS.md` file to track changes to the package.

R/check_config_hub_valid.R

@@ -22,7 +22,7 @@ check_config_hub_valid <- function(hub_path) {
 
   capture_check_cnd(
     check = check,
-    file_path = basename(hub_path),
+    file_path = basename(fs::path_abs(hub_path)),
     msg_subject = "All hub config files",
     msg_attribute = "valid.",
     msg_verbs = c("are", "must be"),

R/check_for_errors.R

@@ -22,5 +22,6 @@ check_for_errors <- function(x) {
         )
     }
 
+    cli::cli_alert_success("All validation checks have been successful.")
     return(invisible(TRUE))
 }

R/check_tbl_match_round_id.R

@@ -10,7 +10,7 @@ check_tbl_match_round_id <- function(tbl, file_path, hub_path,
     if (is_info(check_round_id_col)) {
         return(check_round_id_col)
     }
-    if (is_failure(check_round_id_col)) {
+    if (is_failure(check_round_id_col) | is_exec_error(check_round_id_col)) {
         class(check_round_id_col)[1] <- "check_error"
         check_round_id_col$call <- rlang::call_name(rlang::current_call())
         return(check_round_id_col)

R/check_tbl_unique_round_id.R

@@ -28,7 +28,7 @@ check_tbl_unique_round_id <- function(tbl, file_path, hub_path,
   if (is_info(check_round_id_col)) {
     return(check_round_id_col)
   }
-  if (is_failure(check_round_id_col)) {
+  if (is_failure(check_round_id_col) | is_exec_error(check_round_id_col)) {
     class(check_round_id_col)[1] <- "check_error"
     check_round_id_col$call <- rlang::call_name(rlang::current_call())
     return(check_round_id_col)

R/try_check.R

@@ -10,12 +10,20 @@
 try_check <- function(expr, file_path) {
   check <- try(expr, silent = TRUE)
   if (inherits(check, "try-error")) {
-    msg <- clean_msg(attr(check, "condition")$message)
+    message <- attr(check, "condition")$message
+    parent_msg <- attr(check, "condition")$parent$message
+    if (is.character(parent_msg)) {
+      parent_msg <- paste(parent_msg, collapse = " --> ")
+      msg <- paste(message, parent_msg,  sep = " --> ")
+    } else {
+      msg <- message
+    }
+    msg <- clean_msg(msg)
 
     return(
       capture_exec_error(
         file_path = file_path,
-        msg = msg,
+        msg = paste("EXEC ERROR:", msg),
         call = get_expr_call_name(expr)
       )
     )

R/validate_model_data.R

@@ -17,11 +17,13 @@ validate_model_data <- function(hub_path, file_path, round_id_col = NULL,
   round_id <- file_meta$round_id
 
   # -- File parsing checks ----
-  checks$file_read <- check_file_read(
-    file_path = file_path,
-    hub_path = hub_path
+  checks$file_read <- try_check(
+    check_file_read(
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
-  if (is_error(checks$file_read)) {
+  if (is_any_error(checks$file_read)) {
     return(checks)
   }
 
@@ -33,93 +35,115 @@ validate_model_data <- function(hub_path, file_path, round_id_col = NULL,
   # -- File round ID checks ----
   # Will be skipped if round config round_id_from_var is FALSE and no round_id_col
   # value is explicitly specified.
-  checks$valid_round_id_col <- check_valid_round_id_col(
-    tbl,
-    round_id_col = round_id_col,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$valid_round_id_col <- try_check(
+    check_valid_round_id_col(
+      tbl,
+      round_id_col = round_id_col,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
 
   # check_valid_round_id_col is run at the top of this function and if it does
   # not explicitly succeed (i.e. either fails or is is skipped), the output of
   # check_valid_round_id_col() is returned.
-  checks$unique_round_id <- check_tbl_unique_round_id(
-    tbl,
-    round_id_col = round_id_col,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$unique_round_id <- try_check(
+    check_tbl_unique_round_id(
+      tbl,
+      round_id_col = round_id_col,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
-  if (is_error(checks$unique_round_id)) {
+  if (is_any_error(checks$unique_round_id)) {
     return(checks)
   }
 
-  checks$match_round_id <- check_tbl_match_round_id(
-    tbl,
-    round_id_col = round_id_col,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$match_round_id <- try_check(
+    check_tbl_match_round_id(
+      tbl,
+      round_id_col = round_id_col,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
-  if (is_error(checks$match_round_id)) {
+  if (is_any_error(checks$match_round_id)) {
     return(checks)
   }
 
   # -- Column level checks ----
-  checks$colnames <- check_tbl_colnames(
-    tbl,
-    round_id = round_id,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$colnames <- try_check(
+    check_tbl_colnames(
+      tbl,
+      round_id = round_id,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
-  if (is_error(checks$colnames)) {
+  if (is_any_error(checks$colnames)) {
     return(checks)
   }
 
-  checks$col_types <- check_tbl_col_types(
-    tbl,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$col_types <- try_check(
+    check_tbl_col_types(
+      tbl,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
 
   # -- Row level checks ----
-  checks$valid_vals <- check_tbl_values(
-    tbl,
-    round_id = round_id,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$valid_vals <- try_check(
+    check_tbl_values(
+      tbl,
+      round_id = round_id,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
-  if (is_error(checks$valid_vals)) {
+  if (is_any_error(checks$valid_vals)) {
     return(checks)
   }
 
-  checks$rows_unique <- check_tbl_rows_unique(
-    tbl,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$rows_unique <- try_check(
+    check_tbl_rows_unique(
+      tbl,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
 
-  checks$req_vals <- check_tbl_values_required(
-    tbl,
-    round_id = round_id,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$req_vals <- try_check(
+    check_tbl_values_required(
+      tbl,
+      round_id = round_id,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
 
   # -- Value column checks ----
-  checks$value_col_valid <- check_tbl_value_col(
-    tbl,
-    round_id = round_id,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$value_col_valid <- try_check(
+    check_tbl_value_col(
+      tbl,
+      round_id = round_id,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
 
-  checks$value_col_non_desc <- check_tbl_value_col_ascending(
-    tbl,
-    file_path = file_path
+  checks$value_col_non_desc <- try_check(
+    check_tbl_value_col_ascending(
+      tbl,
+      file_path = file_path
+    ), file_path
   )
 
-  checks$value_col_sum1 <- check_tbl_value_col_sum1(
-    tbl,
-    file_path = file_path
+  checks$value_col_sum1 <- try_check(
+    check_tbl_value_col_sum1(
+      tbl,
+      file_path = file_path
+    ), file_path
   )
 
   custom_checks <- execute_custom_checks(

R/validate_model_file.R

@@ -20,47 +20,59 @@ validate_model_file <- function(hub_path, file_path,
                                 validations_cfg_path = NULL) {
   checks <- new_hub_validations()
 
-  checks$file_exists <- check_file_exists(
-    file_path = file_path,
-    hub_path = hub_path
+  checks$file_exists <- try_check(
+    check_file_exists(
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
-  if (is_error(checks$file_exists)) {
+  if (is_any_error(checks$file_exists)) {
     return(checks)
   }
 
-  checks$file_name <- check_file_name(file_path)
-  if (is_error(checks$file_name)) {
+  checks$file_name <- try_check(
+    check_file_name(file_path), file_path
+  )
+  if (is_any_error(checks$file_name)) {
     return(checks)
   }
 
-  checks$file_location <- check_file_location(file_path)
+  checks$file_location <- try_check(
+    check_file_location(file_path), file_path
+  )
 
   file_meta <- parse_file_name(file_path)
   round_id <- file_meta$round_id
 
-  checks$round_id_valid <- check_valid_round_id(
-    round_id = round_id,
-    file_path = file_path,
-    hub_path = hub_path
+  checks$round_id_valid <- try_check(
+    check_valid_round_id(
+      round_id = round_id,
+      file_path = file_path,
+      hub_path = hub_path
+    ), file_path
   )
-  if (is_error(checks$round_id_valid)) {
+  if (is_any_error(checks$round_id_valid)) {
     return(checks)
   }
 
-  checks$file_format <- check_file_format(
-    file_path = file_path,
-    hub_path = hub_path,
-    round_id = round_id
+  checks$file_format <- try_check(
+    check_file_format(
+      file_path = file_path,
+      hub_path = hub_path,
+      round_id = round_id
+    ), file_path
   )
-  if (is_error(checks$file_format)) {
+  if (is_any_error(checks$file_format)) {
     return(checks)
   }
 
-  checks$metadata_exists <- check_submission_metadata_file_exists(
-    hub_path = hub_path,
-    file_path = file_path
+  checks$metadata_exists <- try_check(
+    check_submission_metadata_file_exists(
+      hub_path = hub_path,
+      file_path = file_path
+    ), file_path
   )
-  if (is_error(checks$metadata_exists)) {
+  if (is_any_error(checks$metadata_exists)) {
     return(checks)
   }