From 8e2367b1c2266e9b8a1fec48c75c29a777b1b04c Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 21:27:53 +0100 Subject: [PATCH 01/13] added missing for a date simplification function --- tests/testthat/test-get_updatedto_text.R | 63 ++++++++++++++++++++++++ 1 file changed, 63 insertions(+) create mode 100644 tests/testthat/test-get_updatedto_text.R diff --git a/tests/testthat/test-get_updatedto_text.R b/tests/testthat/test-get_updatedto_text.R new file mode 100644 index 0000000..44553ec --- /dev/null +++ b/tests/testthat/test-get_updatedto_text.R @@ -0,0 +1,63 @@ +test_that("day aggregation returns the date itself", { + expect_equal( + get_updatedto_text(as.Date("2024-03-15"), "day"), + "15-Mar-2024" + ) +}) + +test_that("week aggregation returns the last day of the week (Sunday)", { + # 2024-03-11 is a Monday; week ends Sunday 2024-03-17 + expect_equal( + get_updatedto_text(as.Date("2024-03-11"), "week"), + "17-Mar-2024" + ) +}) + +test_that("month aggregation returns the last day of the month", { + expect_equal( + get_updatedto_text(as.Date("2024-03-15"), "month"), + "31-Mar-2024" + ) +}) + +test_that("calendar_year aggregation returns the last day of the year", { + expect_equal( + get_updatedto_text(as.Date("2024-06-01"), "calendar_year"), + "31-Dec-2024" + ) +}) + +test_that("none aggregation is treated as month", { + expect_equal( + get_updatedto_text(as.Date("2024-03-15"), "none"), + "31-Mar-2024" + ) +}) + +test_that("datetime input is coerced to date", { + expect_equal( + get_updatedto_text(as.POSIXct("2024-03-15 12:34:56"), "month"), + "31-Mar-2024" + ) +}) + +test_that("multiple last_date values error", { + expect_error( + get_updatedto_text(as.Date(c("2024-03-15", "2024-04-15")), "month"), + "Multiple values" + ) +}) + +test_that("multiple aggregation values error", { + expect_error( + get_updatedto_text(as.Date("2024-03-15"), c("month", "week")), + "Multiple values" + ) +}) + +test_that("invalid aggregation errors", { + expect_error( + get_updatedto_text(as.Date("2024-03-15"), "quarter"), + "invalid aggregation" + ) +}) From d5d3c6d1f88def484f903e0c34730567c9d6852a Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 22:14:38 +0100 Subject: [PATCH 02/13] add date conversion tests --- tests/testthat/test-convert_date.R | 46 ++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 tests/testthat/test-convert_date.R diff --git a/tests/testthat/test-convert_date.R b/tests/testthat/test-convert_date.R new file mode 100644 index 0000000..12b295b --- /dev/null +++ b/tests/testthat/test-convert_date.R @@ -0,0 +1,46 @@ +# convert_date uses dplyr::if_else, which evaluates both branches for all +# elements. This means warnings are always generated — quietly_convert_date +# wraps it with purrr::quietly to suppress them. Tests below reflect this. + +test_that("YMD string is converted to the correct date", { + expect_equal( + suppressWarnings(convert_date("2024-03-15")), + as.Date("2024-03-15") + ) +}) + +test_that("Excel numeric date (as character) is converted correctly", { + # Excel stores dates as days since 1899-12-30 + excel_num <- as.character(as.numeric(as.Date("2024-03-15") - as.Date("1899-12-30"))) + expect_equal( + suppressWarnings(convert_date(excel_num)), + as.Date("2024-03-15") + ) +}) + +test_that("convert_date generates warnings due to if_else evaluating both branches", { + expect_warning(convert_date("2024-03-15")) +}) + +test_that("quietly_convert_date returns the correct date without warnings", { + expect_no_warning(quietly_convert_date("2024-03-15")) + expect_equal(quietly_convert_date("2024-03-15"), as.Date("2024-03-15")) +}) + +test_that("quietly_convert_date handles a vector of YMD strings", { + expect_equal( + quietly_convert_date(c("2024-01-01", "2024-06-15", "2023-12-31")), + as.Date(c("2024-01-01", "2024-06-15", "2023-12-31")) + ) +}) + +test_that("quietly_convert_date handles a mixed YMD and Excel numeric vector", { + excel_num <- as.character(as.numeric(as.Date("2024-06-15") - as.Date("1899-12-30"))) + mixed <- c("2024-01-01", excel_num) + + expect_no_warning(quietly_convert_date(mixed)) + expect_equal( + quietly_convert_date(mixed), + as.Date(c("2024-01-01", "2024-06-15")) + ) +}) From 2cf5095b6061066dfff51a1a966c14d48d4cffa8 Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 22:15:13 +0100 Subject: [PATCH 03/13] add integration tests for spcr_make_report --- tests/testthat/test-spcr_make_report.R | 98 ++++++++++++++++++++++++++ 1 file changed, 98 insertions(+) create mode 100644 tests/testthat/test-spcr_make_report.R diff --git a/tests/testthat/test-spcr_make_report.R b/tests/testthat/test-spcr_make_report.R new file mode 100644 index 0000000..c392a92 --- /dev/null +++ b/tests/testthat/test-spcr_make_report.R @@ -0,0 +1,98 @@ +# Integration tests for spcr_make_report(). +# These tests actually render the Rmd and write files to a temp directory. +# They are skipped on CI because rendering takes ~30 seconds. + +"spcr_make_report: html and csv files are created" |> + test_that({ + skip_on_ci() + skip_if( + system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", + "Report.Rmd not found — run devtools::load_all() first" + ) + + mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) + mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) + + db <- spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config + ) + + withr::with_tempdir({ + result <- spcr_make_report( + data_bundle = db, + output_directory = ".", + output_type = c("html", "csv") + ) + + html_files <- list.files(".", pattern = "\\.html$", full.names = TRUE) + csv_files <- list.files(".", pattern = "\\.csv$", full.names = TRUE) + + expect_true(result) + expect_length(html_files, 1) + expect_length(csv_files, 1) + expect_gt(file.size(html_files[[1]]), 0) + expect_gt(file.size(csv_files[[1]]), 0) + }) + }) + + +"spcr_make_report: html-only output creates no csv" |> + test_that({ + skip_on_ci() + skip_if( + system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", + "Report.Rmd not found — run devtools::load_all() first" + ) + + mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) + mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) + + db <- spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config + ) + + withr::with_tempdir({ + spcr_make_report( + data_bundle = db, + output_directory = ".", + output_type = "html" + ) + + expect_length(list.files(".", pattern = "\\.html$"), 1) + expect_length(list.files(".", pattern = "\\.csv$"), 0) + }) + }) + + +"spcr_make_report: returns invisible TRUE" |> + test_that({ + skip_on_ci() + skip_if( + system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", + "Report.Rmd not found — run devtools::load_all() first" + ) + + mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) + mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) + + db <- spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config + ) + + withr::with_tempdir({ + result <- withVisible(spcr_make_report( + data_bundle = db, + output_directory = ".", + output_type = "html" + )) + + expect_true(result$value) + expect_false(result$visible) + }) + }) From 39b8457678ebe9e5ce45cdc476d49621a5b77048 Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 22:36:52 +0100 Subject: [PATCH 04/13] add align rebase dates tests --- tests/testthat/test-align_rebase_dates.R | 56 ++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 tests/testthat/test-align_rebase_dates.R diff --git a/tests/testthat/test-align_rebase_dates.R b/tests/testthat/test-align_rebase_dates.R new file mode 100644 index 0000000..edaa231 --- /dev/null +++ b/tests/testthat/test-align_rebase_dates.R @@ -0,0 +1,56 @@ +make_measure_data <- function(dates) { + tibble::tibble(date = lubridate::ymd(dates)) +} + +"align_rebase_dates: rebase date that exactly matches a data date is unchanged" |> + test_that({ + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + expect_equal( + align_rebase_dates("2022-02-01", md), + as.Date("2022-02-01") + ) + }) + + +"align_rebase_dates: rebase date between data dates is rounded up to next data date" |> + test_that({ + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + # 2022-01-15 falls between Jan and Feb data points -> rounds up to Feb + expect_equal( + align_rebase_dates("2022-01-15", md), + as.Date("2022-02-01") + ) + }) + + +"align_rebase_dates: rebase date after all data dates is returned as-is" |> + test_that({ + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + # No data date >= 2022-06-01, so the rebase date is returned unchanged + expect_equal( + align_rebase_dates("2022-06-01", md), + as.Date("2022-06-01") + ) + }) + + +"align_rebase_dates: multiple rebase dates are each aligned independently" |> + test_that({ + md <- make_measure_data(paste0("2022-0", 1:6, "-01")) + # "2022-03-17" -> 2022-04-01 (next data date) + # "2022-05-01" -> 2022-05-01 (exact match) + # "2022-06-02" -> 2022-06-02 (after all data, returned as-is) + expect_equal( + align_rebase_dates('"2022-03-17", "2022-05-01", "2022-06-02"', md), + as.Date(c("2022-04-01", "2022-05-01", "2022-06-02")) + ) + }) + + +"align_rebase_dates: NA input returns an empty or NA result" |> + test_that({ + md <- make_measure_data(c("2022-01-01", "2022-02-01")) + result <- align_rebase_dates(NA_character_, md) + # parse_rebase_dates(NA) returns NULL; map_vec over NULL gives empty/NA + expect_true(length(result) == 0 || all(is.na(result))) + }) From c0ac6da85f57f05713966e2a9361a7af2c854509 Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 22:45:06 +0100 Subject: [PATCH 05/13] split helper functions out into individual files --- R/calculate_stale_data.R | 36 ++++ R/convert_date.R | 16 ++ R/display_text.R | 81 +++++++++ R/helper_functions.R | 341 -------------------------------------- R/lengthen_measure_data.R | 51 ++++++ R/rebase_dates.R | 65 ++++++++ R/spc_classification.R | 68 ++++++++ 7 files changed, 317 insertions(+), 341 deletions(-) create mode 100644 R/calculate_stale_data.R create mode 100644 R/convert_date.R create mode 100644 R/display_text.R delete mode 100644 R/helper_functions.R create mode 100644 R/lengthen_measure_data.R create mode 100644 R/rebase_dates.R create mode 100644 R/spc_classification.R diff --git a/R/calculate_stale_data.R b/R/calculate_stale_data.R new file mode 100644 index 0000000..a583490 --- /dev/null +++ b/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") +} diff --git a/R/convert_date.R b/R/convert_date.R new file mode 100644 index 0000000..d81dda8 --- /dev/null +++ b/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") +} diff --git a/R/display_text.R b/R/display_text.R new file mode 100644 index 0000000..03f9f1b --- /dev/null +++ b/R/display_text.R @@ -0,0 +1,81 @@ +#' 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: ≤ + !is.na(target) & imp_dir == "decrease" ~ paste0("≤ ", string), + # ≥ is: ≥ + !is.na(target) & imp_dir == "increase" ~ paste0("≥ ", 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") + }) +} diff --git a/R/helper_functions.R b/R/helper_functions.R deleted file mode 100644 index 80a6e08..0000000 --- a/R/helper_functions.R +++ /dev/null @@ -1,341 +0,0 @@ -#' Transform aggregated data from wide to long format -#' -#' @param .data data frame. Data frame in wide format -#' -#' @returns data frame. Data frame in long format -#' @noRd -lengthen_measure_data <- function(.data) { - assertthat::assert_that( - inherits(.data, "data.frame"), - msg = "lengthen_measure_data: The data must be a data frame." - ) - - # Should match date strings of the form 2022-06-01 - ymd_regex <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$" - init_cols <- c("aggregation", "measure_prefix", "ref", "measure_name", "comment") - - assertthat::assert_that( - all(purrr::map_lgl( - names(.data), \(x) x %in% init_cols | - stringr::str_detect(x, "^[0-9]{5}$") | - stringr::str_detect(x, ymd_regex) - )), - msg = usethis::ui_stop( - paste( - "lengthen_measure_data: The measure_data supplied contains", - "invalid column headings. The only column headings allowed are", - stringr::str_flatten_comma(paste0("'", init_cols, "'")), - "and valid date formats.", - "One invalid column name found is:", - head( - stringr::str_subset( - setdiff(names(.data), init_cols), - stringr::str_glue("^[0-9]{5}$|{ymd_regex}"), - negate = TRUE - ), - 1 - ), - collapse = " " - ) - ) - ) - - # pivot incoming measure_data from wide to long, - # and convert date column to date format - .data |> - tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) |> - dplyr::mutate(across("date", quietly_convert_date)) |> - # Sort data from oldest to latest by measure - it should already be sorted - # (pivot_longer draws from L-R wide data)... but let's make sure - dplyr::arrange(across(all_of(c("ref", "date")))) -} - - - - - -#' 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, - # \u2264 is: ≤ - !is.na(target) & imp_dir == "decrease" ~ paste0("\u2264 ", string), - # \u2265 is: ≥ - !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") - }) -} - - -# 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") -} - - -#' Parse rebase dates -#' Parse dates from the config spreadsheet into a format suitable for use in -#' the SPC calculation function. Only needed as a helper function for -#' `align_rebase_dates()` -#' -#' @param input character. A vector of length 1, containing quoted dates in ymd -#' format, separated with commas eg '"2020-01-01", "2020-03-05"' -#' -#' @returns A vector of dates -#' @noRd -parse_rebase_dates <- function(input) { - if (is.na(input)) { - NULL - } else { - # parse into individual character strings - vector <- input |> - stringr::str_split_1("\\s*,\\s*") |> - stringr::str_remove_all("\\\"") |> # remove internal quotes - stringr::str_trim() # trim white space - - # wrap the date parsing in tryCatch() to stop() - # if excel dates are not perfectly formed. - tryCatch( - lubridate::ymd(vector), - error = function(c) stop("error in parse_rebase_dates: ", c), - warning = function(c) { - stop( - "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." - ) - } - ) - } -} - - - -#' Align rebase date to match next data date after rebase, if does not already -#' match a date from the relevant data. -#' This is because plots were not showing rebase changes if the rebase date -#' did not match a date in the data for that measure. -#' https://github.com/ThomUK/SPCreporter/issues/35 -#' -#' @inheritParams parse_rebase_dates -#' @param measure_data data frame containing a column of date values -#' -#' @returns a vector of dates, amended as necessary, or NA if no dates were -#' present initially -#' @noRd -align_rebase_dates <- function(input, measure_data) { - dates <- parse_rebase_dates(input) - dates_vec <- as.Date(measure_data[["date"]]) - - # "Round up" a rebase date to match the earliest date in the measure data that - # is equal to or greater than the rebase date. - pull_closest_date <- function(date, dates_list = dates_vec) { - if (is.null(date)) { - NA - } else { - later_dates <- dates_list[dates_list >= date] - if (length(later_dates)) min(later_dates) else date - } - } - - dates |> - purrr::map_vec(pull_closest_date) -} - - - - -#' Find the name of the assurance type -#' -#' @param spc data frame. As returned from the {NHSRplotthedots} SPC package -#' @param improvement_direction string. "Increase", "Decrease", or "Neutral" -#' -#' @returns string. Name of the assurance type -#' @noRd -get_assurance_type <- function(spc, improvement_direction) { - imp_dir <- tolower(improvement_direction) - upl <- tail(spc[["upl"]], 1) - lpl <- tail(spc[["lpl"]], 1) - target <- tail(spc[["target"]], 1) - - a <- dplyr::case_when( - imp_dir == "neutral" ~ "Neutral", - is.na(target) | is.na(lpl) | is.na(upl) ~ "No target", - dplyr::between(target, lpl, upl) ~ "RND_TARG", - lpl > target & imp_dir == "increase" ~ "PASS_TARG", - upl < target & imp_dir == "decrease" ~ "PASS_TARG", - lpl > target & imp_dir == "decrease" ~ "FAIL_TARG", - upl < target & imp_dir == "increase" ~ "FAIL_TARG", - TRUE ~ "" - ) - - if (a == "") { - usethis::ui_stop( - "get_assurance_type: Unable to determine SPC assurance type." - ) - } - a -} - - -#' Find the name of the variation type -#' -#' @param spc data frame. As returned from the {NHSRplotthedots} SPC package -#' @param improvement_direction string. "Increase", "Decrease", or "Neutral" -#' -#' @return string. Name of the variation type -#' @noRd -#' -get_variation_type <- function(spc, improvement_direction) { - vari <- tail(spc[["point_type"]], 1) - relative_to_mean <- tail(spc[["relative_to_mean"]], 1) - # need to provide a default value so the case_when works - if (is.null(relative_to_mean)) relative_to_mean <- 0 - imp_dir <- tolower(improvement_direction) - - v <- dplyr::case_when( - vari == "common_cause" ~ "CC", - vari == "special_cause_improvement" & imp_dir == "increase" ~ "SC_HI_IMP", - vari == "special_cause_improvement" & imp_dir == "decrease" ~ "SC_LO_IMP", - vari == "special_cause_concern" & imp_dir == "increase" ~ "SC_LO_CON", - vari == "special_cause_concern" & imp_dir == "decrease" ~ "SC_HI_CON", - vari == "special_cause_neutral" & relative_to_mean == -1 ~ "SC_LO_NEUTRAL", - vari == "special_cause_neutral" & relative_to_mean %in% c(1, 0) ~ "SC_HI_NEUTRAL", - vari == "special_cause_neutral_low" ~ "SC_LO_NEUTRAL", - vari == "special_cause_neutral_high" ~ "SC_HI_NEUTRAL", - TRUE ~ "" - ) - - if (v == "") { - usethis::ui_stop( - "get_variation_type: Unable to determine SPC variation type." - ) - } - v -} - - - - - - - - -#' 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") -} diff --git a/R/lengthen_measure_data.R b/R/lengthen_measure_data.R new file mode 100644 index 0000000..cf61a57 --- /dev/null +++ b/R/lengthen_measure_data.R @@ -0,0 +1,51 @@ +#' Transform aggregated data from wide to long format +#' +#' @param .data data frame. Data frame in wide format +#' +#' @returns data frame. Data frame in long format +#' @noRd +lengthen_measure_data <- function(.data) { + assertthat::assert_that( + inherits(.data, "data.frame"), + msg = "lengthen_measure_data: The data must be a data frame." + ) + + # Should match date strings of the form 2022-06-01 + ymd_regex <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$" + init_cols <- c("aggregation", "measure_prefix", "ref", "measure_name", "comment") + + assertthat::assert_that( + all(purrr::map_lgl( + names(.data), \(x) x %in% init_cols | + stringr::str_detect(x, "^[0-9]{5}$") | + stringr::str_detect(x, ymd_regex) + )), + msg = usethis::ui_stop( + paste( + "lengthen_measure_data: The measure_data supplied contains", + "invalid column headings. The only column headings allowed are", + stringr::str_flatten_comma(paste0("'", init_cols, "'")), + "and valid date formats.", + "One invalid column name found is:", + head( + stringr::str_subset( + setdiff(names(.data), init_cols), + stringr::str_glue("^[0-9]{5}$|{ymd_regex}"), + negate = TRUE + ), + 1 + ), + collapse = " " + ) + ) + ) + + # pivot incoming measure_data from wide to long, + # and convert date column to date format + .data |> + tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) |> + dplyr::mutate(across("date", quietly_convert_date)) |> + # Sort data from oldest to latest by measure - it should already be sorted + # (pivot_longer draws from L-R wide data)... but let's make sure + dplyr::arrange(across(all_of(c("ref", "date")))) +} diff --git a/R/rebase_dates.R b/R/rebase_dates.R new file mode 100644 index 0000000..16e9c26 --- /dev/null +++ b/R/rebase_dates.R @@ -0,0 +1,65 @@ +#' Parse rebase dates +#' Parse dates from the config spreadsheet into a format suitable for use in +#' the SPC calculation function. Only needed as a helper function for +#' `align_rebase_dates()` +#' +#' @param input character. A vector of length 1, containing quoted dates in ymd +#' format, separated with commas eg '"2020-01-01", "2020-03-05"' +#' +#' @returns A vector of dates +#' @noRd +parse_rebase_dates <- function(input) { + if (is.na(input)) { + NULL + } else { + # parse into individual character strings + vector <- input |> + stringr::str_split_1("\\s*,\\s*") |> + stringr::str_remove_all("\\\"") |> # remove internal quotes + stringr::str_trim() # trim white space + + # wrap the date parsing in tryCatch() to stop() + # if excel dates are not perfectly formed. + tryCatch( + lubridate::ymd(vector), + error = function(c) stop("error in parse_rebase_dates: ", c), + warning = function(c) { + stop( + "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." + ) + } + ) + } +} + + +#' Align rebase date to match next data date after rebase, if does not already +#' match a date from the relevant data. +#' This is because plots were not showing rebase changes if the rebase date +#' did not match a date in the data for that measure. +#' https://github.com/ThomUK/SPCreporter/issues/35 +#' +#' @inheritParams parse_rebase_dates +#' @param measure_data data frame containing a column of date values +#' +#' @returns a vector of dates, amended as necessary, or NA if no dates were +#' present initially +#' @noRd +align_rebase_dates <- function(input, measure_data) { + dates <- parse_rebase_dates(input) + dates_vec <- as.Date(measure_data[["date"]]) + + # "Round up" a rebase date to match the earliest date in the measure data that + # is equal to or greater than the rebase date. + pull_closest_date <- function(date, dates_list = dates_vec) { + if (is.null(date)) { + NA + } else { + later_dates <- dates_list[dates_list >= date] + if (length(later_dates)) min(later_dates) else date + } + } + + dates |> + purrr::map_vec(pull_closest_date) +} diff --git a/R/spc_classification.R b/R/spc_classification.R new file mode 100644 index 0000000..b81f271 --- /dev/null +++ b/R/spc_classification.R @@ -0,0 +1,68 @@ +#' Find the name of the assurance type +#' +#' @param spc data frame. As returned from the {NHSRplotthedots} SPC package +#' @param improvement_direction string. "Increase", "Decrease", or "Neutral" +#' +#' @returns string. Name of the assurance type +#' @noRd +get_assurance_type <- function(spc, improvement_direction) { + imp_dir <- tolower(improvement_direction) + upl <- tail(spc[["upl"]], 1) + lpl <- tail(spc[["lpl"]], 1) + target <- tail(spc[["target"]], 1) + + a <- dplyr::case_when( + imp_dir == "neutral" ~ "Neutral", + is.na(target) | is.na(lpl) | is.na(upl) ~ "No target", + dplyr::between(target, lpl, upl) ~ "RND_TARG", + lpl > target & imp_dir == "increase" ~ "PASS_TARG", + upl < target & imp_dir == "decrease" ~ "PASS_TARG", + lpl > target & imp_dir == "decrease" ~ "FAIL_TARG", + upl < target & imp_dir == "increase" ~ "FAIL_TARG", + TRUE ~ "" + ) + + if (a == "") { + usethis::ui_stop( + "get_assurance_type: Unable to determine SPC assurance type." + ) + } + a +} + + +#' Find the name of the variation type +#' +#' @param spc data frame. As returned from the {NHSRplotthedots} SPC package +#' @param improvement_direction string. "Increase", "Decrease", or "Neutral" +#' +#' @return string. Name of the variation type +#' @noRd +#' +get_variation_type <- function(spc, improvement_direction) { + vari <- tail(spc[["point_type"]], 1) + relative_to_mean <- tail(spc[["relative_to_mean"]], 1) + # need to provide a default value so the case_when works + if (is.null(relative_to_mean)) relative_to_mean <- 0 + imp_dir <- tolower(improvement_direction) + + v <- dplyr::case_when( + vari == "common_cause" ~ "CC", + vari == "special_cause_improvement" & imp_dir == "increase" ~ "SC_HI_IMP", + vari == "special_cause_improvement" & imp_dir == "decrease" ~ "SC_LO_IMP", + vari == "special_cause_concern" & imp_dir == "increase" ~ "SC_LO_CON", + vari == "special_cause_concern" & imp_dir == "decrease" ~ "SC_HI_CON", + vari == "special_cause_neutral" & relative_to_mean == -1 ~ "SC_LO_NEUTRAL", + vari == "special_cause_neutral" & relative_to_mean %in% c(1, 0) ~ "SC_HI_NEUTRAL", + vari == "special_cause_neutral_low" ~ "SC_LO_NEUTRAL", + vari == "special_cause_neutral_high" ~ "SC_HI_NEUTRAL", + TRUE ~ "" + ) + + if (v == "") { + usethis::ui_stop( + "get_variation_type: Unable to determine SPC variation type." + ) + } + v +} From 74a38b3a37751e9e3a5f606bb21784c3c9202b94 Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 22:47:23 +0100 Subject: [PATCH 06/13] remove file --- reprex.R | 395 ------------------------------------------------------- 1 file changed, 395 deletions(-) delete mode 100644 reprex.R diff --git a/reprex.R b/reprex.R deleted file mode 100644 index 170843a..0000000 --- a/reprex.R +++ /dev/null @@ -1,395 +0,0 @@ -cutoff_date <- lubridate::floor_date(Sys.Date(), unit = "month") - lubridate::as.period("1d") -cutoff_dttm <- (cutoff_date + 1) - lubridate::as.period("1s") -data_cutoff_dttm <- cutoff_dttm -def_start_date <- lubridate::as_datetime("2020-01-01") -bnet_start <- lubridate::as_datetime("2022-12-01") -m_prefix <- "fh_m" -prefix <- \(x, mp = m_prefix) paste0(mp, "_", x) - - -rep_config <- "Maternity_Services_Report" |> - FH027MaternityReporting::get_report_config() |> - dplyr::filter(if_any("ref", \(x) x %in% c("6", "132", "197"))) - -measure_config <- FH027MaternityReporting::get_measure_config() |> - dplyr::filter(if_any("measure_prefix", \(x) x == m_prefix)) - - -report_refs <- sort(unique(as.numeric(rep_config[["ref"]]))) -completed_refs <- unique(c( - 57, 74, 85, 90, 118, 132, 172, 195:196, 203:205, # excel - 197, 250, # eobs - 75:77, 79:81, 84, 86:88, 104, 108, 194, # datix - # 43, 48, 50, 53:55, 174, 320, # misc other long - 53:55, # hie - # 45, 200, # kilometrics - 33, 40, 62, 63 # medway -)) -bnet_refs <- prefix(setdiff(report_refs, completed_refs)) - -bnet_config <- rep_config |> - dplyr::filter(if_any("measure_id", \(x) x %in% bnet_refs)) - - -bnet_data <- DataHoover::dh_build_report_dataset( - measure_config = measure_config, - report_config = bnet_config, - start_dttm = bnet_start, - end_dttm = cutoff_dttm, - output_format = "long" -) - -bnet_event_refs <- prefix(c( - 2:3, 8, 11, 13, 15, 31, 37, 39, 161:162, 178, 180, 207:212, 222:223, - 257, 261:262, 265:267, 269:270, 273:281, 311, 316:317 -)) - -bnet_data_out <- bnet_data[["event_lists"]] |> - purrr::keep_at(as.character(bnet_event_refs)) |> - purrr::map(\(x) DataHoover::dh_aggregate(x, bnet_start, cutoff_dttm, "month")) |> - purrr::list_rbind() |> - dplyr::bind_rows(bnet_data[["month"]]) |> - dplyr::rename_with(tolower) |> - dplyr::rename(ref = "measure_ref") |> - # 'kilometrics': - dplyr::mutate( - across("value", - \(x) dplyr::if_else( - .data[["ref"]] %in% c("45", "200") & .data[["date"]] >= bnet_start, - x * 1000, - x - ) - ) - ) - -cf_id_cols <- c("measure_prefix", "ref", "measure_name", "comment") -cf_cutoff <- lubridate::ymd("2022-11-01") - -cf_refs <- c(2, 43, 45, 48, 50, 161, 174, 200, 267, 320) - -xl6_data <- "Careflow Data" |> - FH027MaternityReporting:::create_network_path() |> - FH027MaternityReporting:::read_sheet("month") |> - dplyr::mutate(across("ref", as.character)) |> - dplyr::mutate(comment = "Read in from Careflow Data Excel file.") |> - dplyr::mutate(measure_prefix = "fh_m", .before = "ref") |> - dplyr::select(all_of(cf_id_cols) | matches("^\\d{4}\\-\\d{2}\\-\\d{2}$")) |> - tidyr::pivot_longer( - cols = !any_of(cf_id_cols), - names_to = "date", - names_transform = list(date = as.POSIXct) - ) |> - dplyr::filter(if_any("date", \(x) x <= cf_cutoff)) |> - dplyr::filter(if_any("value", \(x) !is.na(x))) |> - dplyr::filter(if_any("ref", \(x) x %in% as.character(cf_refs))) - - - if ("132" %in% rep_config[["ref"]]) { - xl2_data <- "Maternal Deaths" |> - FH027MaternityReporting:::create_network_path() |> - FH027MaternityReporting:::read_sheet("none") |> - dplyr::mutate(Measure_Prefix = "fh_m", .before = "Measure_Ref") |> - dplyr::mutate(across("Measure_Ref", as.character)) - assertthat::assert_that(identical(names(xl2_data), tb_cols)) -} else { - xl2_data <- NULL -} - - -eobs_st <- lubridate::as_datetime("2021-03-01") -eobs_refs <- prefix(c(197, 250)) -# nums & denoms for M197 & M250: -eobs_event_refs <- prefix(251:254) -eobs_config <- rep_config |> - dplyr::filter(if_any("measure_id", \(x) x %in% eobs_refs)) - - -if (nrow(eobs_config) > 0) { - eobs_data <- DataHoover::dh_build_report_dataset( - measure_config = measure_config, - report_config = eobs_config, - start_dttm = eobs_st, - end_dttm = cutoff_dttm, - aggregation_levels = "month", - output_format = "long" - ) - eobs_data_out <- eobs_data[["event_lists"]] |> - purrr::keep_at(eobs_event_refs) |> - purrr::map(\(x) DataHoover::dh_aggregate(x, eobs_st, cutoff_dttm, "month")) |> - purrr::list_rbind() |> - dplyr::bind_rows(eobs_data[["month"]]) |> - dplyr::rename_with(tolower) |> - dplyr::rename(ref = "measure_ref") - assertthat::assert_that(identical(names(eobs_data_out), pref_cols)) -} else { - eobs_data_out <- NULL -} - -rare_refs <- rep_config |> - dplyr::filter(if_any("spc_chart_type", \(x) x == "t")) |> - dplyr::pull("ref") |> - unique() -pref_rare_refs <- prefix(rare_refs) - - - - -rare_data <- list( - bnet_data[["event_lists"]] -) |> - purrr::list_flatten() |> - purrr::keep_at(pref_rare_refs) |> - purrr::list_rbind() |> - dplyr::bind_rows(xl2_data) |> - dplyr::filter(if_any("Measure_Ref", \(x) x %in% rare_refs)) - -if (nrow(rare_data) == 0) { - rare_data <- tibble::tibble( - measure_prefix = character(), - ref = character(), - measure_name = character(), - comment = character(), - event_date_or_datetime = as.Date(character()) - ) -} else { - rare_data <- rare_data |> - dplyr::rename_with(tolower) |> - dplyr::arrange(pick(c("measure_ref", "dttm"))) |> - dplyr::select(all_of(c( - "measure_prefix", - ref = "measure_ref", - "measure_name", - "comment", - "id", - event_date_or_datetime = "dttm") - )) |> - dplyr::distinct() -} - -main_data <- FH027MaternityReporting::get_main_data(report_config = rep_config) - - - -mc_cols <- c("measure_prefix", "ref", "measure_name", "numerator_ref", "denominator_ref") -core_cols <- c("ref", "measure_name", "comment", "date", "value") -pref_cols <- c("measure_prefix", core_cols) -tb_cols <- c("Measure_Prefix", "Measure_Ref", "Measure_Name", "Comment", "ID", "DTTM") -ignore_refs <- c( - "x", as.character(c(2, 43:44, 48:50, 53:57, 64, 74:77, 102, 132, 187, 320)) - ) -da_id_cols <- c("measure_prefix", "ref", "measure_name", "comment") -da_cutoff <- lubridate::ymd("2022-11-01") - - -xl5_data <- "Division Analyst" |> - FH027MaternityReporting:::create_network_path() |> - FH027MaternityReporting:::read_sheet("month") |> - dplyr::mutate(across("ref", as.character)) |> - dplyr::filter(if_any("ref", \(x) !x %in% ignore_refs)) |> - dplyr::mutate(measure_prefix = "fh_m", .before = "ref") |> - dplyr::mutate(comment = "Read in from Division Analyst Excel file.") |> - dplyr::select(all_of(da_id_cols) | matches("^[0-9]+$")) |> - tidyr::pivot_longer( - cols = !any_of(da_id_cols), - names_to = "date", - names_transform = list( - date = \(x) as.Date(as.integer(x), origin = "1899-12-30") - ) - ) |> - dplyr::filter(if_any("date", \(x) x <= da_cutoff)) |> - dplyr::filter(if_any("value", \(x) !is.na(x))) |> - dplyr::filter(if_any("ref", \(x) x == "6")) - - -bnet_data <- DataHoover::dh_build_report_dataset( - measure_config = measure_config, - report_config = rep_config, - start_dttm = bnet_start, - end_dttm = cutoff_dttm, - output_format = "long" - ) -bnet_data_out <- bnet_data[["month"]] |> - dplyr::rename_with(tolower) |> - dplyr::rename(ref = "measure_ref") - - -src_data <- list( - xl5_data, # DA spreadsheet - bnet_data_out, - eobs_data_out -) |> - dplyr::bind_rows() |> - dplyr::distinct() - -src_data_wide <- src_data |> - dplyr::select(all_of(pref_cols)) |> - dplyr::distinct() |> - dplyr::mutate( - across("comment", \(x) stringr::str_flatten(unique(x), " / ")), - .by = c("measure_prefix", "ref") - ) |> - dplyr::distinct() |> - dplyr::arrange(date) |> - tidyr::pivot_wider(names_from = "date") |> - dplyr::arrange(as.numeric(grep("\\d+", .data[["ref"]], value = TRUE))) - - -n_months <- lubridate::interval(def_start_date, cutoff_date) |> - lubridate::as.period("months") |> - stringr::str_extract("^\\d+") |> - as.numeric() -assertthat::assert_that( - ncol(src_data_wide) == (n_months + 1) + (length(pref_cols) - 2) -) - -main_data <- list(month = src_data_wide, events = rare_data) - - -main_bundle <- FH027MaternityReporting::generate_main_bundle( - main_data = main_data, - report_config = rep_config, - measure_config = measure_config -) - -FH027MaternityReporting::generate_main_report( - data_bundle = main_bundle, - report_config = rep_config, - measure_config = measure_config -) - - -rbds <- main_bundle[["rebase_dates"]] -rbds - -parse_rebase_dates(rbds) -rbds_dates <- purrr::map(rbds, parse_rebase_dates) -m_data <- main_bundle[["measure_data"]] - -pull_closest_date <- function(date, dates_list) { - if (is.null(date)) NA - else { - later_dates <- dates_list[dates_list >= date] - if (length(later_dates)) min(later_dates) else date - } -} - -rbds_dates |> - purrr::map2_dbl(m_data, \(x, y) pull_closest_date(x, y[["date"]])) |> - lubridate::as_datetime() |> - lubridate::as_date() - - - -# --- - - -main_data <- FH027MaternityReporting::get_main_data() - -report_config <- "Maternity_Services_Report" |> - FH027MaternityReporting:::get_report_config() -measure_config <- FH027MaternityReporting:::get_measure_config() |> - dplyr::filter(if_any("measure_prefix", \(x) x == m_prefix)) - -data_cutoff_dttm <- (cutoff_date + 1) - lubridate::as.period("1s") - -measure_data <- check_measure_data(main_data) -report_config <- check_report_config(report_config) -measure_config <- check_measure_config(measure_config) - - -e_data <- measure_data |> - purrr::pluck("events") -a_data <- measure_data |> - purrr::discard_at("events") -a_data <- check_a_data(a_data) -e_data <- check_e_data(e_data) -e_data_time_between <- process_event_data_t(e_data, data_cutoff_dttm) - - -a_data_df <- a_data |> - dplyr::bind_rows(.id = "aggregation") - -measure_data_long <- a_data_df |> - lengthen_measure_data() |> - dplyr::bind_rows(e_data_time_between) -check_dataset_is_complete(report_config, measure_data_long) - -report_config |> - dplyr::pull("ref") |> - purrr::walk(\(x) check_measure_names(x, measure_data_long, measure_config)) - - -nested_data1 <- report_config |> - # use measure names from report_config not from measure_config - dplyr::left_join(dplyr::select(measure_config, !"measure_name"), "ref") |> - dplyr::mutate( - measure_name = dplyr::case_when( - spc_chart_type == "t" ~ paste(measure_name, "(time-between)"), - TRUE ~ measure_name - ) - ) -nested_data2 <- nested_data1 |> - dplyr::nest_join( - measure_data_long, - by = c("ref", "aggregation"), - name = "measure_data" - ) |> - - # pull most recent date from each data frame in the measure_data column - dplyr::mutate( - data_cutoff_dttm = as.POSIXct(data_cutoff_dttm), - last_date = purrr::map_vec(.data[["measure_data"]], \(x) max(x[["date"]], na.rm = TRUE)) - ) -nested_data3 <- nested_data2 |> - # pull most recent data point from each data frame in the measure_data column - dplyr::mutate( - last_data_point = purrr::map_vec(.data[["measure_data"]], \(x) { - dplyr::slice_max(x, order_by = x[["date"]], n = 1)[["value"]] - } - ) - ) -nested_data3 |> - dplyr::mutate( - across("improvement_direction", - \(x) dplyr::case_when( - .data[["spc_chart_type"]] == "t" & x == "decrease" ~ "increase", - # a rather unlikely situation - .data[["spc_chart_type"]] == "t" & x == "increase" ~ "decrease", - TRUE ~ x)) - ) |> - dplyr::mutate( - across("unit", - \(x) if_else(.data[["spc_chart_type"]] == "t", "days", x)) - ) |> - dplyr::mutate( - across("target", - \(x) if_else(.data[["spc_chart_type"]] == "t", NA, x)) - ) |> - dplyr::mutate( - across("last_data_point", \(x) dplyr::case_when( - is.na(x) ~ NA_character_, - x == Inf ~ NA_character_, - unit == "%" ~ paste0(round(x * 100, 1), "%"), - unit == "decimal" ~ as.character(round(x, 2)), - unit == "days" ~ paste0(x, "d"), - TRUE ~ as.character(round(x)))) - ) |> - dplyr::mutate( - target_text = get_target_text( - .data[["target"]], - .data[["improvement_direction"]], - .data[["unit"]] - ), - updated_to = get_updatedto_text( - .data[["last_date"]], - .data[["aggregation"]] - ) - ) - - - -main_bundle <- FH027MaternityReporting::generate_main_bundle() - -View(main_bundle) - - From 599eb93d93980fbbbcadfd9dfb97d38573ff83ac Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 23:12:49 +0100 Subject: [PATCH 07/13] remove duplicate tests --- tests/testthat/test-get_updatedto_text.R | 156 ++++++++++++++--------- tests/testthat/test-helper_functions.R | 110 ---------------- tests/testthat/test-parse_rebase_dates.R | 43 ------- 3 files changed, 93 insertions(+), 216 deletions(-) delete mode 100644 tests/testthat/test-helper_functions.R diff --git a/tests/testthat/test-get_updatedto_text.R b/tests/testthat/test-get_updatedto_text.R index 44553ec..be6928d 100644 --- a/tests/testthat/test-get_updatedto_text.R +++ b/tests/testthat/test-get_updatedto_text.R @@ -1,63 +1,93 @@ -test_that("day aggregation returns the date itself", { - expect_equal( - get_updatedto_text(as.Date("2024-03-15"), "day"), - "15-Mar-2024" - ) -}) - -test_that("week aggregation returns the last day of the week (Sunday)", { - # 2024-03-11 is a Monday; week ends Sunday 2024-03-17 - expect_equal( - get_updatedto_text(as.Date("2024-03-11"), "week"), - "17-Mar-2024" - ) -}) - -test_that("month aggregation returns the last day of the month", { - expect_equal( - get_updatedto_text(as.Date("2024-03-15"), "month"), - "31-Mar-2024" - ) -}) - -test_that("calendar_year aggregation returns the last day of the year", { - expect_equal( - get_updatedto_text(as.Date("2024-06-01"), "calendar_year"), - "31-Dec-2024" - ) -}) - -test_that("none aggregation is treated as month", { - expect_equal( - get_updatedto_text(as.Date("2024-03-15"), "none"), - "31-Mar-2024" - ) -}) - -test_that("datetime input is coerced to date", { - expect_equal( - get_updatedto_text(as.POSIXct("2024-03-15 12:34:56"), "month"), - "31-Mar-2024" - ) -}) - -test_that("multiple last_date values error", { - expect_error( - get_updatedto_text(as.Date(c("2024-03-15", "2024-04-15")), "month"), - "Multiple values" - ) -}) - -test_that("multiple aggregation values error", { - expect_error( - get_updatedto_text(as.Date("2024-03-15"), c("month", "week")), - "Multiple values" - ) -}) - -test_that("invalid aggregation errors", { - expect_error( - get_updatedto_text(as.Date("2024-03-15"), "quarter"), - "invalid aggregation" - ) -}) +# These two tests document the dttm coercion bug fixed in March 2024. +# ceiling_date() on a datetime gives a different result than on a date, +# so the function must coerce to Date first. + +"updatedto_text handles dttms correctly 1" |> + test_that({ + d1 <- lubridate::as_date("2024-02-01") + d2 <- lubridate::as_datetime("2024-02-01") + + desired_result <- lubridate::as_date("2024-02-29") + unwanted_result <- lubridate::as_datetime("2024-01-31 23:59:59") + + aggregation <- "month" + + o1 <- lubridate::ceiling_date(d1, aggregation) - 1 + o2 <- lubridate::ceiling_date(d2, aggregation) - 1 + + expect_equal(o1, desired_result) + expect_false(identical(o2, desired_result)) + expect_equal(o2, unwanted_result) + }) + + +"updatedto_text handles dttms correctly 2" |> + test_that({ + d1 <- lubridate::as_date("2024-02-01") + d2 <- lubridate::as_datetime("2024-02-01") + + # the function needs to operate on a date not a datetime + d1 <- as.Date(d1) + d2 <- as.Date(d2) + + desired_result <- lubridate::as_date("2024-02-29") + + aggregation <- "month" + + o1 <- lubridate::ceiling_date(d1, aggregation) - lubridate::days(1) + o2 <- lubridate::ceiling_date(d2, aggregation) - lubridate::days(1) + + expect_equal(o1, desired_result) + expect_equal(o2, desired_result) + }) + + +"get_updatedto_text: all aggregation types - Thursday date" |> + test_that({ + d1 <- lubridate::as_date("2024-02-01") # A Thursday + + expect_identical(get_updatedto_text(d1, "none"), "29-Feb-2024") + expect_identical(get_updatedto_text(d1, "month"), "29-Feb-2024") + expect_identical(get_updatedto_text(d1, "day"), "01-Feb-2024") + expect_identical(get_updatedto_text(d1, "calendar_year"), "31-Dec-2024") + expect_identical(get_updatedto_text(d1, "week"), "04-Feb-2024") # following Sunday + }) + + +"get_updatedto_text: all aggregation types - Monday date" |> + test_that({ + d1 <- lubridate::as_date("2024-01-01") # A Monday + + expect_identical(get_updatedto_text(d1, "none"), "31-Jan-2024") + expect_identical(get_updatedto_text(d1, "month"), "31-Jan-2024") + expect_identical(get_updatedto_text(d1, "day"), "01-Jan-2024") + expect_identical(get_updatedto_text(d1, "calendar_year"), "31-Dec-2024") + expect_identical(get_updatedto_text(d1, "week"), "07-Jan-2024") # following Sunday + }) + + +"get_updatedto_text: error cases" |> + test_that({ + d1 <- lubridate::as_date("2024-01-01") + + expect_error( + get_updatedto_text(d1, "quarter"), + "get_updatedto_text: invalid aggregation (quarter) provided", + fixed = TRUE + ) + expect_error( + get_updatedto_text(d1, NA), + "get_updatedto_text: invalid aggregation (NA) provided", + fixed = TRUE + ) + expect_error( + get_updatedto_text(d1, c("week", "month")), + "get_updatedto_text: Multiple values for `aggregation` provided", + fixed = TRUE + ) + expect_error( + get_updatedto_text(as.Date(c("2024-01-01", "2024-02-01")), "month"), + "get_updatedto_text: Multiple values for `last_date` provided", + fixed = TRUE + ) + }) diff --git a/tests/testthat/test-helper_functions.R b/tests/testthat/test-helper_functions.R deleted file mode 100644 index b605eff..0000000 --- a/tests/testthat/test-helper_functions.R +++ /dev/null @@ -1,110 +0,0 @@ -"updatedto_text handles dttms correctly 1" |> - test_that({ - # failing test for current behaviour (11 March 2024) - - d1 <- lubridate::as_date("2024-02-01") - d2 <- lubridate::as_datetime("2024-02-01") - - desired_result <- lubridate::as_date("2024-02-29") - unwanted_result <- lubridate::as_datetime("2024-01-31 23:59:59") - - aggregation <- "month" - - o1 <- lubridate::ceiling_date(d1, aggregation) - 1 - o2 <- lubridate::ceiling_date(d2, aggregation) - 1 - - expect_equal(o1, desired_result) - expect_false(identical(o2, desired_result)) - expect_equal(o2, unwanted_result) - }) - - -"updatedto_text handles dttms correctly 2" |> - test_that({ - # failing test for current behaviour (11 March 2024) - - d1 <- lubridate::as_date("2024-02-01") - d2 <- lubridate::as_datetime("2024-02-01") - - # the function needs to operate on a date not a datetime - d1 <- as.Date(d1) - d2 <- as.Date(d2) - - desired_result <- lubridate::as_date("2024-02-29") - - aggregation <- "month" - - o1 <- lubridate::ceiling_date(d1, aggregation) - lubridate::days(1) - o2 <- lubridate::ceiling_date(d2, aggregation) - lubridate::days(1) - - expect_equal(o1, desired_result) - expect_equal(o2, desired_result) - }) - - -"general input/output test for get_updatedto_text() part 1" |> - test_that({ - d1 <- lubridate::as_date("2024-02-01") # A Thursday - exp_out <- "29-Feb-2024" # character not date - - od1 <- get_updatedto_text(d1, "none") - expect_identical(od1, exp_out) - - od2 <- get_updatedto_text(d1, "month") - expect_identical(od2, exp_out) - - od3 <- get_updatedto_text(d1, "day") - expect_identical(od3, "01-Feb-2024") # character not date - - od4 <- get_updatedto_text(d1, "calendar_year") - expect_identical(od4, "31-Dec-2024") # character not date - - od5 <- get_updatedto_text(d1, "week") - # Should give us the following Sunday (4 Feb) - expect_identical(od5, "04-Feb-2024") # character not date - }) - - -"general input/output test for get_updatedto_text() part 2" |> - test_that({ - d1 <- lubridate::as_date("2024-01-01") # A Monday - exp_out <- "31-Jan-2024" # character not date - - od1 <- get_updatedto_text(d1, "none") - expect_identical(od1, exp_out) - - od2 <- get_updatedto_text(d1, "month") - expect_identical(od2, exp_out) - - od3 <- get_updatedto_text(d1, "day") - expect_identical(od3, "01-Jan-2024") # character not date - - od4 <- get_updatedto_text(d1, "calendar_year") - expect_identical(od4, "31-Dec-2024") # character not date - - od5 <- get_updatedto_text(d1, "week") - # Should give us the following Sunday (7 Jan) - expect_identical(od5, "07-Jan-2024") # character not date - - # financial year still to be implemented - - - # try some errors - expect_error( - get_updatedto_text(d1, "quarter"), # not implemented - "get_updatedto_text: invalid aggregation (quarter) provided", - fixed = TRUE - ) - - expect_error( - get_updatedto_text(d1, NA), - "get_updatedto_text: invalid aggregation (NA) provided", - fixed = TRUE - ) - - expect_error( - get_updatedto_text(d1, c("week", "month")), - "get_updatedto_text: Multiple values for `aggregation` provided", - fixed = TRUE - ) - }) diff --git a/tests/testthat/test-parse_rebase_dates.R b/tests/testthat/test-parse_rebase_dates.R index 14a3ce8..583f7da 100644 --- a/tests/testthat/test-parse_rebase_dates.R +++ b/tests/testthat/test-parse_rebase_dates.R @@ -25,46 +25,3 @@ "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." ) }) - - -"dates are amended to match data dates" |> - test_that({ - - measure_data <- tibble::tibble( - date = lubridate::ymd(paste0("2022-0", 1:6, "-01")) - ) - - dates <- parse_rebase_dates('"2022-03-17", "2022-05-01", "2022-06-02"') - - expect_length(dates, 3) - - pull_closest_date <- function(date, dates_list) { - later_dates <- dates_list[dates_list >= date] - if (length(later_dates)) min(later_dates) else date - } - - dates_list <- measure_data$date - - later_dates <- dates_list[dates_list >= dates[1]] - expect_length(later_dates, 3) - - later_dates <- dates_list[dates_list >= dates[2]] - expect_length(later_dates, 2) - - later_dates <- dates_list[dates_list >= dates[3]] - expect_length(later_dates, 0) - - expect_equal(pull_closest_date(dates[1], dates_list), as.Date("2022-04-01")) - expect_equal(pull_closest_date(dates[2], dates_list), as.Date("2022-05-01")) - expect_equal(pull_closest_date(dates[3], dates_list), as.Date("2022-06-02")) - - out <- dates |> - purrr::map_vec(pull_closest_date, dates_list = dates_list) - - expect_length(out, 3) - - expect_s3_class(out[1], "Date") - expect_s3_class(out[2], "Date") - expect_s3_class(out[3], "Date") - - }) From 205964cd33db5289fd2cdcff4a7bd65ad4ff9b2e Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 23:26:46 +0100 Subject: [PATCH 08/13] improve edge and boundary tests --- tests/testthat/test-align_rebase_dates.R | 21 +++++++++++++++++++++ tests/testthat/test-get_assurance_type.R | 23 +++++++++++++++++++++++ tests/testthat/test-get_target_text.R | 18 ++++++++++++++++++ tests/testthat/test-get_variation_type.R | 24 ++++++++++++++++++++++++ tests/testthat/test-parse_rebase_dates.R | 18 ++++++++++++++++++ 5 files changed, 104 insertions(+) diff --git a/tests/testthat/test-align_rebase_dates.R b/tests/testthat/test-align_rebase_dates.R index edaa231..af238cb 100644 --- a/tests/testthat/test-align_rebase_dates.R +++ b/tests/testthat/test-align_rebase_dates.R @@ -54,3 +54,24 @@ make_measure_data <- function(dates) { # parse_rebase_dates(NA) returns NULL; map_vec over NULL gives empty/NA expect_true(length(result) == 0 || all(is.na(result))) }) + + +"align_rebase_dates: rebase date before all data dates rounds up to first data date" |> + test_that({ + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + # 2021-06-01 is before all data -> rounds up to the earliest data date + expect_equal( + align_rebase_dates("2021-06-01", md), + as.Date("2022-01-01") + ) + }) + + +"align_rebase_dates: empty measure_data returns rebase date unchanged" |> + test_that({ + md <- tibble::tibble(date = as.Date(character(0))) + expect_equal( + align_rebase_dates("2022-03-15", md), + as.Date("2022-03-15") + ) + }) diff --git a/tests/testthat/test-get_assurance_type.R b/tests/testthat/test-get_assurance_type.R index ee47658..0a152cb 100644 --- a/tests/testthat/test-get_assurance_type.R +++ b/tests/testthat/test-get_assurance_type.R @@ -104,6 +104,29 @@ test_that("it returns correct string in passing conditions", { ) }) +test_that("target exactly equal to lpl is treated as within limits (RND_TARG)", { + spc <- data.frame(upl = 3, lpl = 1, target = 1) + + expect_equal(get_assurance_type(spc, "increase"), "RND_TARG") + expect_equal(get_assurance_type(spc, "decrease"), "RND_TARG") +}) + +test_that("target exactly equal to upl is treated as within limits (RND_TARG)", { + spc <- data.frame(upl = 3, lpl = 1, target = 3) + + expect_equal(get_assurance_type(spc, "increase"), "RND_TARG") + expect_equal(get_assurance_type(spc, "decrease"), "RND_TARG") +}) + +test_that("an unrecognised improvement direction with target outside limits errors", { + spc <- data.frame(upl = 3, lpl = 1, target = 5) + + expect_error( + get_assurance_type(spc, "upward"), + "Unable to determine SPC assurance type" + ) +}) + test_that("it uses the most recent row, not the first, for upl/lpl", { # Simulates a real ptd_spc output where a single-point first rebase phase # produces NA limits for that row, while the current (last) rows have valid diff --git a/tests/testthat/test-get_target_text.R b/tests/testthat/test-get_target_text.R index 9839ce0..2ae6eda 100644 --- a/tests/testthat/test-get_target_text.R +++ b/tests/testthat/test-get_target_text.R @@ -59,3 +59,21 @@ test_that("it rounds decimals", { "\u2265 0.96" ) }) + +test_that("target of 0 with decrease direction omits the <= symbol", { + # A target of zero with "decrease" is a floor: adding \u2264 0 would be + # misleading, so the code intentionally returns the bare value. + expect_equal( + get_target_text(0, "decrease", "decimal"), + "0" + ) +}) + +test_that("target of 100% with increase direction omits the >= symbol", { + # A target of 1 (100%) with "increase" is a ceiling: adding \u2265 100% would + # be misleading, so the code intentionally returns the bare value. + expect_equal( + get_target_text(1, "increase", "%"), + "100%" + ) +}) diff --git a/tests/testthat/test-get_variation_type.R b/tests/testthat/test-get_variation_type.R index 3b4ec00..49783bf 100644 --- a/tests/testthat/test-get_variation_type.R +++ b/tests/testthat/test-get_variation_type.R @@ -72,3 +72,27 @@ test_that("it returns correct strings when improvement direction is decrease", { "SC_LO_IMP" ) }) + +test_that("an unrecognised improvement direction with a special cause point errors", { + spc <- data.frame( + point_type = "special_cause_improvement", + relative_to_mean = 1 + ) + + expect_error( + get_variation_type(spc, "upward"), + "Unable to determine SPC variation type" + ) +}) + +test_that("an unrecognised point_type errors", { + spc <- data.frame( + point_type = "special_cause_unknown", + relative_to_mean = 0 + ) + + expect_error( + get_variation_type(spc, "increase"), + "Unable to determine SPC variation type" + ) +}) diff --git a/tests/testthat/test-parse_rebase_dates.R b/tests/testthat/test-parse_rebase_dates.R index 583f7da..3864bfb 100644 --- a/tests/testthat/test-parse_rebase_dates.R +++ b/tests/testthat/test-parse_rebase_dates.R @@ -25,3 +25,21 @@ "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." ) }) + +"NULL input causes an error" |> + test_that({ + expect_error(parse_rebase_dates(NULL)) + }) + +"empty string returns NA (lubridate::ymd silently returns NA for empty input)" |> + test_that({ + expect_equal(parse_rebase_dates(""), as.Date(NA)) + }) + +"a single quoted date (no comma) is parsed correctly" |> + test_that({ + expect_equal( + parse_rebase_dates('"2020-01-01"'), + as.Date("2020-01-01") + ) + }) From 1ebfafc027cffd1142826e4ed860b6544198659a Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Fri, 24 Apr 2026 23:51:53 +0100 Subject: [PATCH 09/13] further tighten tests --- R/checking_functions.R | 40 +++++-- tests/testthat/test-checking_functions.R | 123 ++++++++++++++++++++ tests/testthat/test-lengthen_measure_data.R | 13 +++ tests/testthat/test-process_event_data_t.R | 31 +++++ 4 files changed, 199 insertions(+), 8 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index 95eb730..74f0e63 100644 --- a/R/checking_functions.R +++ b/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 @@ -118,11 +118,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 +126,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 +189,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 +283,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`. #' diff --git a/tests/testthat/test-checking_functions.R b/tests/testthat/test-checking_functions.R index 05c3f85..201cf26 100644 --- a/tests/testthat/test-checking_functions.R +++ b/tests/testthat/test-checking_functions.R @@ -138,6 +138,68 @@ +"check measure config: invalid improvement_direction throws an error" |> + test_that({ + measure_config <- tibble::tibble( + ref = "1", measure_name = "M1", data_source = "S1", + data_owner = "O1", accountable_person = "L1", + unit = "integer", improvement_direction = "upward", + target = NA, target_set_by = NA, data_quality = "GGGG", + rebase_dates = NA, rebase_comment = NA + ) + + expect_error( + check_measure_config(measure_config), + "'improvement_direction' must be one of.*Invalid value\\(s\\): upward" + ) + }) + +"check measure config: valid improvement_direction values are accepted" |> + test_that({ + for (dir in c("increase", "Increase", "decrease", "Decrease", "neutral", "Neutral")) { + measure_config <- tibble::tibble( + ref = "1", measure_name = "M1", data_source = "S1", + data_owner = "O1", accountable_person = "L1", + unit = "integer", improvement_direction = dir, + target = NA, target_set_by = NA, data_quality = "GGGG", + rebase_dates = NA, rebase_comment = NA + ) + expect_no_error(check_measure_config(measure_config)) + } + }) + +"check measure config: invalid unit throws an error" |> + test_that({ + measure_config <- tibble::tibble( + ref = "1", measure_name = "M1", data_source = "S1", + data_owner = "O1", accountable_person = "L1", + unit = "percent", improvement_direction = "increase", + target = NA, target_set_by = NA, data_quality = "GGGG", + rebase_dates = NA, rebase_comment = NA + ) + + expect_error( + check_measure_config(measure_config), + "'unit' must be one of.*Invalid value\\(s\\): percent" + ) + }) + +"check measure config: valid unit values are accepted" |> + test_that({ + for (u in c("integer", "Integer", "decimal", "Decimal", "%")) { + measure_config <- tibble::tibble( + ref = "1", measure_name = "M1", data_source = "S1", + data_owner = "O1", accountable_person = "L1", + unit = u, improvement_direction = "increase", + target = NA, target_set_by = NA, data_quality = "GGGG", + rebase_dates = NA, rebase_comment = NA + ) + expect_no_error(check_measure_config(measure_config)) + } + }) + + + # check measure names "check measure names: happy path" |> test_that({ @@ -273,6 +335,42 @@ }) +"check report config: invalid spc_chart_type throws an error" |> + test_that({ + report_config <- tibble::tibble( + ref = "1", measure_name = "M1", domain = "D1", + spc_chart_type = "bar", aggregation = "month" + ) + + expect_error( + check_report_config(report_config), + "'spc_chart_type' must be one of.*Invalid value\\(s\\): bar" + ) + }) + +"check report config: invalid aggregation throws an error" |> + test_that({ + report_config <- tibble::tibble( + ref = "1", measure_name = "M1", domain = "D1", + spc_chart_type = "xmr", aggregation = "quarter" + ) + + expect_error( + check_report_config(report_config), + "'aggregation' must be one of.*Invalid value\\(s\\): quarter" + ) + }) + +"check report config: spc_chart_type and aggregation are case-insensitive" |> + test_that({ + report_config <- tibble::tibble( + ref = "1", measure_name = "M1", domain = "D1", + spc_chart_type = "XMR", aggregation = "Month" + ) + + expect_no_error(check_report_config(report_config)) + }) + "check measure_data: happy path" |> test_that({ @@ -330,6 +428,23 @@ }) +"check_dataset_is_complete: empty report_config passes without error" |> + test_that({ + empty_config <- tibble::tibble( + ref = character(), measure_name = character(), aggregation = character() + ) + + measure_data_df <- tibble::tibble( + ref = "1", measure_name = "M1", aggregation = "month" + ) + + expect_no_error( + check_dataset_is_complete(empty_config, measure_data_df) + ) + }) + + + "check a_data: happy path" |> test_that({ @@ -350,6 +465,14 @@ }) +"check a_data: non-list input throws an error" |> + test_that({ + expect_error( + check_a_data(data.frame(ref = 1, measure_name = "M1", comment = "c")), + "check_a_data: The data must be a list." + ) + }) + "check a_data: missing columns throw an error" |> test_that({ diff --git a/tests/testthat/test-lengthen_measure_data.R b/tests/testthat/test-lengthen_measure_data.R index 2e2f2b2..c733522 100644 --- a/tests/testthat/test-lengthen_measure_data.R +++ b/tests/testthat/test-lengthen_measure_data.R @@ -63,6 +63,19 @@ }) +"only init columns and no date columns causes an error (pivot_longer requires at least one column)" |> + test_that({ + .data <- tibble::tibble( + ref = 1L, + measure_name = "a name", + comment = "a comment" + # no date columns + ) + + expect_error(lengthen_measure_data(.data)) + }) + + "check_pipeline" |> test_that({ diff --git a/tests/testthat/test-process_event_data_t.R b/tests/testthat/test-process_event_data_t.R index 44c863c..dd5a58c 100644 --- a/tests/testthat/test-process_event_data_t.R +++ b/tests/testthat/test-process_event_data_t.R @@ -23,6 +23,37 @@ }) +"process_event_data_t: single event produces one row (time from event to cutoff)" |> + test_that({ + e_data <- tibble::tibble( + ref = "1", + measure_name = "Name", + event_date_or_datetime = as.POSIXct("2020-01-01") + ) + cutoff_dttm <- as.POSIXct("2020-01-11 23:59:59") + + result <- process_event_data_t(e_data, cutoff_dttm) + + expect_equal(nrow(result), 1L) + expect_equal(result[["value"]], 10L) # 10 whole days between event and cutoff + expect_equal(result[["date"]], cutoff_dttm) + }) + +"process_event_data_t: events with identical datetimes produce a zero time-between row" |> + test_that({ + e_data <- tibble::tibble( + ref = "1", + measure_name = "Name", + event_date_or_datetime = as.POSIXct(c("2020-01-05", "2020-01-05")) + ) + cutoff_dttm <- as.POSIXct("2020-01-15") + + result <- process_event_data_t(e_data, cutoff_dttm) + + expect_equal(nrow(result), 2L) + expect_equal(result[["value"]], c(0L, 10L)) + }) + "process_event_data_t: passing in an empty event list returns NULL" |> test_that({ From f709d48736b7afe770b890dd1d116ca559a9626c Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Sat, 25 Apr 2026 00:11:33 +0100 Subject: [PATCH 10/13] make a user error message more specific --- R/checking_functions.R | 14 ++++++++++---- tests/testthat/test-checking_functions.R | 16 +++++++++++++++- tests/testthat/test-lengthen_measure_data.R | 12 ------------ 3 files changed, 25 insertions(+), 17 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index 74f0e63..ebcaeca 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -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)." + ) + )) } diff --git a/tests/testthat/test-checking_functions.R b/tests/testthat/test-checking_functions.R index 201cf26..cff75fa 100644 --- a/tests/testthat/test-checking_functions.R +++ b/tests/testthat/test-checking_functions.R @@ -451,7 +451,8 @@ datasheet <- tibble::tibble( ref = c(1, 2, 3), measure_name = c("M1", "M2", "M3"), - comment = c("comment", "comment", "comment") + comment = c("comment", "comment", "comment"), + "2024-01-01" = c(1, 2, 3) ) a_data <- list( @@ -473,6 +474,19 @@ ) }) +"check a_data: data frame with no date columns throws an error" |> + test_that({ + datasheet <- tibble::tibble( + ref = 1, measure_name = "M1", comment = "c" + # no date columns + ) + + expect_error( + check_a_data(list(week = datasheet)), + "No date columns found in the 'week' sheet" + ) + }) + "check a_data: missing columns throw an error" |> test_that({ diff --git a/tests/testthat/test-lengthen_measure_data.R b/tests/testthat/test-lengthen_measure_data.R index c733522..4316d0c 100644 --- a/tests/testthat/test-lengthen_measure_data.R +++ b/tests/testthat/test-lengthen_measure_data.R @@ -63,18 +63,6 @@ }) -"only init columns and no date columns causes an error (pivot_longer requires at least one column)" |> - test_that({ - .data <- tibble::tibble( - ref = 1L, - measure_name = "a name", - comment = "a comment" - # no date columns - ) - - expect_error(lengthen_measure_data(.data)) - }) - "check_pipeline" |> test_that({ From 993424c90a0cc6d58ace4b024ea37aeb4c1773ab Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Sat, 25 Apr 2026 00:15:21 +0100 Subject: [PATCH 11/13] remove pipe style from test titles --- tests/testthat/test-align_rebase_dates.R | 115 ++- tests/testthat/test-calculate_stale_data.R | 141 ++- tests/testthat/test-check_measure_data.R | 147 ++- tests/testthat/test-checking_functions.R | 976 ++++++++++---------- tests/testthat/test-get_updatedto_text.R | 173 ++-- tests/testthat/test-lengthen_measure_data.R | 174 ++-- tests/testthat/test-parse_rebase_dates.R | 85 +- tests/testthat/test-process_event_data_t.R | 106 +-- tests/testthat/test-spcr_make_data_bundle.R | 267 +++--- tests/testthat/test-spcr_make_report.R | 169 ++-- 10 files changed, 1140 insertions(+), 1213 deletions(-) diff --git a/tests/testthat/test-align_rebase_dates.R b/tests/testthat/test-align_rebase_dates.R index af238cb..61f2111 100644 --- a/tests/testthat/test-align_rebase_dates.R +++ b/tests/testthat/test-align_rebase_dates.R @@ -2,76 +2,69 @@ make_measure_data <- function(dates) { tibble::tibble(date = lubridate::ymd(dates)) } -"align_rebase_dates: rebase date that exactly matches a data date is unchanged" |> - test_that({ - md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) - expect_equal( - align_rebase_dates("2022-02-01", md), - as.Date("2022-02-01") - ) - }) +test_that("align_rebase_dates: rebase date that exactly matches a data date is unchanged", { + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + expect_equal( + align_rebase_dates("2022-02-01", md), + as.Date("2022-02-01") + ) +}) -"align_rebase_dates: rebase date between data dates is rounded up to next data date" |> - test_that({ - md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) - # 2022-01-15 falls between Jan and Feb data points -> rounds up to Feb - expect_equal( - align_rebase_dates("2022-01-15", md), - as.Date("2022-02-01") - ) - }) +test_that("align_rebase_dates: rebase date between data dates is rounded up to next data date", { + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + # 2022-01-15 falls between Jan and Feb data points -> rounds up to Feb + expect_equal( + align_rebase_dates("2022-01-15", md), + as.Date("2022-02-01") + ) +}) -"align_rebase_dates: rebase date after all data dates is returned as-is" |> - test_that({ - md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) - # No data date >= 2022-06-01, so the rebase date is returned unchanged - expect_equal( - align_rebase_dates("2022-06-01", md), - as.Date("2022-06-01") - ) - }) +test_that("align_rebase_dates: rebase date after all data dates is returned as-is", { + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + # No data date >= 2022-06-01, so the rebase date is returned unchanged + expect_equal( + align_rebase_dates("2022-06-01", md), + as.Date("2022-06-01") + ) +}) -"align_rebase_dates: multiple rebase dates are each aligned independently" |> - test_that({ - md <- make_measure_data(paste0("2022-0", 1:6, "-01")) - # "2022-03-17" -> 2022-04-01 (next data date) - # "2022-05-01" -> 2022-05-01 (exact match) - # "2022-06-02" -> 2022-06-02 (after all data, returned as-is) - expect_equal( - align_rebase_dates('"2022-03-17", "2022-05-01", "2022-06-02"', md), - as.Date(c("2022-04-01", "2022-05-01", "2022-06-02")) - ) - }) +test_that("align_rebase_dates: multiple rebase dates are each aligned independently", { + md <- make_measure_data(paste0("2022-0", 1:6, "-01")) + # "2022-03-17" -> 2022-04-01 (next data date) + # "2022-05-01" -> 2022-05-01 (exact match) + # "2022-06-02" -> 2022-06-02 (after all data, returned as-is) + expect_equal( + align_rebase_dates('"2022-03-17", "2022-05-01", "2022-06-02"', md), + as.Date(c("2022-04-01", "2022-05-01", "2022-06-02")) + ) +}) -"align_rebase_dates: NA input returns an empty or NA result" |> - test_that({ - md <- make_measure_data(c("2022-01-01", "2022-02-01")) - result <- align_rebase_dates(NA_character_, md) - # parse_rebase_dates(NA) returns NULL; map_vec over NULL gives empty/NA - expect_true(length(result) == 0 || all(is.na(result))) - }) +test_that("align_rebase_dates: NA input returns an empty or NA result", { + md <- make_measure_data(c("2022-01-01", "2022-02-01")) + result <- align_rebase_dates(NA_character_, md) + # parse_rebase_dates(NA) returns NULL; map_vec over NULL gives empty/NA + expect_true(length(result) == 0 || all(is.na(result))) +}) -"align_rebase_dates: rebase date before all data dates rounds up to first data date" |> - test_that({ - md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) - # 2021-06-01 is before all data -> rounds up to the earliest data date - expect_equal( - align_rebase_dates("2021-06-01", md), - as.Date("2022-01-01") - ) - }) +test_that("align_rebase_dates: rebase date before all data dates rounds up to first data date", { + md <- make_measure_data(c("2022-01-01", "2022-02-01", "2022-03-01")) + # 2021-06-01 is before all data -> rounds up to the earliest data date + expect_equal( + align_rebase_dates("2021-06-01", md), + as.Date("2022-01-01") + ) +}) -"align_rebase_dates: empty measure_data returns rebase date unchanged" |> - test_that({ - md <- tibble::tibble(date = as.Date(character(0))) - expect_equal( - align_rebase_dates("2022-03-15", md), - as.Date("2022-03-15") - ) - }) +test_that("align_rebase_dates: empty measure_data returns rebase date unchanged", { + md <- tibble::tibble(date = as.Date(character(0))) + expect_equal( + align_rebase_dates("2022-03-15", md), + as.Date("2022-03-15") + ) +}) diff --git a/tests/testthat/test-calculate_stale_data.R b/tests/testthat/test-calculate_stale_data.R index 9b6ab56..1c315e4 100644 --- a/tests/testthat/test-calculate_stale_data.R +++ b/tests/testthat/test-calculate_stale_data.R @@ -1,75 +1,70 @@ -"it has a happy path" |> - test_that({ - - updated_to <- "31-Jan-2020" - lag <- 0 - cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") - - expect_equal( - calculate_stale_data(updated_to, lag, cutoff_dttm), "fresh" - ) - }) - -"updated_to must be a simple date string" |> - test_that({ - - lag <- 0 - cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") - - # introduce the error - updated_to <- as.POSIXct("2020-01-31") - - # this will generate a warning message due to the incorrect date format - expect_error( - calculate_stale_data(updated_to, lag, cutoff_dttm), - "calculate_stale_data: Unable to convert the updated_to argument text to a valid date." - ) - }) - -"the lag must be an integer (complete days only)" |> - test_that({ - - updated_to <- "31-Jan-2020" - # introduce an error - lag <- 0.1 - cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") - - expect_error( - calculate_stale_data(updated_to, lag, cutoff_dttm), - "calculate_stale_data: The lag argument must be an integer." - ) - }) - -"cutoff_dttm must be a POSIXct" |> - test_that({ - - updated_to <- "31-Jan-2020" - lag <- 0 - cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") - # introduce an error - cutoff_dttm <- as.Date(cutoff_dttm) - - expect_error( - calculate_stale_data(updated_to, lag, cutoff_dttm), - "calculate_stale_data: The cutoff_dttm argument must be a POSIXct." - ) - }) - -"adding an allowable lag enables reporting in arrears" |> - test_that({ - - updated_to <- "31-Jan-2020" - lag <- 0 - # report one month later - cutoff_dttm <- as.POSIXct("2020-02-28 23:59:59") - - expect_equal( - calculate_stale_data(updated_to, lag, cutoff_dttm), "stale" - ) - - expect_equal( - calculate_stale_data(updated_to, 30, cutoff_dttm), "fresh" - ) - }) +test_that("it has a happy path", { + + updated_to <- "31-Jan-2020" + lag <- 0 + cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") + + expect_equal( + calculate_stale_data(updated_to, lag, cutoff_dttm), "fresh" + ) +}) + +test_that("updated_to must be a simple date string", { + + lag <- 0 + cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") + + # introduce the error + updated_to <- as.POSIXct("2020-01-31") + + # this will generate a warning message due to the incorrect date format + expect_error( + calculate_stale_data(updated_to, lag, cutoff_dttm), + "calculate_stale_data: Unable to convert the updated_to argument text to a valid date." + ) +}) + +test_that("the lag must be an integer (complete days only)", { + + updated_to <- "31-Jan-2020" + # introduce an error + lag <- 0.1 + cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") + + expect_error( + calculate_stale_data(updated_to, lag, cutoff_dttm), + "calculate_stale_data: The lag argument must be an integer." + ) +}) + +test_that("cutoff_dttm must be a POSIXct", { + + updated_to <- "31-Jan-2020" + lag <- 0 + cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") + # introduce an error + cutoff_dttm <- as.Date(cutoff_dttm) + + expect_error( + calculate_stale_data(updated_to, lag, cutoff_dttm), + "calculate_stale_data: The cutoff_dttm argument must be a POSIXct." + ) +}) + +test_that("adding an allowable lag enables reporting in arrears", { + + updated_to <- "31-Jan-2020" + lag <- 0 + # report one month later + cutoff_dttm <- as.POSIXct("2020-02-28 23:59:59") + + expect_equal( + calculate_stale_data(updated_to, lag, cutoff_dttm), "stale" + ) + + expect_equal( + calculate_stale_data(updated_to, 30, cutoff_dttm), "fresh" + ) +}) diff --git a/tests/testthat/test-check_measure_data.R b/tests/testthat/test-check_measure_data.R index 32673bc..0225ea7 100644 --- a/tests/testthat/test-check_measure_data.R +++ b/tests/testthat/test-check_measure_data.R @@ -1,60 +1,55 @@ -"it errors if the data is not a list" |> - test_that({ - expect_error( - check_measure_data(tibble::tibble(this_is = "not a list")), - "check_measure_data: The data must be a list." - ) - }) +test_that("it errors if the data is not a list", { + expect_error( + check_measure_data(tibble::tibble(this_is = "not a list")), + "check_measure_data: The data must be a list." + ) +}) -"list contains at least one of the required items" |> - test_that({ - expect_error( - check_measure_data(list(`Once in a blue moon` = 1)), - "check_measure_data: One element of measure_data must be named 'week' or 'month'" - ) - }) +test_that("list contains at least one of the required items", { + expect_error( + check_measure_data(list(`Once in a blue moon` = 1)), + "check_measure_data: One element of measure_data must be named 'week' or 'month'" + ) +}) -"list containing extra elements is allowed" |> - test_that({ - expect_no_error( - list( - week = data.frame(ref = 1, measure_name = "M1", comment = NA), - month = data.frame(ref = 2, measure_name = "M2", comment = NA), - asdf = data.frame(some = "other data") # extra element - ) |> - check_measure_data() - ) - }) +test_that("list containing extra elements is allowed", { + expect_no_error( + list( + week = data.frame(ref = 1, measure_name = "M1", comment = NA), + month = data.frame(ref = 2, measure_name = "M2", comment = NA), + asdf = data.frame(some = "other data") # extra element + ) |> + check_measure_data() + ) +}) -"list containing either 'week' or 'month' is allowed" |> - test_that({ +test_that("list containing either 'week' or 'month' is allowed", { - expect_no_error( - list( - week = data.frame(ref = 1, measure_name = "M1", comment = NA) - # month list item is not provided - ) |> - check_measure_data() - ) + expect_no_error( + list( + week = data.frame(ref = 1, measure_name = "M1", comment = NA) + # month list item is not provided + ) |> + check_measure_data() + ) - expect_no_error( - list( - # week list item is not provided - month = data.frame(ref = 2, measure_name = "M2", comment = NA) - ) |> - check_measure_data() - ) - }) + expect_no_error( + list( + # week list item is not provided + month = data.frame(ref = 2, measure_name = "M2", comment = NA) + ) |> + check_measure_data() + ) +}) -"capitalised list items are allowed" |> - test_that({ - expect_no_error( - list( - Week = data.frame(ref = 1, measure_name = "M1", comment = NA) # Week not week - ) |> - check_measure_data() - ) - }) +test_that("capitalised list items are allowed", { + expect_no_error( + list( + Week = data.frame(ref = 1, measure_name = "M1", comment = NA) # Week not week + ) |> + check_measure_data() + ) +}) measure_data <- list( week = tibble::tibble( @@ -93,35 +88,33 @@ measure_data <- list( ) ) -"it coerces refs to character vectors" |> - test_that({ - # create the error by assigning numeric refs - measure_data[["week"]]$ref <- c(1, 2, 3) - measure_data[["month"]]$ref <- c(1, 2, 3) +test_that("it coerces refs to character vectors", { + # create the error by assigning numeric refs + measure_data[["week"]]$ref <- c(1, 2, 3) + measure_data[["month"]]$ref <- c(1, 2, 3) - r <- check_measure_data(measure_data) + r <- check_measure_data(measure_data) - expect_equal( - r[["week"]]$ref, - c("1", "2", "3") - ) - }) + expect_equal( + r[["week"]]$ref, + c("1", "2", "3") + ) +}) -"it errors helpfully when column names are missing or mis-spelled" |> - test_that({ - # create the error by removing a required column - measure_data[["week"]]$ref <- NULL +test_that("it errors helpfully when column names are missing or mis-spelled", { + # create the error by removing a required column + measure_data[["week"]]$ref <- NULL - expect_error( - check_measure_data(measure_data), - "check_for_required_columns: Column 'ref' is missing from the 'week' data frame. Check for typos in the column names." - ) + expect_error( + check_measure_data(measure_data), + "check_for_required_columns: Column 'ref' is missing from the 'week' data frame. Check for typos in the column names." + ) - # error persists when the column is mis-spelled - measure_data[["week"]]$Reference <- c(1, 2, 3) + # error persists when the column is mis-spelled + measure_data[["week"]]$Reference <- c(1, 2, 3) - expect_error( - check_measure_data(measure_data), - "check_for_required_columns: Column 'ref' is missing from the 'week' data frame. Check for typos in the column names." - ) - }) + expect_error( + check_measure_data(measure_data), + "check_for_required_columns: Column 'ref' is missing from the 'week' data frame. Check for typos in the column names." + ) +}) diff --git a/tests/testthat/test-checking_functions.R b/tests/testthat/test-checking_functions.R index cff75fa..de51eed 100644 --- a/tests/testthat/test-checking_functions.R +++ b/tests/testthat/test-checking_functions.R @@ -1,542 +1,516 @@ -"check_dataset_is_complete: happy path" |> - test_that({ - - # this function is called when before the aggregation is manually changed from - # "events" to "none", so we need to create the renaming here - measure_data_df <- test_measure_data |> - dplyr::bind_rows(.id = "aggregation") |> - dplyr::mutate(aggregation = dplyr::case_when( - aggregation == "events" ~ "none", - TRUE ~ aggregation - )) - - expect_no_error( - check_dataset_is_complete( - test_report_config, - measure_data_df - ) - ) - }) - -"check_dataset_is_complete: it errors when data is missing" |> - test_that({ - - measure_data_df <- test_measure_data |> - dplyr::bind_rows(.id = "aggregation") |> - dplyr::mutate(aggregation = dplyr::case_when( - aggregation == "events" ~ "none", - TRUE ~ aggregation - )) - - report_config_plus_one <- test_report_config |> - tibble::add_row(ref = 9999, measure_name = "test", aggregation = "week") - - # add a single row - expect_error( - check_dataset_is_complete( - report_config_plus_one, - measure_data_df - ), - "Data is missing for 1 report items. The first is ref 9999, 'test', aggregation: week." - ) - - report_config_plus_two <- test_report_config |> - tibble::add_row(ref = 9998, measure_name = "test", aggregation = "none") |> - tibble::add_row(ref = 9999, measure_name = "test", aggregation = "week") - - expect_error( - check_dataset_is_complete( - report_config_plus_two, - measure_data_df - ), - "Data is missing for 2 report items. The first is ref 9998, 'test', aggregation: none." - ) - }) +test_that("check_dataset_is_complete: happy path", { + + # this function is called when before the aggregation is manually changed from + # "events" to "none", so we need to create the renaming here + measure_data_df <- test_measure_data |> + dplyr::bind_rows(.id = "aggregation") |> + dplyr::mutate(aggregation = dplyr::case_when( + aggregation == "events" ~ "none", + TRUE ~ aggregation + )) + + expect_no_error( + check_dataset_is_complete( + test_report_config, + measure_data_df + ) + ) +}) + +test_that("check_dataset_is_complete: it errors when data is missing", { + + measure_data_df <- test_measure_data |> + dplyr::bind_rows(.id = "aggregation") |> + dplyr::mutate(aggregation = dplyr::case_when( + aggregation == "events" ~ "none", + TRUE ~ aggregation + )) + + report_config_plus_one <- test_report_config |> + tibble::add_row(ref = 9999, measure_name = "test", aggregation = "week") + + # add a single row + expect_error( + check_dataset_is_complete( + report_config_plus_one, + measure_data_df + ), + "Data is missing for 1 report items. The first is ref 9999, 'test', aggregation: week." + ) + + report_config_plus_two <- test_report_config |> + tibble::add_row(ref = 9998, measure_name = "test", aggregation = "none") |> + tibble::add_row(ref = 9999, measure_name = "test", aggregation = "week") + + expect_error( + check_dataset_is_complete( + report_config_plus_two, + measure_data_df + ), + "Data is missing for 2 report items. The first is ref 9998, 'test', aggregation: none." + ) +}) # check measure config -"check measure config: coerces refs to character vectors" |> - test_that({ - # create the error by assigning numeric refs - measure_config <- tibble::tibble( - ref = c(1, 2, 3), - measure_name = c("M1", "M2", "M3"), - data_source = c("S1", "S2", "S3"), - data_owner = c("O1", "O2", "O3"), - accountable_person = c("L1", "L2", "L3"), - unit = c("Integer", "Decimal", "%"), - improvement_direction = c("Neutral", "Increase", "Decrease"), - target = c(NA, 10, 0.2), - target_set_by = c(NA, "T2", "T3"), - data_quality = c("RRRR", "AAAA", "GGGG"), - baseline_period = c(12L, 12L, 12L), - rebase_dates = c(NA, NA, NA), - rebase_comment = c(NA, NA, NA), - allowable_days_lag = NA, - reviewed_at = NA, - escalated_to = NA - ) - - r <- check_measure_config(measure_config) - - expect_equal( - r$ref, - c("1", "2", "3") - ) - }) - -"check measure config: errors helpfully when column names are missing or mis-spelled" |> - test_that({ - - # create the error by omitting a required column (unit) - measure_config <- tibble::tibble( - ref = c("1", "2", "3"), - measure_name = c("M1", "M2", "M3"), - data_source = c("S1", "S2", "S3"), - data_owner = c("O1", "O2", "O3"), - accountable_person = c("L1", "L2", "L3"), - # unit = c("Integer", "Decimal", "%"), - improvement_direction = c("Neutral", "Increase", "Decrease"), - target = c(NA, 10, 0.2), - target_set_by = c(NA, "T2", "T3"), - data_quality = c("RRRR", "AAAA", "GGGG"), - baseline_period = c(12L, 12L, 12L), - rebase_dates = c(NA, NA, NA), - rebase_comment = c(NA, NA, NA) - ) - - expect_error( - check_measure_config(measure_config), - "check_for_required_columns: Column 'unit' is missing from the 'measure_config' data frame. Check for typos in the column names." - ) - - # error persists when the column is mis-spelled - measure_config <- tibble::tibble( - ref = c("1", "2", "3"), - measure_name = c("M1", "M2", "M3"), - data_source = c("S1", "S2", "S3"), - data_owner = c("O1", "O2", "O3"), - accountable_person = c("L1", "L2", "L3"), - Unit = c("Integer", "Decimal", "%"), - improvement_direction = c("Neutral", "Increase", "Decrease"), - target = c(NA, 10, 0.2), - target_set_by = c(NA, "T2", "T3"), - data_quality = c("RRRR", "AAAA", "GGGG"), - baseline_period = c(12L, 12L, 12L), - rebase_dates = c(NA, NA, NA), - rebase_comment = c(NA, NA, NA) - ) - - expect_error( - check_measure_config(measure_config), - "check_for_required_columns: Column 'unit' is missing from the 'measure_config' data frame. Check for typos in the column names." - ) - }) - - - - -"check measure config: invalid improvement_direction throws an error" |> - test_that({ +test_that("check measure config: coerces refs to character vectors", { + # create the error by assigning numeric refs + measure_config <- tibble::tibble( + ref = c(1, 2, 3), + measure_name = c("M1", "M2", "M3"), + data_source = c("S1", "S2", "S3"), + data_owner = c("O1", "O2", "O3"), + accountable_person = c("L1", "L2", "L3"), + unit = c("Integer", "Decimal", "%"), + improvement_direction = c("Neutral", "Increase", "Decrease"), + target = c(NA, 10, 0.2), + target_set_by = c(NA, "T2", "T3"), + data_quality = c("RRRR", "AAAA", "GGGG"), + baseline_period = c(12L, 12L, 12L), + rebase_dates = c(NA, NA, NA), + rebase_comment = c(NA, NA, NA), + allowable_days_lag = NA, + reviewed_at = NA, + escalated_to = NA + ) + + r <- check_measure_config(measure_config) + + expect_equal( + r$ref, + c("1", "2", "3") + ) +}) + +test_that("check measure config: errors helpfully when column names are missing or mis-spelled", { + + # create the error by omitting a required column (unit) + measure_config <- tibble::tibble( + ref = c("1", "2", "3"), + measure_name = c("M1", "M2", "M3"), + data_source = c("S1", "S2", "S3"), + data_owner = c("O1", "O2", "O3"), + accountable_person = c("L1", "L2", "L3"), + # unit = c("Integer", "Decimal", "%"), + improvement_direction = c("Neutral", "Increase", "Decrease"), + target = c(NA, 10, 0.2), + target_set_by = c(NA, "T2", "T3"), + data_quality = c("RRRR", "AAAA", "GGGG"), + baseline_period = c(12L, 12L, 12L), + rebase_dates = c(NA, NA, NA), + rebase_comment = c(NA, NA, NA) + ) + + expect_error( + check_measure_config(measure_config), + "check_for_required_columns: Column 'unit' is missing from the 'measure_config' data frame. Check for typos in the column names." + ) + + # error persists when the column is mis-spelled + measure_config <- tibble::tibble( + ref = c("1", "2", "3"), + measure_name = c("M1", "M2", "M3"), + data_source = c("S1", "S2", "S3"), + data_owner = c("O1", "O2", "O3"), + accountable_person = c("L1", "L2", "L3"), + Unit = c("Integer", "Decimal", "%"), + improvement_direction = c("Neutral", "Increase", "Decrease"), + target = c(NA, 10, 0.2), + target_set_by = c(NA, "T2", "T3"), + data_quality = c("RRRR", "AAAA", "GGGG"), + baseline_period = c(12L, 12L, 12L), + rebase_dates = c(NA, NA, NA), + rebase_comment = c(NA, NA, NA) + ) + + expect_error( + check_measure_config(measure_config), + "check_for_required_columns: Column 'unit' is missing from the 'measure_config' data frame. Check for typos in the column names." + ) +}) + + + + +test_that("check measure config: invalid improvement_direction throws an error", { + measure_config <- tibble::tibble( + ref = "1", measure_name = "M1", data_source = "S1", + data_owner = "O1", accountable_person = "L1", + unit = "integer", improvement_direction = "upward", + target = NA, target_set_by = NA, data_quality = "GGGG", + rebase_dates = NA, rebase_comment = NA + ) + + expect_error( + check_measure_config(measure_config), + "'improvement_direction' must be one of.*Invalid value\\(s\\): upward" + ) +}) + +test_that("check measure config: valid improvement_direction values are accepted", { + for (dir in c("increase", "Increase", "decrease", "Decrease", "neutral", "Neutral")) { measure_config <- tibble::tibble( ref = "1", measure_name = "M1", data_source = "S1", data_owner = "O1", accountable_person = "L1", - unit = "integer", improvement_direction = "upward", + unit = "integer", improvement_direction = dir, target = NA, target_set_by = NA, data_quality = "GGGG", rebase_dates = NA, rebase_comment = NA ) - - expect_error( - check_measure_config(measure_config), - "'improvement_direction' must be one of.*Invalid value\\(s\\): upward" - ) - }) - -"check measure config: valid improvement_direction values are accepted" |> - test_that({ - for (dir in c("increase", "Increase", "decrease", "Decrease", "neutral", "Neutral")) { - measure_config <- tibble::tibble( - ref = "1", measure_name = "M1", data_source = "S1", - data_owner = "O1", accountable_person = "L1", - unit = "integer", improvement_direction = dir, - target = NA, target_set_by = NA, data_quality = "GGGG", - rebase_dates = NA, rebase_comment = NA - ) - expect_no_error(check_measure_config(measure_config)) - } - }) - -"check measure config: invalid unit throws an error" |> - test_that({ + expect_no_error(check_measure_config(measure_config)) + } +}) + +test_that("check measure config: invalid unit throws an error", { + measure_config <- tibble::tibble( + ref = "1", measure_name = "M1", data_source = "S1", + data_owner = "O1", accountable_person = "L1", + unit = "percent", improvement_direction = "increase", + target = NA, target_set_by = NA, data_quality = "GGGG", + rebase_dates = NA, rebase_comment = NA + ) + + expect_error( + check_measure_config(measure_config), + "'unit' must be one of.*Invalid value\\(s\\): percent" + ) +}) + +test_that("check measure config: valid unit values are accepted", { + for (u in c("integer", "Integer", "decimal", "Decimal", "%")) { measure_config <- tibble::tibble( ref = "1", measure_name = "M1", data_source = "S1", data_owner = "O1", accountable_person = "L1", - unit = "percent", improvement_direction = "increase", + unit = u, improvement_direction = "increase", target = NA, target_set_by = NA, data_quality = "GGGG", rebase_dates = NA, rebase_comment = NA ) - - expect_error( - check_measure_config(measure_config), - "'unit' must be one of.*Invalid value\\(s\\): percent" - ) - }) - -"check measure config: valid unit values are accepted" |> - test_that({ - for (u in c("integer", "Integer", "decimal", "Decimal", "%")) { - measure_config <- tibble::tibble( - ref = "1", measure_name = "M1", data_source = "S1", - data_owner = "O1", accountable_person = "L1", - unit = u, improvement_direction = "increase", - target = NA, target_set_by = NA, data_quality = "GGGG", - rebase_dates = NA, rebase_comment = NA - ) - expect_no_error(check_measure_config(measure_config)) - } - }) + expect_no_error(check_measure_config(measure_config)) + } +}) # check measure names -"check measure names: happy path" |> - test_that({ +test_that("check measure names: happy path", { - measure_data <- tibble::tibble( - ref = "10", - measure_name = "Measure 10" - ) + measure_data <- tibble::tibble( + ref = "10", + measure_name = "Measure 10" + ) - measure_config <- tibble::tibble( - ref = "10", - measure_name = "Measure 10" - ) + measure_config <- tibble::tibble( + ref = "10", + measure_name = "Measure 10" + ) - expect_no_error( - check_measure_names(10, measure_data, measure_config) - ) - }) + expect_no_error( + check_measure_names(10, measure_data, measure_config) + ) +}) -"check measure names: warns when names do not match" |> - test_that({ +test_that("check measure names: warns when names do not match", { - measure_data <- tibble::tibble( - ref = "10", - measure_name = "Measure 10" - ) + measure_data <- tibble::tibble( + ref = "10", + measure_name = "Measure 10" + ) - measure_config <- tibble::tibble( - ref = "10", - # create the error - measure_name = "A different name" - ) + measure_config <- tibble::tibble( + ref = "10", + # create the error + measure_name = "A different name" + ) - expect_warning( - check_measure_names(10, measure_data, measure_config) - ) - }) + expect_warning( + check_measure_names(10, measure_data, measure_config) + ) +}) -"check measure names: ignores NAs in the ref column of the measure_config" |> - test_that({ +test_that("check measure names: ignores NAs in the ref column of the measure_config", { - measure_data <- tibble::tibble( - ref = "10", - measure_name = "Measure 10" - ) + measure_data <- tibble::tibble( + ref = "10", + measure_name = "Measure 10" + ) - # create the error condition - measure_config <- tibble::tibble( - ref = c("10", NA), - measure_name = c("Measure 10", NA) - ) + # create the error condition + measure_config <- tibble::tibble( + ref = c("10", NA), + measure_name = c("Measure 10", NA) + ) - expect_no_error( - check_measure_names(10, measure_data, measure_config) - ) - }) + expect_no_error( + check_measure_names(10, measure_data, measure_config) + ) +}) # check report config -"check report config: coerces refs to character vectors" |> - test_that({ - - # assign numeric refs - report_config <- tibble::tibble( - ref = c(1, 2, 3, 1, 2, 3), - measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), - domain = c("D1", "D1", "D1", "D2", "D2", "D2"), - spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), - aggregation = c("week", "week", "week", "month", "month", "month"), - report_comment = NA - ) - - r <- check_report_config(report_config) - - expect_equal( - r$ref, - c("1", "2", "3", "1", "2", "3") - ) - }) - -"check report config: errors helpfully when column names are missing or mis-spelled" |> - test_that({ - - # create the error by omitting a required column ('domain') - report_config <- tibble::tibble( - ref = c("1", "2", "3", "1", "2", "3"), - measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), - # domain = c("D1", "D1", "D1", "D2", "D2", "D2"), - spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), - aggregation = c("week", "week", "week", "month", "month", "month") - ) - - expect_error( - check_report_config(report_config), - "check_for_required_columns: Column 'domain' is missing from the 'report_config' data frame. Check for typos in the column names." - ) - - # error persists when the column is mis-spelled - report_config <- tibble::tibble( - ref = c("1", "2", "3", "1", "2", "3"), - measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), - DomainWithABigD = c("D1", "D1", "D1", "D2", "D2", "D2"), - spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), - aggregation = c("week", "week", "week", "month", "month", "month") - ) - - expect_error( - check_report_config(report_config), - "check_for_required_columns: Column 'domain' is missing from the 'report_config' data frame. Check for typos in the column names." - ) - }) - -"check report config: missing optional columns does not throw an error" |> - test_that({ - - # assign numeric refs - report_config <- tibble::tibble( - ref = c(1, 2, 3, 1, 2, 3), - measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), - domain = c("D1", "D1", "D1", "D2", "D2", "D2"), - spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), - aggregation = c("week", "week", "week", "month", "month", "month"), - # report_comment = NA # this is an optional column - ) - - expect_message( - check_report_config(report_config), - "i check_for_optional_columns: Optional column 'report_comment' is missing. Adding it." - ) +test_that("check report config: coerces refs to character vectors", { + + # assign numeric refs + report_config <- tibble::tibble( + ref = c(1, 2, 3, 1, 2, 3), + measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), + domain = c("D1", "D1", "D1", "D2", "D2", "D2"), + spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), + aggregation = c("week", "week", "week", "month", "month", "month"), + report_comment = NA + ) + + r <- check_report_config(report_config) + + expect_equal( + r$ref, + c("1", "2", "3", "1", "2", "3") + ) +}) + +test_that("check report config: errors helpfully when column names are missing or mis-spelled", { + + # create the error by omitting a required column ('domain') + report_config <- tibble::tibble( + ref = c("1", "2", "3", "1", "2", "3"), + measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), + # domain = c("D1", "D1", "D1", "D2", "D2", "D2"), + spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), + aggregation = c("week", "week", "week", "month", "month", "month") + ) + + expect_error( + check_report_config(report_config), + "check_for_required_columns: Column 'domain' is missing from the 'report_config' data frame. Check for typos in the column names." + ) + + # error persists when the column is mis-spelled + report_config <- tibble::tibble( + ref = c("1", "2", "3", "1", "2", "3"), + measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), + DomainWithABigD = c("D1", "D1", "D1", "D2", "D2", "D2"), + spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), + aggregation = c("week", "week", "week", "month", "month", "month") + ) + + expect_error( + check_report_config(report_config), + "check_for_required_columns: Column 'domain' is missing from the 'report_config' data frame. Check for typos in the column names." + ) +}) + +test_that("check report config: missing optional columns does not throw an error", { + + # assign numeric refs + report_config <- tibble::tibble( + ref = c(1, 2, 3, 1, 2, 3), + measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), + domain = c("D1", "D1", "D1", "D2", "D2", "D2"), + spc_chart_type = c("xmr", "xmr", "xmr", "t", "t", "t"), + aggregation = c("week", "week", "week", "month", "month", "month"), + # report_comment = NA # this is an optional column + ) + + expect_message( + check_report_config(report_config), + "i check_for_optional_columns: Optional column 'report_comment' is missing. Adding it." + ) + +}) + +test_that("check report config: invalid spc_chart_type throws an error", { + report_config <- tibble::tibble( + ref = "1", measure_name = "M1", domain = "D1", + spc_chart_type = "bar", aggregation = "month" + ) + + expect_error( + check_report_config(report_config), + "'spc_chart_type' must be one of.*Invalid value\\(s\\): bar" + ) +}) + +test_that("check report config: invalid aggregation throws an error", { + report_config <- tibble::tibble( + ref = "1", measure_name = "M1", domain = "D1", + spc_chart_type = "xmr", aggregation = "quarter" + ) + + expect_error( + check_report_config(report_config), + "'aggregation' must be one of.*Invalid value\\(s\\): quarter" + ) +}) + +test_that("check report config: spc_chart_type and aggregation are case-insensitive", { + report_config <- tibble::tibble( + ref = "1", measure_name = "M1", domain = "D1", + spc_chart_type = "XMR", aggregation = "Month" + ) + + expect_no_error(check_report_config(report_config)) +}) + +test_that("check measure_data: happy path", { + + aggregated_datasheet <- tibble::tibble( + ref = c(1, 2, 3), + measure_name = c("M1", "M2", "M3"), + comment = c("comment", "comment", "comment") + ) + + events_datasheet <- tibble::tibble( + ref = c(1, 2, 3), + measure_name = c("M1", "M2", "M3"), + comment = c("comment", "comment", "comment"), + event_date_or_datetime = "there will be dates here" + ) + + measure_data <- list( + "week" = aggregated_datasheet, + "month" = aggregated_datasheet, + "events" = events_datasheet + ) + + expect_no_error( + check_measure_data(measure_data) + ) + +}) + +test_that("check measure_data: missing columns throw an error", { + + aggregated_datasheet <- tibble::tibble( + ref = c(1, 2, 3), + # measure_name = c("M1", "M2", "M3"), # missing column + comment = c("comment", "comment", "comment") + ) + + events_datasheet <- tibble::tibble( + ref = c(1, 2, 3), + measure_name = c("M1", "M2", "M3"), + comment = c("comment", "comment", "comment"), + event_date_or_datetime = "there will be dates here" + ) + + measure_data <- list( + "week" = aggregated_datasheet, + "month" = aggregated_datasheet, + "events" = events_datasheet + ) + + expect_error( + check_measure_data(measure_data), + "check_for_required_columns: Column 'measure_name' is missing from the 'week' data frame. Check for typos in the column names." + ) + +}) + +test_that("check_dataset_is_complete: empty report_config passes without error", { + empty_config <- tibble::tibble( + ref = character(), measure_name = character(), aggregation = character() + ) + + measure_data_df <- tibble::tibble( + ref = "1", measure_name = "M1", aggregation = "month" + ) + + expect_no_error( + check_dataset_is_complete(empty_config, measure_data_df) + ) +}) + + + +test_that("check a_data: happy path", { + + datasheet <- tibble::tibble( + ref = c(1, 2, 3), + measure_name = c("M1", "M2", "M3"), + comment = c("comment", "comment", "comment"), + "2024-01-01" = c(1, 2, 3) + ) + + a_data <- list( + "week" = datasheet, + "month" = datasheet + ) + + expect_no_error( + check_a_data(a_data) + ) + +}) + +test_that("check a_data: non-list input throws an error", { + expect_error( + check_a_data(data.frame(ref = 1, measure_name = "M1", comment = "c")), + "check_a_data: The data must be a list." + ) +}) + +test_that("check a_data: data frame with no date columns throws an error", { + datasheet <- tibble::tibble( + ref = 1, measure_name = "M1", comment = "c" + # no date columns + ) + + expect_error( + check_a_data(list(week = datasheet)), + "No date columns found in the 'week' sheet" + ) +}) + +test_that("check a_data: missing columns throw an error", { + + datasheet <- tibble::tibble( + ref = c(1, 2, 3), + # measure_name = c("M1", "M2", "M3"), # missing column + comment = c("comment", "comment", "comment") + ) + + a_data <- list( + "week" = datasheet, + "month" = datasheet + ) + + expect_error( + check_a_data(a_data), + "check_for_required_columns: Column 'measure_name' is missing from the 'week' data frame. Check for typos in the column names." + ) + +}) + +test_that("check e_data: happy path", { + + e_data <- tibble::tibble( + ref = c(1, 2, 3), + measure_name = c("M1", "M2", "M3"), + comment = c("comment", "comment", "comment"), + event_date_or_datetime = "there will be dates here" + ) + + expect_no_error( + check_e_data(e_data) + ) + +}) + +test_that("check e_data: missing columns throw an error", { - }) - -"check report config: invalid spc_chart_type throws an error" |> - test_that({ - report_config <- tibble::tibble( - ref = "1", measure_name = "M1", domain = "D1", - spc_chart_type = "bar", aggregation = "month" - ) - - expect_error( - check_report_config(report_config), - "'spc_chart_type' must be one of.*Invalid value\\(s\\): bar" - ) - }) - -"check report config: invalid aggregation throws an error" |> - test_that({ - report_config <- tibble::tibble( - ref = "1", measure_name = "M1", domain = "D1", - spc_chart_type = "xmr", aggregation = "quarter" - ) - - expect_error( - check_report_config(report_config), - "'aggregation' must be one of.*Invalid value\\(s\\): quarter" - ) - }) + e_data <- tibble::tibble( + ref = c(1, 2, 3), + measure_name = c("M1", "M2", "M3"), + comment = c("comment", "comment", "comment"), + # event_date_or_datetime = "there will be dates here" # missing column + ) -"check report config: spc_chart_type and aggregation are case-insensitive" |> - test_that({ - report_config <- tibble::tibble( - ref = "1", measure_name = "M1", domain = "D1", - spc_chart_type = "XMR", aggregation = "Month" - ) - - expect_no_error(check_report_config(report_config)) - }) - -"check measure_data: happy path" |> - test_that({ - - aggregated_datasheet <- tibble::tibble( - ref = c(1, 2, 3), - measure_name = c("M1", "M2", "M3"), - comment = c("comment", "comment", "comment") - ) - - events_datasheet <- tibble::tibble( - ref = c(1, 2, 3), - measure_name = c("M1", "M2", "M3"), - comment = c("comment", "comment", "comment"), - event_date_or_datetime = "there will be dates here" - ) - - measure_data <- list( - "week" = aggregated_datasheet, - "month" = aggregated_datasheet, - "events" = events_datasheet - ) - - expect_no_error( - check_measure_data(measure_data) - ) - - }) - -"check measure_data: missing columns throw an error" |> - test_that({ - - aggregated_datasheet <- tibble::tibble( - ref = c(1, 2, 3), - # measure_name = c("M1", "M2", "M3"), # missing column - comment = c("comment", "comment", "comment") - ) - - events_datasheet <- tibble::tibble( - ref = c(1, 2, 3), - measure_name = c("M1", "M2", "M3"), - comment = c("comment", "comment", "comment"), - event_date_or_datetime = "there will be dates here" - ) - - measure_data <- list( - "week" = aggregated_datasheet, - "month" = aggregated_datasheet, - "events" = events_datasheet - ) - - expect_error( - check_measure_data(measure_data), - "check_for_required_columns: Column 'measure_name' is missing from the 'week' data frame. Check for typos in the column names." - ) - - }) - -"check_dataset_is_complete: empty report_config passes without error" |> - test_that({ - empty_config <- tibble::tibble( - ref = character(), measure_name = character(), aggregation = character() - ) - - measure_data_df <- tibble::tibble( - ref = "1", measure_name = "M1", aggregation = "month" - ) - - expect_no_error( - check_dataset_is_complete(empty_config, measure_data_df) - ) - }) - - - -"check a_data: happy path" |> - test_that({ - - datasheet <- tibble::tibble( - ref = c(1, 2, 3), - measure_name = c("M1", "M2", "M3"), - comment = c("comment", "comment", "comment"), - "2024-01-01" = c(1, 2, 3) - ) - - a_data <- list( - "week" = datasheet, - "month" = datasheet - ) - - expect_no_error( - check_a_data(a_data) - ) - - }) - -"check a_data: non-list input throws an error" |> - test_that({ - expect_error( - check_a_data(data.frame(ref = 1, measure_name = "M1", comment = "c")), - "check_a_data: The data must be a list." - ) - }) - -"check a_data: data frame with no date columns throws an error" |> - test_that({ - datasheet <- tibble::tibble( - ref = 1, measure_name = "M1", comment = "c" - # no date columns - ) - - expect_error( - check_a_data(list(week = datasheet)), - "No date columns found in the 'week' sheet" - ) - }) - -"check a_data: missing columns throw an error" |> - test_that({ - - datasheet <- tibble::tibble( - ref = c(1, 2, 3), - # measure_name = c("M1", "M2", "M3"), # missing column - comment = c("comment", "comment", "comment") - ) - - a_data <- list( - "week" = datasheet, - "month" = datasheet - ) - - expect_error( - check_a_data(a_data), - "check_for_required_columns: Column 'measure_name' is missing from the 'week' data frame. Check for typos in the column names." - ) - - }) - -"check e_data: happy path" |> - test_that({ - - e_data <- tibble::tibble( - ref = c(1, 2, 3), - measure_name = c("M1", "M2", "M3"), - comment = c("comment", "comment", "comment"), - event_date_or_datetime = "there will be dates here" - ) - - expect_no_error( - check_e_data(e_data) - ) - - }) - -"check e_data: missing columns throw an error" |> - test_that({ - - e_data <- tibble::tibble( - ref = c(1, 2, 3), - measure_name = c("M1", "M2", "M3"), - comment = c("comment", "comment", "comment"), - # event_date_or_datetime = "there will be dates here" # missing column - ) - - expect_error( - check_e_data(e_data), - "check_for_required_columns: Column 'event_date_or_datetime' is missing from the 'events' data frame. Check for typos in the column names." - ) + expect_error( + check_e_data(e_data), + "check_for_required_columns: Column 'event_date_or_datetime' is missing from the 'events' data frame. Check for typos in the column names." + ) - }) +}) diff --git a/tests/testthat/test-get_updatedto_text.R b/tests/testthat/test-get_updatedto_text.R index be6928d..ababa68 100644 --- a/tests/testthat/test-get_updatedto_text.R +++ b/tests/testthat/test-get_updatedto_text.R @@ -2,92 +2,87 @@ # ceiling_date() on a datetime gives a different result than on a date, # so the function must coerce to Date first. -"updatedto_text handles dttms correctly 1" |> - test_that({ - d1 <- lubridate::as_date("2024-02-01") - d2 <- lubridate::as_datetime("2024-02-01") - - desired_result <- lubridate::as_date("2024-02-29") - unwanted_result <- lubridate::as_datetime("2024-01-31 23:59:59") - - aggregation <- "month" - - o1 <- lubridate::ceiling_date(d1, aggregation) - 1 - o2 <- lubridate::ceiling_date(d2, aggregation) - 1 - - expect_equal(o1, desired_result) - expect_false(identical(o2, desired_result)) - expect_equal(o2, unwanted_result) - }) - - -"updatedto_text handles dttms correctly 2" |> - test_that({ - d1 <- lubridate::as_date("2024-02-01") - d2 <- lubridate::as_datetime("2024-02-01") - - # the function needs to operate on a date not a datetime - d1 <- as.Date(d1) - d2 <- as.Date(d2) - - desired_result <- lubridate::as_date("2024-02-29") - - aggregation <- "month" - - o1 <- lubridate::ceiling_date(d1, aggregation) - lubridate::days(1) - o2 <- lubridate::ceiling_date(d2, aggregation) - lubridate::days(1) - - expect_equal(o1, desired_result) - expect_equal(o2, desired_result) - }) - - -"get_updatedto_text: all aggregation types - Thursday date" |> - test_that({ - d1 <- lubridate::as_date("2024-02-01") # A Thursday - - expect_identical(get_updatedto_text(d1, "none"), "29-Feb-2024") - expect_identical(get_updatedto_text(d1, "month"), "29-Feb-2024") - expect_identical(get_updatedto_text(d1, "day"), "01-Feb-2024") - expect_identical(get_updatedto_text(d1, "calendar_year"), "31-Dec-2024") - expect_identical(get_updatedto_text(d1, "week"), "04-Feb-2024") # following Sunday - }) - - -"get_updatedto_text: all aggregation types - Monday date" |> - test_that({ - d1 <- lubridate::as_date("2024-01-01") # A Monday - - expect_identical(get_updatedto_text(d1, "none"), "31-Jan-2024") - expect_identical(get_updatedto_text(d1, "month"), "31-Jan-2024") - expect_identical(get_updatedto_text(d1, "day"), "01-Jan-2024") - expect_identical(get_updatedto_text(d1, "calendar_year"), "31-Dec-2024") - expect_identical(get_updatedto_text(d1, "week"), "07-Jan-2024") # following Sunday - }) - - -"get_updatedto_text: error cases" |> - test_that({ - d1 <- lubridate::as_date("2024-01-01") - - expect_error( - get_updatedto_text(d1, "quarter"), - "get_updatedto_text: invalid aggregation (quarter) provided", - fixed = TRUE - ) - expect_error( - get_updatedto_text(d1, NA), - "get_updatedto_text: invalid aggregation (NA) provided", - fixed = TRUE - ) - expect_error( - get_updatedto_text(d1, c("week", "month")), - "get_updatedto_text: Multiple values for `aggregation` provided", - fixed = TRUE - ) - expect_error( - get_updatedto_text(as.Date(c("2024-01-01", "2024-02-01")), "month"), - "get_updatedto_text: Multiple values for `last_date` provided", - fixed = TRUE - ) - }) +test_that("updatedto_text handles dttms correctly 1", { + d1 <- lubridate::as_date("2024-02-01") + d2 <- lubridate::as_datetime("2024-02-01") + + desired_result <- lubridate::as_date("2024-02-29") + unwanted_result <- lubridate::as_datetime("2024-01-31 23:59:59") + + aggregation <- "month" + + o1 <- lubridate::ceiling_date(d1, aggregation) - 1 + o2 <- lubridate::ceiling_date(d2, aggregation) - 1 + + expect_equal(o1, desired_result) + expect_false(identical(o2, desired_result)) + expect_equal(o2, unwanted_result) +}) + + +test_that("updatedto_text handles dttms correctly 2", { + d1 <- lubridate::as_date("2024-02-01") + d2 <- lubridate::as_datetime("2024-02-01") + + # the function needs to operate on a date not a datetime + d1 <- as.Date(d1) + d2 <- as.Date(d2) + + desired_result <- lubridate::as_date("2024-02-29") + + aggregation <- "month" + + o1 <- lubridate::ceiling_date(d1, aggregation) - lubridate::days(1) + o2 <- lubridate::ceiling_date(d2, aggregation) - lubridate::days(1) + + expect_equal(o1, desired_result) + expect_equal(o2, desired_result) +}) + + +test_that("get_updatedto_text: all aggregation types - Thursday date", { + d1 <- lubridate::as_date("2024-02-01") # A Thursday + + expect_identical(get_updatedto_text(d1, "none"), "29-Feb-2024") + expect_identical(get_updatedto_text(d1, "month"), "29-Feb-2024") + expect_identical(get_updatedto_text(d1, "day"), "01-Feb-2024") + expect_identical(get_updatedto_text(d1, "calendar_year"), "31-Dec-2024") + expect_identical(get_updatedto_text(d1, "week"), "04-Feb-2024") # following Sunday +}) + + +test_that("get_updatedto_text: all aggregation types - Monday date", { + d1 <- lubridate::as_date("2024-01-01") # A Monday + + expect_identical(get_updatedto_text(d1, "none"), "31-Jan-2024") + expect_identical(get_updatedto_text(d1, "month"), "31-Jan-2024") + expect_identical(get_updatedto_text(d1, "day"), "01-Jan-2024") + expect_identical(get_updatedto_text(d1, "calendar_year"), "31-Dec-2024") + expect_identical(get_updatedto_text(d1, "week"), "07-Jan-2024") # following Sunday +}) + + +test_that("get_updatedto_text: error cases", { + d1 <- lubridate::as_date("2024-01-01") + + expect_error( + get_updatedto_text(d1, "quarter"), + "get_updatedto_text: invalid aggregation (quarter) provided", + fixed = TRUE + ) + expect_error( + get_updatedto_text(d1, NA), + "get_updatedto_text: invalid aggregation (NA) provided", + fixed = TRUE + ) + expect_error( + get_updatedto_text(d1, c("week", "month")), + "get_updatedto_text: Multiple values for `aggregation` provided", + fixed = TRUE + ) + expect_error( + get_updatedto_text(as.Date(c("2024-01-01", "2024-02-01")), "month"), + "get_updatedto_text: Multiple values for `last_date` provided", + fixed = TRUE + ) +}) diff --git a/tests/testthat/test-lengthen_measure_data.R b/tests/testthat/test-lengthen_measure_data.R index 4316d0c..3c60110 100644 --- a/tests/testthat/test-lengthen_measure_data.R +++ b/tests/testthat/test-lengthen_measure_data.R @@ -1,106 +1,102 @@ -"happy path" |> - test_that({ - .data <- tibble::tibble( - ref = 1, - measure_name = "a name", - comment = "a comment", - "2022-01-01" = 10, - "2022-02-01" = 20 - ) +test_that("happy path", { + .data <- tibble::tibble( + ref = 1, + measure_name = "a name", + comment = "a comment", + "2022-01-01" = 10, + "2022-02-01" = 20 + ) - expect_true(inherits(.data, "data.frame")) + expect_true(inherits(.data, "data.frame")) - expected_out <- tibble::tibble( - ref = c(1, 1), - measure_name = c("a name", "a name"), - comment = c("a comment", "a comment"), - date = lubridate::ymd(c("2022-01-01", "2022-02-01")), - value = c(10, 20) - ) + expected_out <- tibble::tibble( + ref = c(1, 1), + measure_name = c("a name", "a name"), + comment = c("a comment", "a comment"), + date = lubridate::ymd(c("2022-01-01", "2022-02-01")), + value = c(10, 20) + ) - expect_equal( - lengthen_measure_data(.data), - expected_out - ) - }) + expect_equal( + lengthen_measure_data(.data), + expected_out + ) +}) -"data frame input" |> - test_that({ - expect_error( - lengthen_measure_data("not a data frame"), - "lengthen_measure_data: The data must be a data frame." - ) - }) +test_that("data frame input", { + expect_error( + lengthen_measure_data("not a data frame"), + "lengthen_measure_data: The data must be a data frame." + ) +}) -"check input names" |> - test_that({ - ymd_regex <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$" - init_cols <- c("ref", "measure_name", "comment") +test_that("check input names", { + ymd_regex <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$" + init_cols <- c("ref", "measure_name", "comment") - df_names <- c("ref", "measure_name", "2022-01-01", "90210") + df_names <- c("ref", "measure_name", "2022-01-01", "90210") - expect_true( - all(purrr::map_lgl( - df_names, \(x) x %in% init_cols | - stringr::str_detect(x, "^[0-9]{5}$") | - stringr::str_detect(x, ymd_regex))) - ) - - df_names <- c(df_names, "other") - - expect_false( - all(purrr::map_lgl( + expect_true( + all(purrr::map_lgl( df_names, \(x) x %in% init_cols | stringr::str_detect(x, "^[0-9]{5}$") | stringr::str_detect(x, ymd_regex))) - ) - }) - - - -"check_pipeline" |> - test_that({ - - init_cols <- c("ref", "measure_name", "comment") - - .data <- tibble::tibble( - ref = c(1, 2), - measure_name = "a name", - comment = "a comment", - "2022-01-01" = c(10L, 12L), - "2022-02-01" = c(NA_integer_, 20L) - ) - - out1 <- .data |> - tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) - - tibble::tibble( - ref = c(1, 2, 2), - measure_name = "a name", - comment = "a comment", - date = c("2022-01-01", "2022-01-01", "2022-02-01"), - value = c(10, 12, 20) - ) |> - expect_equal(out1) - - - out2 <- .data |> - tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) |> - dplyr::mutate(across("date", quietly_convert_date)) - - tibble::tibble( - ref = c(1, 2, 2), - measure_name = "a name", - comment = "a comment", - date = lubridate::ymd(c("2022-01-01", "2022-01-01", "2022-02-01")), - value = c(10, 12, 20) - ) |> - expect_equal(out2) - }) + ) + + df_names <- c(df_names, "other") + + expect_false( + all(purrr::map_lgl( + df_names, \(x) x %in% init_cols | + stringr::str_detect(x, "^[0-9]{5}$") | + stringr::str_detect(x, ymd_regex))) + ) +}) + + + +test_that("check_pipeline", { + + init_cols <- c("ref", "measure_name", "comment") + + .data <- tibble::tibble( + ref = c(1, 2), + measure_name = "a name", + comment = "a comment", + "2022-01-01" = c(10L, 12L), + "2022-02-01" = c(NA_integer_, 20L) + ) + + out1 <- .data |> + tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) + + tibble::tibble( + ref = c(1, 2, 2), + measure_name = "a name", + comment = "a comment", + date = c("2022-01-01", "2022-01-01", "2022-02-01"), + value = c(10, 12, 20) + ) |> + expect_equal(out1) + + + out2 <- .data |> + tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) |> + dplyr::mutate(across("date", quietly_convert_date)) + + tibble::tibble( + ref = c(1, 2, 2), + measure_name = "a name", + comment = "a comment", + date = lubridate::ymd(c("2022-01-01", "2022-01-01", "2022-02-01")), + value = c(10, 12, 20) + ) |> + expect_equal(out2) +}) diff --git a/tests/testthat/test-parse_rebase_dates.R b/tests/testthat/test-parse_rebase_dates.R index 3864bfb..2765cd4 100644 --- a/tests/testthat/test-parse_rebase_dates.R +++ b/tests/testthat/test-parse_rebase_dates.R @@ -1,45 +1,40 @@ -"it has a happy path" |> - test_that({ - - expect_equal( - parse_rebase_dates("2020-01-01"), - as.Date("2020-01-01") - ) - - expect_equal( - parse_rebase_dates('"2020-01-01", "2020-02-01"'), - as.Date(c("2020-01-01", "2020-02-01")) - ) - }) - -"invalid dates cause an error" |> - test_that({ - - expect_error( - parse_rebase_dates("01-01-2020"), - "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." - ) - - expect_error( - parse_rebase_dates('"2020-01-01", "01-05-2020"'), - "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." - ) - }) - -"NULL input causes an error" |> - test_that({ - expect_error(parse_rebase_dates(NULL)) - }) - -"empty string returns NA (lubridate::ymd silently returns NA for empty input)" |> - test_that({ - expect_equal(parse_rebase_dates(""), as.Date(NA)) - }) - -"a single quoted date (no comma) is parsed correctly" |> - test_that({ - expect_equal( - parse_rebase_dates('"2020-01-01"'), - as.Date("2020-01-01") - ) - }) +test_that("it has a happy path", { + + expect_equal( + parse_rebase_dates("2020-01-01"), + as.Date("2020-01-01") + ) + + expect_equal( + parse_rebase_dates('"2020-01-01", "2020-02-01"'), + as.Date(c("2020-01-01", "2020-02-01")) + ) +}) + +test_that("invalid dates cause an error", { + + expect_error( + parse_rebase_dates("01-01-2020"), + "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." + ) + + expect_error( + parse_rebase_dates('"2020-01-01", "01-05-2020"'), + "parse_rebase_dates: rebase dates must be in 'YYYY-MM-DD' format." + ) +}) + +test_that("NULL input causes an error", { + expect_error(parse_rebase_dates(NULL)) +}) + +test_that("empty string returns NA (lubridate::ymd silently returns NA for empty input)", { + expect_equal(parse_rebase_dates(""), as.Date(NA)) +}) + +test_that("a single quoted date (no comma) is parsed correctly", { + expect_equal( + parse_rebase_dates('"2020-01-01"'), + as.Date("2020-01-01") + ) +}) diff --git a/tests/testthat/test-process_event_data_t.R b/tests/testthat/test-process_event_data_t.R index dd5a58c..a700c27 100644 --- a/tests/testthat/test-process_event_data_t.R +++ b/tests/testthat/test-process_event_data_t.R @@ -1,71 +1,67 @@ -"process_event_data_t: happy path" |> - test_that({ +test_that("process_event_data_t: happy path", { - e_data <- tibble::tibble( - "ref" = c(123, 123, 123), - "measure_name" = "Name", - "event_date_or_datetime" = as.POSIXct(c("2020-01-01", "2020-01-03", "2020-01-13")) - ) + e_data <- tibble::tibble( + "ref" = c(123, 123, 123), + "measure_name" = "Name", + "event_date_or_datetime" = as.POSIXct(c("2020-01-01", "2020-01-03", "2020-01-13")) + ) - cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") + cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") - expect_no_error( - result <- process_event_data_t(e_data, cutoff_dttm) - ) + expect_no_error( + result <- process_event_data_t(e_data, cutoff_dttm) + ) - expect_equal( - names(result), - c("aggregation", "ref", "measure_name", "date", "value") - ) + expect_equal( + names(result), + c("aggregation", "ref", "measure_name", "date", "value") + ) - expect_equal(result[["date"]], as.POSIXct(c("2020-01-03 00:00:00", "2020-01-13 00:00:00", "2020-01-31 23:59:59"))) - expect_equal(result[["value"]], c(2, 10, 18)) + expect_equal(result[["date"]], as.POSIXct(c("2020-01-03 00:00:00", "2020-01-13 00:00:00", "2020-01-31 23:59:59"))) + expect_equal(result[["value"]], c(2, 10, 18)) - }) +}) -"process_event_data_t: single event produces one row (time from event to cutoff)" |> - test_that({ - e_data <- tibble::tibble( - ref = "1", - measure_name = "Name", - event_date_or_datetime = as.POSIXct("2020-01-01") - ) - cutoff_dttm <- as.POSIXct("2020-01-11 23:59:59") +test_that("process_event_data_t: single event produces one row (time from event to cutoff)", { + e_data <- tibble::tibble( + ref = "1", + measure_name = "Name", + event_date_or_datetime = as.POSIXct("2020-01-01") + ) + cutoff_dttm <- as.POSIXct("2020-01-11 23:59:59") - result <- process_event_data_t(e_data, cutoff_dttm) + result <- process_event_data_t(e_data, cutoff_dttm) - expect_equal(nrow(result), 1L) - expect_equal(result[["value"]], 10L) # 10 whole days between event and cutoff - expect_equal(result[["date"]], cutoff_dttm) - }) + expect_equal(nrow(result), 1L) + expect_equal(result[["value"]], 10L) # 10 whole days between event and cutoff + expect_equal(result[["date"]], cutoff_dttm) +}) -"process_event_data_t: events with identical datetimes produce a zero time-between row" |> - test_that({ - e_data <- tibble::tibble( - ref = "1", - measure_name = "Name", - event_date_or_datetime = as.POSIXct(c("2020-01-05", "2020-01-05")) - ) - cutoff_dttm <- as.POSIXct("2020-01-15") +test_that("process_event_data_t: events with identical datetimes produce a zero time-between row", { + e_data <- tibble::tibble( + ref = "1", + measure_name = "Name", + event_date_or_datetime = as.POSIXct(c("2020-01-05", "2020-01-05")) + ) + cutoff_dttm <- as.POSIXct("2020-01-15") - result <- process_event_data_t(e_data, cutoff_dttm) + result <- process_event_data_t(e_data, cutoff_dttm) - expect_equal(nrow(result), 2L) - expect_equal(result[["value"]], c(0L, 10L)) - }) + expect_equal(nrow(result), 2L) + expect_equal(result[["value"]], c(0L, 10L)) +}) -"process_event_data_t: passing in an empty event list returns NULL" |> - test_that({ +test_that("process_event_data_t: passing in an empty event list returns NULL", { - events <- tibble::tibble( - "ref" = numeric(), - "measure_name" = character(), - "event_date_or_datetime" = lubridate::POSIXct() - ) + events <- tibble::tibble( + "ref" = numeric(), + "measure_name" = character(), + "event_date_or_datetime" = lubridate::POSIXct() + ) - expect_equal( - process_event_data_t(events), - NULL - ) + expect_equal( + process_event_data_t(events), + NULL + ) - }) +}) diff --git a/tests/testthat/test-spcr_make_data_bundle.R b/tests/testthat/test-spcr_make_data_bundle.R index d0e9cc6..130d64b 100644 --- a/tests/testthat/test-spcr_make_data_bundle.R +++ b/tests/testthat/test-spcr_make_data_bundle.R @@ -1,172 +1,165 @@ -"spcr_make_data_bundle: happy path" |> - test_that({ - - expect_no_error( - spcr_make_data_bundle( - test_measure_data, - test_report_config, - test_measure_config - ) +test_that("spcr_make_data_bundle: happy path", { + + expect_no_error( + spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config ) - }) + ) +}) -"spcr_make_data_bundle: it accepts a custom cutoff dttm" |> - test_that({ +test_that("spcr_make_data_bundle: it accepts a custom cutoff dttm", { - expect_no_error( - spcr_make_data_bundle( - test_measure_data, - test_report_config, - test_measure_config, - data_cutoff_dttm = as.POSIXct("2023-10-31 23:59:59") - ) + expect_no_error( + spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config, + data_cutoff_dttm = as.POSIXct("2023-10-31 23:59:59") ) - }) + ) +}) -"spcr_make_data_bundle: there is a helpful error if the 'events' worksheet is missing" |> - test_that({ +test_that("spcr_make_data_bundle: there is a helpful error if the 'events' worksheet is missing", { - measure_data_no_events <- test_measure_data - measure_data_no_events[["events"]] <- NULL + measure_data_no_events <- test_measure_data + measure_data_no_events[["events"]] <- NULL - expect_error( - spcr_make_data_bundle( - measure_data_no_events, - test_report_config, # note this will still be calling for t charts - test_measure_config - ), - "The 'events' worksheet is missing from 'measure_data'." - ) + expect_error( + spcr_make_data_bundle( + measure_data_no_events, + test_report_config, # note this will still be calling for t charts + test_measure_config + ), + "The 'events' worksheet is missing from 'measure_data'." + ) - }) +}) -"spcr_make_data_bundle: it is possible to make a data_bundle if no event data is supplied" |> - test_that({ +test_that("spcr_make_data_bundle: it is possible to make a data_bundle if no event data is supplied", { - measure_data_no_events <- test_measure_data - measure_data_no_events[["events"]] <- tibble::tibble( - "ref" = numeric(), - "measure_name" = character(), - "comment" = character(), - "event_date_or_datetime" = date() - ) + measure_data_no_events <- test_measure_data + measure_data_no_events[["events"]] <- tibble::tibble( + "ref" = numeric(), + "measure_name" = character(), + "comment" = character(), + "event_date_or_datetime" = date() + ) - report_config <- test_report_config |> - dplyr::filter(spc_chart_type != "t") # event data needed for t charts + report_config <- test_report_config |> + dplyr::filter(spc_chart_type != "t") # event data needed for t charts - expect_no_error( - spcr_make_data_bundle( - measure_data_no_events, - report_config, - test_measure_config - ) + expect_no_error( + spcr_make_data_bundle( + measure_data_no_events, + report_config, + test_measure_config ) + ) - }) +}) -"test data bundle process" |> - test_that({ +test_that("test data bundle process", { - # stub out the Sys.time call with a repeating value - mockery::stub(spcr_make_data_bundle, "Sys.time", as.POSIXct("2023-12-04 21:25:25")) + # stub out the Sys.time call with a repeating value + mockery::stub(spcr_make_data_bundle, "Sys.time", as.POSIXct("2023-12-04 21:25:25")) - db <- spcr_make_data_bundle( - test_measure_data, - test_report_config, - test_measure_config - ) + db <- spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config + ) - # some spot checks on the above conversion of the last_data_point to the - # appropriate character format - expect_equal(db[["last_data_point"]][[1]], "222") - expect_equal(db[["last_data_point"]][[2]], "73%") - expect_equal(db[["last_data_point"]][[3]], "0.46") - expect_equal(db[["last_data_point"]][[9]], "430d") + # some spot checks on the above conversion of the last_data_point to the + # appropriate character format + expect_equal(db[["last_data_point"]][[1]], "222") + expect_equal(db[["last_data_point"]][[2]], "73%") + expect_equal(db[["last_data_point"]][[3]], "0.46") + expect_equal(db[["last_data_point"]][[9]], "430d") - }) +}) -"test the whole thing" |> - test_that({ - out <- spcr_make_data_bundle( - measure_data = test_measure_data, - report_config = test_report_config, - measure_config = test_measure_config) - - expect_length(out, 27) - expect_equal(nrow(out), nrow(test_report_config)) - expect_type(out[["ref"]], "character") - expect_type(out[["target"]], "double") - expect_type(out[["allowable_days_lag"]], "integer") - expect_type(out[["measure_data"]], "list") - expect_s3_class(out[["last_date"]], "POSIXct") - expect_type(out[["updated_to"]], "character") - expect_type(out[["domain_heading"]], "logical") - - # set all targets to NA - test_measure_config2 <- test_measure_config |> - dplyr::mutate(across("target", \(x) NA_real_)) - - expect_no_error(spcr_make_data_bundle( - measure_data = test_measure_data, - report_config = test_report_config, - measure_config = test_measure_config2)) +test_that("test the whole thing", { + out <- spcr_make_data_bundle( + measure_data = test_measure_data, + report_config = test_report_config, + measure_config = test_measure_config) - out2 <- spcr_make_data_bundle( - measure_data = test_measure_data, - report_config = test_report_config, - measure_config = test_measure_config2) + expect_length(out, 27) + expect_equal(nrow(out), nrow(test_report_config)) + expect_type(out[["ref"]], "character") + expect_type(out[["target"]], "double") + expect_type(out[["allowable_days_lag"]], "integer") + expect_type(out[["measure_data"]], "list") + expect_s3_class(out[["last_date"]], "POSIXct") + expect_type(out[["updated_to"]], "character") + expect_type(out[["domain_heading"]], "logical") + + # set all targets to NA + test_measure_config2 <- test_measure_config |> + dplyr::mutate(across("target", \(x) NA_real_)) + + expect_no_error(spcr_make_data_bundle( + measure_data = test_measure_data, + report_config = test_report_config, + measure_config = test_measure_config2)) + + out2 <- spcr_make_data_bundle( + measure_data = test_measure_data, + report_config = test_report_config, + measure_config = test_measure_config2) - expect_length(out2, 27) - expect_equal(nrow(out2), nrow(test_report_config)) + expect_length(out2, 27) + expect_equal(nrow(out2), nrow(test_report_config)) - }) +}) # this is more properly a test for the check_measure_names() function # but it's good to test it as part of the make_bundle() workflow too -"error for name mismatches before other errors" |> - test_that({ - - # a measure_name mismatch in the measure config will throw a warning - test_measure_config2 <- test_measure_config |> - dplyr::mutate(across("measure_name", \(x) stringr::str_replace(x, "Capacity", "Capaciteeee"))) - - expect_warning( - spcr_make_data_bundle( - measure_data = test_measure_data, - report_config = test_report_config, - measure_config = test_measure_config2 - ), - "check_measure_names: There is a name mismatch for measure ref: 5. The title in the data bundle is 'Capacity'. The title in the measure config is 'Capaciteeee'." - ) +test_that("error for name mismatches before other errors", { - # a measure_name mismatch in the measure data will throw a warning - test_measure_data2 <- test_measure_data |> - purrr::modify_at("month", \(x) - dplyr::mutate(x, across("measure_name", \(x) stringr::str_replace(x, "Widgets", "widgets")))) - - expect_warning( - spcr_make_data_bundle( - measure_data = test_measure_data2, - report_config = test_report_config, - measure_config = test_measure_config - ), - "check_measure_names: There is a name mismatch for measure ref: 11. The title in the data bundle is 'widgets'. The title in the measure config is 'Widgets'." - ) + # a measure_name mismatch in the measure config will throw a warning + test_measure_config2 <- test_measure_config |> + dplyr::mutate(across("measure_name", \(x) stringr::str_replace(x, "Capacity", "Capaciteeee"))) + + expect_warning( + spcr_make_data_bundle( + measure_data = test_measure_data, + report_config = test_report_config, + measure_config = test_measure_config2 + ), + "check_measure_names: There is a name mismatch for measure ref: 5. The title in the data bundle is 'Capacity'. The title in the measure config is 'Capaciteeee'." + ) + + # a measure_name mismatch in the measure data will throw a warning + test_measure_data2 <- test_measure_data |> + purrr::modify_at("month", \(x) + dplyr::mutate(x, across("measure_name", \(x) stringr::str_replace(x, "Widgets", "widgets")))) + + expect_warning( + spcr_make_data_bundle( + measure_data = test_measure_data2, + report_config = test_report_config, + measure_config = test_measure_config + ), + "check_measure_names: There is a name mismatch for measure ref: 11. The title in the data bundle is 'widgets'. The title in the measure config is 'Widgets'." + ) - # but a measure_name change in the report config should not throw an error - test_report_config2 <- test_report_config |> - dplyr::mutate(across("measure_name", \(x) stringr::str_replace(x, "Widgets", "widgets"))) + # but a measure_name change in the report config should not throw an error + test_report_config2 <- test_report_config |> + dplyr::mutate(across("measure_name", \(x) stringr::str_replace(x, "Widgets", "widgets"))) - expect_no_error( - spcr_make_data_bundle( - measure_data = test_measure_data, - report_config = test_report_config2, - measure_config = test_measure_config - ) + expect_no_error( + spcr_make_data_bundle( + measure_data = test_measure_data, + report_config = test_report_config2, + measure_config = test_measure_config ) + ) - }) +}) diff --git a/tests/testthat/test-spcr_make_report.R b/tests/testthat/test-spcr_make_report.R index c392a92..2511b1a 100644 --- a/tests/testthat/test-spcr_make_report.R +++ b/tests/testthat/test-spcr_make_report.R @@ -2,97 +2,94 @@ # These tests actually render the Rmd and write files to a temp directory. # They are skipped on CI because rendering takes ~30 seconds. -"spcr_make_report: html and csv files are created" |> - test_that({ - skip_on_ci() - skip_if( - system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", - "Report.Rmd not found — run devtools::load_all() first" +test_that("spcr_make_report: html and csv files are created", { + skip_on_ci() + skip_if( + system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", + "Report.Rmd not found — run devtools::load_all() first" + ) + + mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) + mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) + + db <- spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config + ) + + withr::with_tempdir({ + result <- spcr_make_report( + data_bundle = db, + output_directory = ".", + output_type = c("html", "csv") ) - mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) - mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) + html_files <- list.files(".", pattern = "\\.html$", full.names = TRUE) + csv_files <- list.files(".", pattern = "\\.csv$", full.names = TRUE) - db <- spcr_make_data_bundle( - test_measure_data, - test_report_config, - test_measure_config - ) - - withr::with_tempdir({ - result <- spcr_make_report( - data_bundle = db, - output_directory = ".", - output_type = c("html", "csv") - ) - - html_files <- list.files(".", pattern = "\\.html$", full.names = TRUE) - csv_files <- list.files(".", pattern = "\\.csv$", full.names = TRUE) - - expect_true(result) - expect_length(html_files, 1) - expect_length(csv_files, 1) - expect_gt(file.size(html_files[[1]]), 0) - expect_gt(file.size(csv_files[[1]]), 0) - }) + expect_true(result) + expect_length(html_files, 1) + expect_length(csv_files, 1) + expect_gt(file.size(html_files[[1]]), 0) + expect_gt(file.size(csv_files[[1]]), 0) }) - - -"spcr_make_report: html-only output creates no csv" |> - test_that({ - skip_on_ci() - skip_if( - system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", - "Report.Rmd not found — run devtools::load_all() first" +}) + + +test_that("spcr_make_report: html-only output creates no csv", { + skip_on_ci() + skip_if( + system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", + "Report.Rmd not found — run devtools::load_all() first" + ) + + mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) + mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) + + db <- spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config + ) + + withr::with_tempdir({ + spcr_make_report( + data_bundle = db, + output_directory = ".", + output_type = "html" ) - mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) - mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) - - db <- spcr_make_data_bundle( - test_measure_data, - test_report_config, - test_measure_config - ) - - withr::with_tempdir({ - spcr_make_report( - data_bundle = db, - output_directory = ".", - output_type = "html" - ) - - expect_length(list.files(".", pattern = "\\.html$"), 1) - expect_length(list.files(".", pattern = "\\.csv$"), 0) - }) + expect_length(list.files(".", pattern = "\\.html$"), 1) + expect_length(list.files(".", pattern = "\\.csv$"), 0) }) - - -"spcr_make_report: returns invisible TRUE" |> - test_that({ - skip_on_ci() - skip_if( - system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", - "Report.Rmd not found — run devtools::load_all() first" - ) - - mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) - mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) - - db <- spcr_make_data_bundle( - test_measure_data, - test_report_config, - test_measure_config - ) - - withr::with_tempdir({ - result <- withVisible(spcr_make_report( - data_bundle = db, - output_directory = ".", - output_type = "html" - )) - - expect_true(result$value) - expect_false(result$visible) - }) +}) + + +test_that("spcr_make_report: returns invisible TRUE", { + skip_on_ci() + skip_if( + system.file("Rmd", "Report.Rmd", package = "SPCreporter") == "", + "Report.Rmd not found — run devtools::load_all() first" + ) + + mockery::stub(spcr_make_report, "utils::browseURL", invisible(NULL)) + mockery::stub(spcr_make_report, "beepr::beep", invisible(NULL)) + + db <- spcr_make_data_bundle( + test_measure_data, + test_report_config, + test_measure_config + ) + + withr::with_tempdir({ + result <- withVisible(spcr_make_report( + data_bundle = db, + output_directory = ".", + output_type = "html" + )) + + expect_true(result$value) + expect_false(result$visible) }) +}) From 9b7994a112eee600c99383fa5cf0f6c612881191 Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Sat, 25 Apr 2026 00:17:10 +0100 Subject: [PATCH 12/13] bump dev version to 0.2.1.9000 Co-Authored-By: Claude Sonnet 4.6 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index ea9b519..90bcbd9 100644 --- a/DESCRIPTION +++ b/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")) From d2dd0c1e03b17f0e72a432912aca311dff81ac3d Mon Sep 17 00:00:00 2001 From: Tom Smith Date: Sat, 25 Apr 2026 00:37:30 +0100 Subject: [PATCH 13/13] replace non-ASCII symbols with Unicode escapes in display_text.R Co-Authored-By: Claude Sonnet 4.6 --- R/display_text.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/display_text.R b/R/display_text.R index 03f9f1b..5152caa 100644 --- a/R/display_text.R +++ b/R/display_text.R @@ -20,10 +20,8 @@ get_target_text <- function(target, improvement_direction, unit) { dplyr::case_when( target == 0 & imp_dir == "decrease" ~ string, target == 1 & unit == "%" & imp_dir == "increase" ~ string, - # ≤ is: ≤ - !is.na(target) & imp_dir == "decrease" ~ paste0("≤ ", string), - # ≥ is: ≥ - !is.na(target) & imp_dir == "increase" ~ paste0("≥ ", string), + !is.na(target) & imp_dir == "decrease" ~ paste0("\u2264 ", string), + !is.na(target) & imp_dir == "increase" ~ paste0("\u2265 ", string), TRUE ~ string ) }