Merge pull request #27 from Infectious-Disease-Modeling-Hubs/validate_pr

[WIP] Add validate_pr fn

DESCRIPTION

@@ -31,6 +31,7 @@ Imports:
     config,
     dplyr,
     fs,
+    gh,
     hubUtils (>= 0.0.0.9014),
     jsonlite,
     jsonvalidate,
@@ -44,6 +45,7 @@ Imports:
     yaml
 Suggests: 
     covr,
+    gert,
     mockery,
     rmarkdown,
     testthat (>= 3.0.0),

NAMESPACE

@@ -1,26 +1,32 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(combine,hub_validations)
 S3method(print,hub_validations)
+S3method(print,pr_hub_validations)
 export("%>%")
+export(as_hub_validations)
 export(capture_check_cnd)
 export(capture_check_info)
 export(capture_exec_error)
 export(capture_exec_warning)
-export(cfg_check_tbl_col_timediff)
+export(check_config_hub_valid)
 export(check_file_exists)
 export(check_file_format)
 export(check_file_location)
 export(check_file_name)
 export(check_file_read)
+export(check_for_errors)
 export(check_metadata_file_exists)
 export(check_metadata_file_ext)
 export(check_metadata_file_location)
 export(check_metadata_file_name)
 export(check_metadata_matches_schema)
 export(check_metadata_schema_exists)
 export(check_submission_metadata_file_exists)
+export(check_submission_time)
 export(check_tbl_col_types)
 export(check_tbl_colnames)
+export(check_tbl_match_round_id)
 export(check_tbl_rows_unique)
 export(check_tbl_unique_round_id)
 export(check_tbl_value_col)
@@ -30,14 +36,27 @@ export(check_tbl_values)
 export(check_tbl_values_required)
 export(check_valid_round_id)
 export(check_valid_round_id_col)
+export(combine)
+export(is_any_error)
 export(is_error)
+export(is_exec_error)
+export(is_exec_warn)
 export(is_failure)
 export(is_info)
 export(is_success)
+export(new_hub_validations)
 export(not_pass)
+export(opt_check_tbl_col_timediff)
+export(opt_check_tbl_counts_lt_popn)
+export(opt_check_tbl_horizon_timediff)
 export(read_model_out_file)
+export(try_check)
 export(validate_model_data)
 export(validate_model_file)
 export(validate_model_metadata)
+export(validate_pr)
 export(validate_submission)
+export(validate_submission_time)
+importFrom(lubridate,"%within%")
 importFrom(magrittr,"%>%")
+importFrom(rlang,"!!!")

R/check_config_hub_valid.R

@@ -0,0 +1,32 @@
+#' Check hub correctly configured
+#'
+#' Checks that `admin` and `tasks` configuration files in directory `hub-config`
+#' are valid.
+#' @inherit check_valid_round_id return params
+#'
+#' @export
+check_config_hub_valid <- function(hub_path) {
+  valid_config <- hubUtils::validate_hub_config(hub_path) %>%
+      suppressMessages() %>%
+      suppressWarnings()
+
+  check <- all(unlist(valid_config))
+
+  if (check) {
+    details <- NULL
+  } else {
+    details <- cli::format_inline(
+      "Config file{?s} {.val {names(valid_config)[!unlist(valid_config)]}} invalid."
+    )
+  }
+
+  capture_check_cnd(
+    check = check,
+    file_path = basename(hub_path),
+    msg_subject = "All hub config files",
+    msg_attribute = "valid.",
+    msg_verbs = c("are", "must be"),
+    error = TRUE,
+    details = details
+  )
+}

R/check_for_errors.R

@@ -0,0 +1,26 @@
+#' Raise conditions stored in a `hub_validations` object
+#'
+#' This is meant to be used in CI workflows to raise conditions from
+#' `hub_validations` objects.
+#'
+#' @param x A `hub_validations` object
+#'
+#' @return An error if one of the elements of `x` is of class `check_failure`,
+#' `check_error`, `check_exec_error` or `check_exec_warning`.
+#' `TRUE` invisibly otherwise.
+#'
+#' @export
+check_for_errors <- function(x) {
+    flag_checks <- x[purrr::map_lgl(x, ~not_pass(.x))]
+
+    class(flag_checks) <- c("hub_validations", "list")
+
+    if (length(flag_checks) > 0) {
+        print(flag_checks)
+        rlang::abort(
+            "\nThe validation checks produced some failures/errors reported above."
+        )
+    }
+
+    return(invisible(TRUE))
+}

R/check_submission_time.R

