Improve test suite coverage and validation

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: SPCreporter
 Title: Creates Metric Reports using Statistical Process Control in the NHS style
-Version: 0.2.1
+Version: 0.2.1.9000
 Authors@R: c(
     person("Tom", "Smith",, "tomsmith_uk@hotmail.com", role = c("aut", "cre")),
     person("Fran", "Barton",, "fbarton@alwaysdata.net", role = "aut"))

R/calculate_stale_data.R

@@ -0,0 +1,36 @@
+#' Check whether data is stale
+#'
+#' @param updated_to date. The date of the final day the data relates to.
+#'  Should be provided in "%d-%b-%Y" format
+#' @param lag integer. The number of days of update lag allowable before the
+#'  data is stale
+#' @param cutoff_dttm POSIXct. The datetime of the data cutoff, usually the end
+#'  of the week or month.
+#'
+#' @returns character: "stale" or "fresh"
+#' @noRd
+calculate_stale_data <- function(updated_to, lag, cutoff_dttm) {
+  updated_to <- tryCatch(
+    lubridate::dmy(updated_to),
+    warning = \(w) "calculate_stale_data: The updated_to date is not in the required '%d-%b-%Y' format."
+  )
+
+  assertthat::assert_that(
+    !any(is.na(updated_to)),
+    all(inherits(updated_to, "Date")),
+    msg = "calculate_stale_data: Unable to convert the updated_to argument text to a valid date."
+  )
+
+  assertthat::assert_that(
+    all(lag %% 1 == 0),
+    msg = "calculate_stale_data: The lag argument must be an integer."
+  )
+
+  assertthat::assert_that(
+    all(inherits(cutoff_dttm, "POSIXct")),
+    msg = "calculate_stale_data: The cutoff_dttm argument must be a POSIXct."
+  )
+
+  lag <- lubridate::days(lag) + lubridate::hms("23:59:59") # convert to a period
+  if_else((updated_to + lag) < cutoff_dttm, "stale", "fresh")
+}

R/checking_functions.R

@@ -51,7 +51,7 @@ check_measure_data <- function(measure_data) {
 check_a_data <- function(a_data) {
   assertthat::assert_that(
     inherits(a_data, "list"),
-    msg = "check_measure_data: The data must be a list."
+    msg = "check_a_data: The data must be a list."
   )
 
   # We now only retain data frames from the list if they have a name
@@ -61,12 +61,18 @@ check_a_data <- function(a_data) {
     "day", "week", "month",
     "calendar_year", "financial_year"
     )
+  required_columns <- c("ref", "measure_name", "comment")
+
   a_data |>
     purrr::keep_at(allowed_names) |>
-    purrr::iwalk(
-      \(x, nm) check_for_required_columns(
-        x, nm, required_columns = c("ref", "measure_name", "comment"))
-    )
+    purrr::iwalk(\(x, nm) check_for_required_columns(x, nm, required_columns)) |>
+    purrr::iwalk(\(x, nm) assertthat::assert_that(
+      ncol(x) > length(required_columns),
+      msg = paste0(
+        "measure_data: No date columns found in the '", nm, "' sheet or dataframe. ",
+        "The data must contain at least one and probably more date column(s) (which will contain the data to be plotted)."
+      )
+    ))
 }
 
 
@@ -118,11 +124,6 @@ check_report_config <- function(report_config) {
     "ref", "measure_name", "domain", "spc_chart_type", "aggregation"
   )
 
-  assert_that(
-    !any(is.na(report_config[["aggregation"]])),
-    msg = "check_report_config: Some aggregation values are blank."
-  )
-
   optional_columns <- c("report_comment")
 
   # check required cols are present
@@ -131,7 +132,12 @@ check_report_config <- function(report_config) {
     check_for_optional_columns(optional_columns) |>
     dplyr::select(c(all_of(required_columns), any_of(optional_columns))) |>
     dplyr::distinct() |>
-    dplyr::mutate(across("ref", as.character))
+    dplyr::mutate(
+      across("ref", as.character),
+      across(c("spc_chart_type", "aggregation"), tolower)
+    ) |>
+    check_for_allowed_values("spc_chart_type", c("xmr", "t")) |>
+    check_for_allowed_values("aggregation", c("day", "week", "month", "calendar_year", "financial_year", "none"))
 }
 
 
@@ -189,7 +195,9 @@ check_measure_config <- function(measure_config) {
       # target and allowable_days_lag are the only cols that should end up numeric
       across("target", \(x) as.numeric(dplyr::na_if(x, "-"))),
       across("allowable_days_lag", \(x) as.integer(tidyr::replace_na(x, "0")))
-    )
+    ) |>
+    check_for_allowed_values("improvement_direction", c("increase", "decrease", "neutral")) |>
+    check_for_allowed_values("unit", c("integer", "decimal", "%"))
 }
 
 