@@ -0,0 +1,61 @@
+#' Checks submission is within the valid submission window for a given round.
+#'
+#' @inherit check_tbl_col_types params return
+#'
+#' @importFrom lubridate %within%
+#' @export
+check_submission_time <- function(hub_path, file_path) {
+  config_tasks <- hubUtils::read_config(hub_path, "tasks")
+  submission_config <- get_file_round_config(file_path, hub_path)[["submissions_due"]]
+  hub_tz <- get_hub_timezone(hub_path)
+
+  if (!is.null(submission_config[["relative_to"]])) {
+    tbl <- read_model_out_file(
+      file_path = file_path,
+      hub_path = hub_path
+    )
+    relative_date <- as.Date(
+      unique(tbl[[submission_config[["relative_to"]]]])
+    )
+    submission_window <- get_submission_window(
+      start = relative_date + submission_config[["start"]],
+      end = relative_date + submission_config[["end"]],
+      hub_tz
+    )
+  } else {
+    submission_window <- get_submission_window(
+      start = submission_config[["start"]],
+      end = submission_config[["end"]],
+      hub_tz
+    )
+  }
+  check <- Sys.time() %within% submission_window
+
+  if (check) {
+    details <- NULL
+  } else {
+    details <- cli::format_inline(
+      "Current time {.val {Sys.time()}} is outside window {.val {submission_window}}."
+    )
+  }
+
+  capture_check_cnd(
+    check = check,
+    file_path = file_path,
+    msg_subject = "Submission time",
+    msg_attribute = "within accepted submission window for round.",
+    details = details
+  )
+}
+
+get_submission_window <- function(start, end, hub_tz) {
+  submit_window_start <- lubridate::ymd(start, tz = hub_tz)
+  submit_window_end <- lubridate::ymd_hms(paste(end, "23:59:59"),
+    tz = hub_tz
+  )
+
+  lubridate::interval(
+    start = submit_window_start,
+    end = submit_window_end
+  )
+}

R/check_tbl_match_round_id.R

@@ -0,0 +1,50 @@
+#' Check model output data tbl round ID matches submission round ID.
+#'
+#' @inherit check_tbl_unique_round_id params details return
+#' @export
+check_tbl_match_round_id <- function(tbl, file_path, hub_path,
+                                      round_id_col = NULL) {
+    check_round_id_col <- check_valid_round_id_col(
+        tbl, file_path, hub_path, round_id_col)
+
+    if (is_info(check_round_id_col)) {
+        return(check_round_id_col)
+    }
+    if (is_failure(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)
+    }
+
+    if (is.null(round_id_col)) {
+        round_id_col <- get_file_round_id_col(file_path, hub_path)
+    }
+    round_id <- parse_file_name(file_path)$round_id
+
+    round_id_match <- tbl[[round_id_col]] == round_id
+    check <- all(round_id_match)
+
+    if (check) {
+        details <- NULL
+    } else {
+        unmatched_round_ids <- unique(tbl[[round_id_col]][!round_id_match])
+        details <- cli::format_inline(
+            "{.var round_id} {cli::qty(length(unmatched_round_ids))}
+            value{?s} {.val {unmatched_round_ids}} {?does/do} not match
+            submission {.var round_id} {.val {round_id}}"
+        )
+    }
+
+    capture_check_cnd(
+        check = check,
+        file_path = file_path,
+        msg_subject = cli::format_inline(
+            "All {.var round_id_col} {.val {round_id_col}} values"
+        ),
+        msg_attribute = "submission {.var round_id} from file name.",
+        msg_verbs = c("match", "must match"),
+        error = TRUE,
+        details = details
+    )
+
+}

R/check_tbl_values_required.R

@@ -22,14 +22,13 @@ check_tbl_values_required <- function(tbl, round_id, file_path, hub_path) {
     round_id = round_id,
     required_vals_only = FALSE,
     all_character = TRUE,
-    as_arrow_table = TRUE,
+    as_arrow_table = FALSE,
     bind_model_tasks = FALSE
   )
 
   tbl <- purrr::map(
     full,
-    ~ dplyr::inner_join(.x, tbl, by = names(tbl))[, names(tbl)] %>%
-      tibble::as_tibble()
+    ~ dplyr::inner_join(.x, tbl, by = names(tbl))[, names(tbl)]
   )
 
   missing_df <- purrr::pmap(
@@ -183,7 +182,7 @@ missing_req_rows <- function(opt_cols, x, mask, req, full, split_req = FALSE) {
   # avoids erroneously returning missing required values that are not applicable
   # to a given model task or output type.
   expected_req <- dplyr::inner_join(req,
-    tibble::as_tibble(applicaple_full[, names(req)]),
+    applicaple_full[, names(req)],
     by = names(req)
   ) %>%
     unique()
@@ -200,7 +199,7 @@ missing_req_rows <- function(opt_cols, x, mask, req, full, split_req = FALSE) {
       unique(x[, opt_cols])
     )[, names(x)]
   } else {
-    tibble::as_tibble(full[1, names(x)])[0, ]
+    full[1, names(x)][0, ]
   }
 }
 

R/cnd_utils.R

@@ -28,3 +28,21 @@ is_info <- function(x) {
 not_pass <- function(x) {
     !inherits(x, "check_success") & !inherits(x, "check_info")
 }
+
+#' @describeIn is_success Is exec error?
+#' @export
+is_exec_error <- function(x) {
+    inherits(x, "check_exec_error")
+}
+
+#' @describeIn is_success Is exec warning?
+#' @export
+is_exec_warn <- function(x) {
+    inherits(x, "check_exec_warn")
+}
+
+#' @describeIn is_success Is error or exec error?
+#' @export
+is_any_error <- function(x) {
+    inherits(x, "check_error") | inherits(x, "check_exec_error")
+}

R/execute_custom_checks.R

@@ -36,5 +36,5 @@ execute_custom_checks <- function(validations_cfg_path = NULL) {
   purrr::map(
     purrr::set_names(names(validations_cfg)),
     ~ exec_cfg_check(.x, validations_cfg, caller_env, caller_call)
-  )
+  ) %>% as_hub_validations()
 }