@@ -281,6 +289,28 @@ check_for_required_columns <- function(.data, df_name, required_columns) {
 
 
 
+#' Check that a column contains only allowed values
+#'
+#' @param .data A data frame
+#' @param col_name character. The column to validate
+#' @param allowed_values character. The set of permitted values
+#'
+#' @returns The original data frame, or an error if invalid values are found
+#' @noRd
+check_for_allowed_values <- function(.data, col_name, allowed_values) {
+  bad <- setdiff(.data[[col_name]], allowed_values)
+  assertthat::assert_that(
+    length(bad) == 0,
+    msg = paste0(
+      "'", col_name, "' must be one of ",
+      paste(paste0("'", allowed_values, "'"), collapse = ", "), ". ",
+      "Invalid value(s): ", paste(bad, collapse = ", "), "."
+    )
+  )
+  .data
+}
+
+
 #' Certain variables are optional in measure_config. If supplied, we want to
 #' keep them, but if not supplied we want to add them with contents = `NA`.
 #'

R/convert_date.R

@@ -0,0 +1,16 @@
+# This function generates warnings due to the way if_else works with dates
+# We will wrap it in a quietly adverb to handle the warnings, which are not
+# warnings we need to worry about
+convert_date <- function(x) {
+  ymd_regex <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$"
+  if_else(
+    grepl(ymd_regex, x),
+    lubridate::ymd(x),
+    lubridate::as_date(as.numeric(x), origin = "1899-12-30")
+  )
+}
+
+quietly_convert_date <- function(...) {
+  purrr::quietly(convert_date)(...) |>
+    purrr::pluck("result")
+}

R/display_text.R

@@ -0,0 +1,79 @@
+#' Get the character representation of the target
+#'
+#' @param target string/numeric. The target (probably a numeric)
+#' @param improvement_direction string. One of "increase", "decrease", or
+#'  "neutral"
+#' @param unit string. One of "integer", "decimal", or "%"
+#'
+#' @returns A character string suitable for inclusion in the report
+#' @noRd
+get_target_text <- function(target, improvement_direction, unit) {
+  imp_dir <- tolower(improvement_direction)
+
+  string <- dplyr::case_when(
+    is.na(target) ~ "-",
+    imp_dir == "neutral" ~ "Neutral",
+    unit == "%" ~ paste0(round(target * 100, 1), "%"),
+    TRUE ~ as.character(round(target, 2)) # covers decimal and integer
+  )
+
+  dplyr::case_when(
+    target == 0 & imp_dir == "decrease" ~ string,
+    target == 1 & unit == "%" & imp_dir == "increase" ~ string,
+    !is.na(target) & imp_dir == "decrease" ~ paste0("\u2264 ", string),
+    !is.na(target) & imp_dir == "increase" ~ paste0("\u2265 ", string),
+    TRUE ~ string
+  )
+}
+
+
+#' Calculate the updated_to date string
+#'
+#' The `aggregation` parameter is derived from the report config, and should
+#' never be blank (NA).
+#'
+#' @param last_date date.
+#' @param aggregation string. e.g. "month"
+#'
+#' @returns A date in "%d-%b-%Y" (day-month-year) format
+#'
+#' @noRd
+get_updatedto_text <- function(last_date, aggregation) {
+  assert_that(
+    length(last_date) == 1L,
+    msg = "get_updatedto_text: Multiple values for `last_date` provided"
+  )
+  assert_that(
+    length(aggregation) == 1L,
+    msg = "get_updatedto_text: Multiple values for `aggregation` provided"
+  )
+
+  last_date <- as.Date(last_date) # handles dttm being passed in by mistake
+
+  # Rename "calendar_year" and "none" aggregations to work with ceiling_date()
+  agg <- dplyr::case_when(
+    aggregation == "calendar_year" ~ "year",
+    # aggregation == "financial_year" ~ "3 months", # TODO
+    aggregation == "none" ~ "month",
+    .default = aggregation
+  )
+
+  # allowed values
+  assert_that(
+    all(agg %in% c("day", "week", "month", "year")),
+    msg = glue("get_updatedto_text: invalid aggregation ({agg}) provided")
+  )
+
+  # Set start day for week to Monday (1)
+  withr::with_options(list(lubridate.week.start = 1), {
+    dplyr::case_when(
+      # For day aggregation use the day itself
+      agg == "day" ~ last_date,
+      # For all other levels, use a ceiling_date approach to get the end day of
+      # the current period (week, month etc). Event data (agg = "none") is
+      # rounded to the month boundary.
+      .default = lubridate::ceiling_date(last_date, agg) - days(1),
+    ) |>
+      format("%d-%b-%Y")
+  })
+}