From 946f607aa66f3d08c877bd293f9072437c5dba64 Mon Sep 17 00:00:00 2001 From: Fran Barton Date: Sun, 12 Jan 2025 20:28:14 +0000 Subject: [PATCH 01/16] Add .lintr config file --- .Rbuildignore | 1 + .lintr | 10 ++++++++++ 2 files changed, 11 insertions(+) create mode 100644 .lintr diff --git a/.Rbuildignore b/.Rbuildignore index e8fd69d..b0c77d4 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,3 +11,4 @@ ^\.github$ .*\.xlsx$ .*\.code-workspace$ +^\.lintr$ diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..6608207 --- /dev/null +++ b/.lintr @@ -0,0 +1,10 @@ +linters: linters_with_defaults( + commented_code_linter = NULL, + indentation_linter = NULL + ) # see vignette("lintr") +encoding: "UTF-8" +exclusions: list( + "vignettes/get_started.Rmd", + "vignettes/multiple_reports.Rmd", + "inst/Rmd/Report.Rmd" + ) From df58e5f8bf205da08f40babd8b11fe735701f8e5 Mon Sep 17 00:00:00 2001 From: Fran Barton Date: Sun, 12 Jan 2025 20:28:29 +0000 Subject: [PATCH 02/16] Delete reprex file that shouldn't have been there --- 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 71a086b30b79b968ed457a7c1fccb269569235a0 Mon Sep 17 00:00:00 2001 From: Fran Barton Date: Sun, 12 Jan 2025 20:37:39 +0000 Subject: [PATCH 03/16] Remove unnecessary pkg:: infixes --- R/checking_functions.R | 18 +++++++++--------- R/helper_functions.R | 12 ++++++------ tests/testthat/test-helper_functions.R | 4 ++-- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index 95eb730..b207ec9 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -5,14 +5,14 @@ #' @returns The input list of data frames, after checking for necessary columns #' @noRd check_measure_data <- function(measure_data) { - assertthat::assert_that( + assert_that( inherits(measure_data, "list"), msg = "check_measure_data: The data must be a list." ) measure_data <- rlang::set_names(measure_data, tolower) - assertthat::assert_that( + assert_that( any(c("week", "month") %in% names(measure_data)), msg = paste0( "check_measure_data: ", @@ -49,7 +49,7 @@ check_measure_data <- function(measure_data) { #' @returns The input list of data frames, after checking for necessary columns #' @noRd check_a_data <- function(a_data) { - assertthat::assert_that( + assert_that( inherits(a_data, "list"), msg = "check_measure_data: The data must be a list." ) @@ -84,7 +84,7 @@ check_e_data <- function(e_data) { if(is.null(e_data)) stop("The 'events' worksheet is missing from 'measure_data'.") - assertthat::assert_that( + assert_that( inherits(e_data, "data.frame"), msg = "check_event_data: The data must be a data frame." ) @@ -108,7 +108,7 @@ check_e_data <- function(e_data) { #' @returns The input data frame after some checks and transformations #' @noRd check_report_config <- function(report_config) { - assertthat::assert_that( + assert_that( inherits(report_config, "data.frame"), msg = "check_report_config: The report config must be a data frame." ) @@ -145,7 +145,7 @@ check_report_config <- function(report_config) { #' @returns The input data frame after some checks and transformations #' @noRd check_measure_config <- function(measure_config) { - assertthat::assert_that( + assert_that( inherits(measure_config, "data.frame"), msg = "check_measure_config: config_data must be a data frame" ) @@ -207,7 +207,7 @@ check_measure_config <- function(measure_config) { #' @noRd check_measure_names <- function(ref_no, measure_data, measure_config) { # check that the config table includes this ref_no number - assertthat::assert_that( + assert_that( ref_no %in% measure_config[["ref"]], msg = glue( "check_measure_names: ", @@ -225,7 +225,7 @@ check_measure_names <- function(ref_no, measure_data, measure_config) { dplyr::pull("measure_name") |> unique() - assertthat::assert_that( + assert_that( length(c_title) == 1, msg = glue( "check_measure_names: ", @@ -328,7 +328,7 @@ check_dataset_is_complete <- function(report_config, measure_data) { # build an error message if there are missing data items - assertthat::assert_that( + assert_that( nrow(missing_data) == 0, msg = usethis::ui_stop( dplyr::slice(missing_data, 1) |> diff --git a/R/helper_functions.R b/R/helper_functions.R index cf44d85..12cef9d 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -5,7 +5,7 @@ #' @returns data frame. Data frame in long format #' @noRd lengthen_measure_data <- function(.data) { - assertthat::assert_that( + assert_that( inherits(.data, "data.frame"), msg = "lengthen_measure_data: The data must be a data frame." ) @@ -14,7 +14,7 @@ lengthen_measure_data <- function(.data) { 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( + assert_that( all(purrr::map_lgl( names(.data), \(x) x %in% init_cols | stringr::str_detect(x, "^[0-9]{5}$") | @@ -320,22 +320,22 @@ calculate_stale_data <- function(updated_to, lag, cutoff_dttm) { warning = \(w) "calculate_stale_data: The updated_to date is not in the required '%d-%b-%Y' format." ) - assertthat::assert_that( + 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( + assert_that( all(lag %% 1 == 0), msg = "calculate_stale_data: The lag argument must be an integer." ) - assertthat::assert_that( + 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 + lag <- days(lag) + lubridate::hms("23:59:59") # convert to a period if_else((updated_to + lag) < cutoff_dttm, "stale", "fresh") } diff --git a/tests/testthat/test-helper_functions.R b/tests/testthat/test-helper_functions.R index b605eff..3472c96 100644 --- a/tests/testthat/test-helper_functions.R +++ b/tests/testthat/test-helper_functions.R @@ -34,8 +34,8 @@ aggregation <- "month" - o1 <- lubridate::ceiling_date(d1, aggregation) - lubridate::days(1) - o2 <- lubridate::ceiling_date(d2, aggregation) - lubridate::days(1) + o1 <- lubridate::ceiling_date(d1, aggregation) - days(1) + o2 <- lubridate::ceiling_date(d2, aggregation) - days(1) expect_equal(o1, desired_result) expect_equal(o2, desired_result) From 0a496f22762b0e8f4667491a7d7daf938354400b Mon Sep 17 00:00:00 2001 From: Fran Barton Date: Sun, 12 Jan 2025 20:42:11 +0000 Subject: [PATCH 04/16] Remove unnecessary all_of()s --- R/checking_functions.R | 2 +- R/spcr_make_data_bundle.R | 14 +------------- R/spcr_make_report.R | 10 +++++----- 3 files changed, 7 insertions(+), 19 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index b207ec9..ce8da5e 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -323,7 +323,7 @@ check_for_optional_columns <- function(.data, optional_columns) { check_dataset_is_complete <- function(report_config, measure_data) { missing_data <- report_config |> - dplyr::select(all_of(c("ref", "measure_name", "aggregation"))) |> + dplyr::select(c("ref", "measure_name", "aggregation")) |> dplyr::anti_join(measure_data, by = c("ref", "aggregation")) diff --git a/R/spcr_make_data_bundle.R b/R/spcr_make_data_bundle.R index 826698e..6892b6c 100644 --- a/R/spcr_make_data_bundle.R +++ b/R/spcr_make_data_bundle.R @@ -89,19 +89,7 @@ spcr_make_data_bundle <- function( # Check that measure data that is supposed to be integer data is supplied as # such, or raise a warning message - nested_data |> - dplyr::filter(if_any("unit", \(x) x == "integer")) |> - tidyr::hoist("measure_data", "value") |> - dplyr::select(all_of(c(x = "value", y = "ref"))) |> - purrr::pwalk(\(x, y) if (any(round(x) != x)) { - warning( - glue( - "spcr_make_data_bundle: ", - "Measure {y} is configured as an integer, ", - "but has been supplied with decimal data." - ) - ) - }) + dplyr::select(c(x = "value", y = "ref")) |> nested_data |> dplyr::mutate( diff --git a/R/spcr_make_report.R b/R/spcr_make_report.R index 3bb38fe..2a1463e 100644 --- a/R/spcr_make_report.R +++ b/R/spcr_make_report.R @@ -49,31 +49,31 @@ spcr_make_report <- function( # Create list of source data for SPC charts spc_data <- data_bundle |> - dplyr::select(all_of(c( + dplyr::select(c( "target", "rebase_dates", "improvement_direction", "measure_data" - ))) |> + )) |> purrr::pmap(make_spc_data, .progress = "SPC data") # Create list of SPC charts spc_charts <- data_bundle |> - dplyr::select(all_of(c( + dplyr::select(c( "ref", "measure_name", "data_source", "unit", "spc_chart_type", "aggregation" - ))) |> + )) |> dplyr::mutate(label_limits = annotate_limits) |> dplyr::mutate(spc_data = spc_data) |> purrr::pmap(make_spc_chart, .progress = "SPC charts") tmp_files <- data_bundle |> - dplyr::select(all_of(c(x = "ref", y = "aggregation"))) |> + dplyr::select(c(x = "ref", y = "aggregation")) |> purrr::pmap_chr(\(x, y) glue("tmp_{x}_{y}_")) |> tempfile(fileext = ".png") From d1f383e0b9faabc516b83b54fa8e688ff36fcc28 Mon Sep 17 00:00:00 2001 From: Fran Barton Date: Sun, 12 Jan 2025 20:55:23 +0000 Subject: [PATCH 05/16] Reformat to keep to 80ch line length where poss --- R/checking_functions.R | 65 ++++++++++++--------- R/helper_functions.R | 40 ++++++++----- R/process_event_data_t.R | 25 +++++--- R/spcr_make_data_bundle.R | 22 ++++++- R/spcr_make_report.R | 38 ++++++++---- tests/testthat/test-calculate_stale_data.R | 5 +- tests/testthat/test-check_measure_data.R | 18 ++++-- tests/testthat/test-checking_functions.R | 60 ++++++++++++++----- tests/testthat/test-lengthen_measure_data.R | 8 ++- tests/testthat/test-process_event_data_t.R | 11 +++- tests/testthat/test-spcr_make_data_bundle.R | 30 +++++++--- 11 files changed, 227 insertions(+), 95 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index ce8da5e..05efc58 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -1,6 +1,7 @@ #' Check the incoming measure data and transform as needed #' -#' @param measure_data list. A list of data frames containing a combination of aggregated data and event data +#' @param measure_data list. A list of data frames containing a combination of +#' aggregated data and event data #' #' @returns The input list of data frames, after checking for necessary columns #' @noRd @@ -82,7 +83,9 @@ check_a_data <- function(a_data) { #' @noRd check_e_data <- function(e_data) { - if(is.null(e_data)) stop("The 'events' worksheet is missing from 'measure_data'.") + if (is.null(e_data)) { + stop("The 'events' worksheet is missing from 'measure_data'.") + } assert_that( inherits(e_data, "data.frame"), @@ -186,7 +189,8 @@ check_measure_config <- function(measure_config) { across("improvement_direction", tolower), # " marks in the comment mess up the render process later across("rebase_comment", \(x) stringr::str_replace_all(x, "\\\"", "'")), - # target and allowable_days_lag are the only cols that should end up numeric + # `target` and `allowable_days_lag` are the only cols that should + # end up as numeric. across("target", \(x) as.numeric(dplyr::na_if(x, "-"))), across("allowable_days_lag", \(x) as.integer(tidyr::replace_na(x, "0"))) ) @@ -240,10 +244,16 @@ check_measure_names <- function(ref_no, measure_data, measure_config) { \(x) ifelse( x == c_title, usethis::ui_silence(TRUE), - usethis::ui_warn( - c("check_measure_names: There is a name mismatch for measure ref: {ref_no}. The title in the data bundle is '{x}'. The title in the measure config is '{c_title}'.") - ))) - + usethis::ui_warn(c( + paste0( + "check_measure_names: There is a name mismatch for measure ref: ", + "{ref_no}." + ), + "The title in the data bundle is '{x}'.", + "The title in the measure config is '{c_title}'." + )) + ) + }) invisible(TRUE) } @@ -270,10 +280,13 @@ check_for_required_columns <- function(.data, df_name, required_columns) { first_missing_column <- missing_columns[1] # throw the error - usethis::ui_stop( - "check_for_required_columns: Column '{first_missing_column}' is missing from the '{df_name}' data frame. Check for typos in the column names." - ) - } else .data + usethis::ui_stop(paste0( + "check_for_required_columns: Column '{first_missing_column}' is missing ", + "from the '{df_name}' data frame. Check for typos in the column names." + )) + } else { + .data + } } @@ -295,11 +308,11 @@ check_for_optional_columns <- function(.data, optional_columns) { # find the name of the first missing col for the console message first_missing_column <- missing_columns[1] - usethis::ui_info( - c( - "check_for_optional_columns: Optional column '{first_missing_column}' is missing. Adding it." - ) - ) + usethis::ui_info(paste0( + "check_for_optional_columns: Optional column '{first_missing_column}' ", + "is missing. Adding it." + )) + missing_columns |> purrr::reduce( \(x, y) tibble::add_column(x, {{y}} := NA_character_), @@ -316,7 +329,8 @@ check_for_optional_columns <- function(.data, optional_columns) { #' Check all required data items are provided #' -#' @param report_config A data frame. The report config detailing required report items +#' @param report_config A data frame. The report config detailing required +#' report items #' @param measure_data Data frame in wide format #' #' @returns logical TRUE if check is successful, else an error message @@ -326,18 +340,17 @@ check_dataset_is_complete <- function(report_config, measure_data) { dplyr::select(c("ref", "measure_name", "aggregation")) |> dplyr::anti_join(measure_data, by = c("ref", "aggregation")) - # build an error message if there are missing data items assert_that( nrow(missing_data) == 0, msg = usethis::ui_stop( - dplyr::slice(missing_data, 1) |> - stringr::str_glue_data( - "check_dataset_is_complete: ", - "Data is missing for {nrow(missing_data)} report items. ", - "The first is ref {ref}, '{measure_name}', aggregation: {aggregation}." - ) - )) - + glue::glue_data( + dplyr::slice(missing_data, 1), + "check_dataset_is_complete: ", + "Data is missing for {nrow(missing_data)} report items. ", + "The first is ref {ref}, '{measure_name}', aggregation: {aggregation}" + ) + ) + ) invisible(TRUE) } diff --git a/R/helper_functions.R b/R/helper_functions.R index 12cef9d..50023ae 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -10,9 +10,15 @@ lengthen_measure_data <- function(.data) { 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") + # should match date strings of the form 2022-06-01 + ymd_rx <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$" + init_cols <- c( + "aggregation", + "measure_prefix", + "ref", + "measure_name", + "comment" + ) assert_that( all(purrr::map_lgl( @@ -27,14 +33,9 @@ lengthen_measure_data <- function(.data) { 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 - ), + head(stringr::str_subset( + setdiff(names(.data), init_cols), glue("^[0-9]{5}$|{ymd_rx}"), TRUE + ), 1), collapse = " " ) ) @@ -43,7 +44,9 @@ lengthen_measure_data <- function(.data) { # 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) |> + 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 @@ -96,7 +99,6 @@ get_target_text <- function(target, improvement_direction, unit) { #' @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( @@ -317,13 +319,21 @@ get_variation_type <- function(spc, improvement_direction) { 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." + warning = \(w) { + paste0( + "calculate_stale_data: The updated_to date is not in the required ", + "'%d-%b-%Y' format." + ) + } ) 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." + msg = paste0( + "calculate_stale_data: Unable to convert the updated_to argument ", + "text to a valid date." + ) ) assert_that( diff --git a/R/process_event_data_t.R b/R/process_event_data_t.R index aae9bb6..bbfd2c5 100644 --- a/R/process_event_data_t.R +++ b/R/process_event_data_t.R @@ -9,21 +9,28 @@ process_event_data_t <- function(event_data, data_cutoff_dttm){ if(nrow(event_data) == 0) return(NULL) - processed_data <- event_data |> - dplyr::mutate( - aggregation = "none" + event_data |> + dplyr::mutate(aggregation = "none") |> + # Remove events after the cutoff time (should only happen for + # retrospective reports). + dplyr::filter( + if_any("event_date_or_datetime", \(x) x <= data_cutoff_dttm) ) |> - dplyr::filter(.data$event_date_or_datetime < data_cutoff_dttm) |> # remove events after the cutoff time (should only happen for retrospective reports) - dplyr::group_by(.data$ref) |> - dplyr::arrange(.data$event_date_or_datetime) |> + dplyr::group_by(pick("ref")) |> + dplyr::arrange(pick("event_date_or_datetime")) |> # add the theoretical "today" event to each group - dplyr::group_modify(~ tibble::add_row(.x, event_date_or_datetime = data_cutoff_dttm)) |> + dplyr::group_modify(\(x, y) { + tibble::add_row(x, event_date_or_datetime = data_cutoff_dttm) + }) |> # calculate the time between events, in days dplyr::mutate( - time_between = difftime(.data$event_date_or_datetime, dplyr::lag(.data$event_date_or_datetime), units = "days"), - time_between = as.integer(.data$time_between), + time_between = as.integer(difftime( + .data[["event_date_or_datetime"]], + dplyr::lag(.data[["event_date_or_datetime"]]), + units = "days" + )) ) |> dplyr::filter(!is.na(.data$time_between)) |> dplyr::ungroup() |> diff --git a/R/spcr_make_data_bundle.R b/R/spcr_make_data_bundle.R index 6892b6c..6112a7a 100644 --- a/R/spcr_make_data_bundle.R +++ b/R/spcr_make_data_bundle.R @@ -3,9 +3,11 @@ #' @param measure_data list. List containing data frames of data in wide format #' @param report_config data frame. Config information for the report #' @param measure_config data frame. Config information for the measures -#' @param data_cutoff_dttm POSIXct. The data cutoff date-time (the last date-time for data in the report eg. month-end) +#' @param data_cutoff_dttm POSIXct. The data cutoff date-time (the last +#' date-time for data in the report eg. month-end) #' -#' @returns data frame. A nested data frame containing source data for the report +#' @returns data frame. A nested data frame containing source data for the +#' report #' @export spcr_make_data_bundle <- function( measure_data = test_measure_data, @@ -29,7 +31,8 @@ spcr_make_data_bundle <- function( a_data <- measure_data |> purrr::discard_at("events") - # a_data is closely related to the measure_data, but we use a different function to check it + # a_data is closely related to the measure_data, but we use a different + # function to check it. a_data <- check_a_data(a_data) # check event_data columns and set `ref` column to character @@ -89,7 +92,20 @@ spcr_make_data_bundle <- function( # Check that measure data that is supposed to be integer data is supplied as # such, or raise a warning message + if (any(nested_data[["unit"]] == "integer")) { + nested_data |> + dplyr::filter(if_any("unit", \(x) x == "integer")) |> + tidyr::hoist("measure_data", "value") |> dplyr::select(c(x = "value", y = "ref")) |> + purrr::pwalk(\(x, y) { + if (any(round(x) != x)) { + warning(glue( + "spcr_make_data_bundle: Measure {y} is configured as an integer, ", + "but has been supplied with decimal data." + )) + } + }) + } nested_data |> dplyr::mutate( diff --git a/R/spcr_make_report.R b/R/spcr_make_report.R index 2a1463e..df15f48 100644 --- a/R/spcr_make_report.R +++ b/R/spcr_make_report.R @@ -1,24 +1,38 @@ #' Make the SPC Report #' -#' @param data_bundle data frame. The pre-processed bundle of information (ideally made with `spcr_make_data_bundle()`) -#' @param report_title string. The report title, printed at the top of the report +#' @param data_bundle data frame. The pre-processed bundle of information +#' (ideally made with `spcr_make_data_bundle()`) +#' @param report_title string. The report title, printed at the top of the +#' report #' @param subtitle string. The report subtitle, printed at the top of the report -#' @param document_title string. A title for the document, as used in the HTML `` tag or as the PDF document title. If left as NULL (the default), this function will use the `report_title` parameter and the current date to construct a title +#' @param document_title string. A title for the document, as used in the HTML +#' `<title>` tag or as the PDF document title. If left as NULL (the default), +#' this function will use the `report_title` parameter and the current date +#' to construct a title #' @param report_ref string. A unique reference for the report #' @param logo_path string. File path of the logo to be used on the report -#' @param department string. A text suffix positioned underneath the logo, for eg. department name +#' @param department string. A text label positioned underneath the logo, +#' for example the department name #' @param department_text_colour string. The colour of the department text #' @param intro string. Intro text printed at the head of the report #' @param author_name string. The author's name #' @param author_email string. The author's contact email address -#' @param paper_colour string. Customise the background colour using a hex code, or CSS colour name -#' @param accordion_colour string. Customise the accordion colour using a hex code, or CSS colour name -#' @param stale_colour string. Customise the date lozenge to indicate that data is stale, using a hex code, or CSS colour name -#' @param fresh_colour string. Customise the date lozenge to indicate that data is up to date, using a hex code, or CSS colour name -#' @param output_directory string. The name of the directory in which to save the resulting report -#' @param output_type vector. Specify what output types are needed. Default is c("html", "csv"). "pdf" is also possible. -#' @param include_dq_icon logical. Whether to include the data quality icon on the final report -#' @param annotate_limits logical. Whether to add annotations to a secondary y axis for process limits and mean +#' @param paper_colour string. Customise the background colour using a hex +#' code, or CSS colour name +#' @param accordion_colour string. Customise the accordion colour using a hex +#' code, or CSS colour name +#' @param stale_colour string. Customise the date lozenge to indicate that +#' data is stale, using a hex code, or CSS colour name +#' @param fresh_colour string. Customise the date lozenge to indicate that +#' data is up to date, using a hex code, or CSS colour name +#' @param output_directory string. The name of the directory in which to save +#' the resulting report +#' @param output_type vector. Specify what output types are needed. The +#' default is c("html", "csv"). "pdf" is also possible. +#' @param include_dq_icon logical. Whether to include the data quality icon +#' on the final report +#' @param annotate_limits logical. Whether to add annotations to a +#' secondary y axis for process limits and mean #' #' @export spcr_make_report <- function( diff --git a/tests/testthat/test-calculate_stale_data.R b/tests/testthat/test-calculate_stale_data.R index 9b6ab56..a347ecf 100644 --- a/tests/testthat/test-calculate_stale_data.R +++ b/tests/testthat/test-calculate_stale_data.R @@ -24,7 +24,10 @@ # 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." + paste0( + "calculate_stale_data: Unable to convert the updated_to ", + "argument text to a valid date." + ) ) }) diff --git a/tests/testthat/test-check_measure_data.R b/tests/testthat/test-check_measure_data.R index 32673bc..d3b3268 100644 --- a/tests/testthat/test-check_measure_data.R +++ b/tests/testthat/test-check_measure_data.R @@ -10,7 +10,10 @@ 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'" + paste0( + "check_measure_data: One element of measure_data must be ", + "named 'week' or 'month'" + ) ) }) @@ -50,7 +53,8 @@ test_that({ expect_no_error( list( - Week = data.frame(ref = 1, measure_name = "M1", comment = NA) # Week not week + # Week not week + Week = data.frame(ref = 1, measure_name = "M1", comment = NA) ) |> check_measure_data() ) @@ -114,7 +118,10 @@ measure_data <- list( 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." + paste0( + "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 @@ -122,6 +129,9 @@ measure_data <- list( 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." + paste0( + "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 05c3f85..5419093 100644 --- a/tests/testthat/test-checking_functions.R +++ b/tests/testthat/test-checking_functions.R @@ -2,8 +2,8 @@ "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 + # 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( @@ -38,19 +38,26 @@ report_config_plus_one, measure_data_df ), - "Data is missing for 1 report items. The first is ref 9999, 'test', aggregation: week." + paste0( + "check_dataset_is_complete: ", + "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") + tibble::add_row(ref = 998, measure_name = "test", aggregation = "none") |> + tibble::add_row(ref = 999, 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." + paste0( + "Data is missing for 2 report items. The first is ref 998, 'test', ", + "aggregation: none" + ) ) }) @@ -109,7 +116,10 @@ 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." + paste0( + "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 @@ -131,7 +141,10 @@ 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." + paste0( + "check_for_required_columns: Column 'unit' is missing from the ", + "'measure_config' data frame. Check for typos in the column names." + ) ) }) @@ -235,7 +248,10 @@ 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." + paste0( + "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 @@ -249,7 +265,10 @@ 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." + paste0( + "check_for_required_columns: Column 'domain' is missing from the ", + "'report_config' data frame. Check for typos in the column names." + ) ) }) @@ -268,7 +287,10 @@ expect_message( check_report_config(report_config), - "i check_for_optional_columns: Optional column 'report_comment' is missing. Adding it." + paste0( + "i check_for_optional_columns: Optional column 'report_comment' ", + "is missing. Adding it." + ) ) }) @@ -325,7 +347,10 @@ 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." + paste0( + "check_for_required_columns: Column 'measure_name' is missing ", + "from the 'week' data frame. Check for typos in the column names." + ) ) }) @@ -366,7 +391,10 @@ 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." + paste0( + "check_for_required_columns: Column 'measure_name' is missing ", + "from the 'week' data frame. Check for typos in the column names." + ) ) }) @@ -399,7 +427,11 @@ 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." + paste0( + "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-lengthen_measure_data.R b/tests/testthat/test-lengthen_measure_data.R index 2e2f2b2..e1b6e04 100644 --- a/tests/testthat/test-lengthen_measure_data.R +++ b/tests/testthat/test-lengthen_measure_data.R @@ -77,7 +77,9 @@ ) out1 <- .data |> - tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) + tidyr::pivot_longer( + !any_of(init_cols), names_to = "date", values_drop_na = TRUE + ) tibble::tibble( ref = c(1, 2, 2), @@ -90,7 +92,9 @@ out2 <- .data |> - tidyr::pivot_longer(!any_of(init_cols), names_to = "date", values_drop_na = TRUE) |> + tidyr::pivot_longer( + !any_of(init_cols), names_to = "date", values_drop_na = TRUE + ) |> dplyr::mutate(across("date", quietly_convert_date)) tibble::tibble( diff --git a/tests/testthat/test-process_event_data_t.R b/tests/testthat/test-process_event_data_t.R index 44c863c..47ac407 100644 --- a/tests/testthat/test-process_event_data_t.R +++ b/tests/testthat/test-process_event_data_t.R @@ -4,7 +4,9 @@ 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")) + "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") @@ -18,7 +20,12 @@ 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[["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)) }) diff --git a/tests/testthat/test-spcr_make_data_bundle.R b/tests/testthat/test-spcr_make_data_bundle.R index d0e9cc6..cfd96a4 100644 --- a/tests/testthat/test-spcr_make_data_bundle.R +++ b/tests/testthat/test-spcr_make_data_bundle.R @@ -71,7 +71,8 @@ test_that({ # 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")) + spcr_make_data_bundle |> + mockery::stub("Sys.time", as.POSIXct("2023-12-04 21:25:25")) db <- spcr_make_data_bundle( test_measure_data, @@ -132,7 +133,9 @@ # 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"))) + dplyr::mutate(across("measure_name", \(x) { + stringr::str_replace(x, "Capacity", "Capaciteeee") + })) expect_warning( spcr_make_data_bundle( @@ -140,13 +143,20 @@ 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'." + paste0( + "check_measure_names: There is a name mismatch for measure ref: 5.\n", + "The title in the data bundle is 'Capacity'.\n", + "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")))) + purrr::modify_at("month", \(x) { + dplyr::mutate(x, across("measure_name", \(x) { + stringr::str_replace(x, "Widgets", "widgets") + })) + }) expect_warning( spcr_make_data_bundle( @@ -154,12 +164,18 @@ 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'." + paste0( + "check_measure_names: There is a name mismatch for measure ref: 11.\n", + "The title in the data bundle is 'widgets'.\n", + "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"))) + dplyr::mutate(across("measure_name", \(x) { + stringr::str_replace(x, "Widgets", "widgets") + })) expect_no_error( spcr_make_data_bundle( From e267beec3825bb7a3e806b438d27ae534bfebda6 Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:01:49 +0000 Subject: [PATCH 06/16] Surround functions in curly braces --- R/checking_functions.R | 29 ++++++++-------- R/helper_functions.R | 6 ++-- R/spcr_make_data_bundle.R | 37 ++++++++++----------- tests/testthat/test-lengthen_measure_data.R | 23 ++++++++----- 4 files changed, 50 insertions(+), 45 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index 05efc58..8a48463 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -31,10 +31,9 @@ check_measure_data <- function(measure_data) { ) measure_data |> purrr::keep_at(allowed_names) |> - purrr::iwalk( - \(x, nm) check_for_required_columns( - x, nm, required_columns = c("ref", "measure_name")) - ) |> + purrr::iwalk(\(x, nm) { + check_for_required_columns(x, nm, c("ref", "measure_name")) + }) |> purrr::map(\(x) dplyr::mutate(x, across("ref", as.character))) } @@ -64,10 +63,9 @@ check_a_data <- function(a_data) { ) 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, c("ref", "measure_name", "comment")) + }) } @@ -240,8 +238,8 @@ check_measure_names <- function(ref_no, measure_data, measure_config) { # warn when the titles don't match m_titles |> - purrr::walk( - \(x) ifelse( + purrr::walk(\(x) { + ifelse( x == c_title, usethis::ui_silence(TRUE), usethis::ui_warn(c( @@ -314,11 +312,12 @@ check_for_optional_columns <- function(.data, optional_columns) { )) missing_columns |> - purrr::reduce( - \(x, y) tibble::add_column(x, {{y}} := NA_character_), - .init = .data - ) - } else .data + purrr::reduce(\(x, y) { + tibble::add_column(x, {{y}} := NA_character_) + }, .init = .data) + } else { + .data + } } diff --git a/R/helper_functions.R b/R/helper_functions.R index 50023ae..54f6156 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -22,9 +22,11 @@ lengthen_measure_data <- function(.data) { assert_that( all(purrr::map_lgl( - names(.data), \(x) x %in% init_cols | + names(.data), \(x) { + x %in% init_cols | stringr::str_detect(x, "^[0-9]{5}$") | - stringr::str_detect(x, ymd_regex) + stringr::str_detect(x, ymd_rx) + } )), msg = usethis::ui_stop( paste( diff --git a/R/spcr_make_data_bundle.R b/R/spcr_make_data_bundle.R index 6112a7a..c446fbc 100644 --- a/R/spcr_make_data_bundle.R +++ b/R/spcr_make_data_bundle.R @@ -68,13 +68,9 @@ spcr_make_data_bundle <- function( nested_data <- report_config |> # use measure names from report_config not from measure_config dplyr::left_join(dplyr::select(measure_config, !"measure_name"), "ref") |> - dplyr::mutate( - across("measure_name", - \(x) if_else( - .data[["spc_chart_type"]] == "t", paste(x, "(time-between)"), x - ) - ) - ) |> + dplyr::mutate(across("measure_name", \(x) { + if_else(.data[["spc_chart_type"]] == "t", paste(x, "(time-between)"), x) + })) |> dplyr::nest_join( measure_data_long, by = c("ref", "aggregation"), @@ -83,7 +79,9 @@ spcr_make_data_bundle <- function( # 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)), + last_date = purrr::map_vec(.data[["measure_data"]], \(x) { + max(x[["date"]], na.rm = TRUE) + }), # pull most recent data point from each df in the measure_data column last_data_point = purrr::map_vec(.data[["measure_data"]], \(x) { dplyr::slice_max(x, order_by = x[["date"]], n = 1)[["value"]] @@ -109,9 +107,8 @@ spcr_make_data_bundle <- function( nested_data |> dplyr::mutate( - across( - "improvement_direction", - \(x) dplyr::case_when( + 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", @@ -127,14 +124,16 @@ spcr_make_data_bundle <- function( \(x) if_else(.data[["spc_chart_type"]] == "t", NA, x) ), across("target_set_by", \(x) if_else(is.na(x), "-", x)), - 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)) - )) + 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"), + .default = as.character(round(x)) + ) + }) ) |> dplyr::mutate( target_text = get_target_text( diff --git a/tests/testthat/test-lengthen_measure_data.R b/tests/testthat/test-lengthen_measure_data.R index e1b6e04..6510057 100644 --- a/tests/testthat/test-lengthen_measure_data.R +++ b/tests/testthat/test-lengthen_measure_data.R @@ -40,25 +40,31 @@ "check input names" |> test_that({ - ymd_regex <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$" + ymd_rx <- "^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") 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, \(x) { + x %in% init_cols | + stringr::str_detect(x, "^[0-9]{5}$") | + stringr::str_detect(x, ymd_rx) + } + )) ) 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))) + all( + purrr::map_lgl(df_names, \(x) { + x %in% init_cols | + stringr::str_detect(x, "^[0-9]{5}$") | + stringr::str_detect(x, ymd_rx) + }) + ) ) }) @@ -106,4 +112,3 @@ ) |> expect_equal(out2) }) - From 1a36c2b3b515f24e9d56414e556e9d82acb87c6e Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:05:50 +0000 Subject: [PATCH 07/16] Fix closing bracket indentation --- tests/testthat/test-spcr_make_data_bundle.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-spcr_make_data_bundle.R b/tests/testthat/test-spcr_make_data_bundle.R index cfd96a4..ba18b23 100644 --- a/tests/testthat/test-spcr_make_data_bundle.R +++ b/tests/testthat/test-spcr_make_data_bundle.R @@ -95,7 +95,8 @@ out <- spcr_make_data_bundle( measure_data = test_measure_data, report_config = test_report_config, - measure_config = test_measure_config) + measure_config = test_measure_config + ) expect_length(out, 27) expect_equal(nrow(out), nrow(test_report_config)) @@ -182,7 +183,7 @@ measure_data = test_measure_data, report_config = test_report_config2, measure_config = test_measure_config - ) ) + ) }) From 349a2a2d354af95f07e12bc744adc436fb1923c3 Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:07:46 +0000 Subject: [PATCH 08/16] Condense code to a single line where possible --- NAMESPACE | 1 + R/SPCreporter-package.R | 2 +- R/checking_functions.R | 8 +++----- R/helper_functions.R | 8 +++----- R/spcr_make_data_bundle.R | 12 +++--------- 5 files changed, 11 insertions(+), 20 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a78c8f4..2695ea0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ importFrom(dplyr,pick) importFrom(ggplot2,aes) importFrom(glue,glue) importFrom(lubridate,days) +importFrom(rlang,"%||%") importFrom(rlang,":=") importFrom(rlang,.data) importFrom(tidyselect,all_of) diff --git a/R/SPCreporter-package.R b/R/SPCreporter-package.R index d7222a7..5bfaafa 100644 --- a/R/SPCreporter-package.R +++ b/R/SPCreporter-package.R @@ -7,7 +7,7 @@ #' @importFrom ggplot2 aes #' @importFrom glue glue #' @importFrom lubridate days -#' @importFrom rlang := .data +#' @importFrom rlang := %||% .data #' @importFrom tidyselect all_of any_of everything #' @importFrom utils head tail ## usethis namespace: end diff --git a/R/checking_functions.R b/R/checking_functions.R index 8a48463..5b052ba 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -90,11 +90,9 @@ check_e_data <- function(e_data) { msg = "check_event_data: The data must be a data frame." ) - e_data |> - check_for_required_columns( - "events", - required_columns = c("ref", "measure_name", "event_date_or_datetime") - ) |> + check_for_required_columns( + e_data, "events", c("ref", "measure_name", "event_date_or_datetime") + ) |> dplyr::mutate(across("ref", as.character)) } diff --git a/R/helper_functions.R b/R/helper_functions.R index 54f6156..b8fa73c 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -273,11 +273,9 @@ get_assurance_type <- function(spc, improvement_direction) { #' @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) + vari <- tail(spc[["point_type"]], 1) # nolint + relative_to_mean <- tail(spc[["relative_to_mean"]], 1) %||% 0 # nolint + imp_dir <- tolower(improvement_direction) # nolint v <- dplyr::case_when( vari == "common_cause" ~ "CC", diff --git a/R/spcr_make_data_bundle.R b/R/spcr_make_data_bundle.R index c446fbc..807abd8 100644 --- a/R/spcr_make_data_bundle.R +++ b/R/spcr_make_data_bundle.R @@ -114,15 +114,9 @@ spcr_make_data_bundle <- function( .data[["spc_chart_type"]] == "t" & x == "increase" ~ "decrease", TRUE ~ x ) - ), - across( - "unit", - \(x) if_else(.data[["spc_chart_type"]] == "t", "days", x) - ), - across( - "target", - \(x) if_else(.data[["spc_chart_type"]] == "t", NA, x) - ), + }), + across("unit", \(x) if_else(.data[["spc_chart_type"]] == "t", "days", x)), + across("target", \(x) if_else(.data[["spc_chart_type"]] == "t", NA, x)), across("target_set_by", \(x) if_else(is.na(x), "-", x)), across("last_data_point", \(x) { dplyr::case_when( From fda1e08f8d190dbbead2a591215f3478f97229bc Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:16:23 +0000 Subject: [PATCH 09/16] Restructure some comment/documentation text --- R/checking_functions.R | 6 ++-- R/helper_functions.R | 19 ++++++------ R/process_event_data_t.R | 5 ++-- R/spcr_make_data_bundle.R | 9 +++--- man/check_dataset_is_complete.Rd | 3 +- man/spcr_make_data_bundle.Rd | 6 ++-- man/spcr_make_report.Rd | 38 ++++++++++++++++-------- tests/testthat/test-check_measure_data.R | 3 +- 8 files changed, 54 insertions(+), 35 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index 5b052ba..23039a2 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -54,9 +54,9 @@ check_a_data <- function(a_data) { msg = "check_measure_data: The data must be a list." ) - # We now only retain data frames from the list if they have a name - # matching one of the allowed aggregation levels. We then check that each - # data frame has the required columns and the 'ref' column is a character type + # We now only retain data frames from the list if they have a name matching + # one of the allowed aggregation levels. We then check that each data frame + # has the required columns and the 'ref' column is a character type. allowed_names <- c( "day", "week", "month", "calendar_year", "financial_year" diff --git a/R/helper_functions.R b/R/helper_functions.R index b8fa73c..39a4fd5 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -2,7 +2,7 @@ #' #' @param .data data frame. Data frame in wide format #' -#' @returns data frame. Data frame in long format +#' @returns A data frame in long format #' @noRd lengthen_measure_data <- function(.data) { assert_that( @@ -43,8 +43,8 @@ lengthen_measure_data <- function(.data) { ) ) - # pivot incoming measure_data from wide to long, - # and convert date column to date format + # 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 @@ -145,7 +145,7 @@ get_updatedto_text <- function(last_date, aggregation) { # 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 +# 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( @@ -162,9 +162,10 @@ quietly_convert_date <- function(...) { #' 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()` +#' 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"' @@ -181,8 +182,8 @@ parse_rebase_dates <- function(input) { 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. + # Wrap the date parsing in tryCatch() to stop() if excel dates are not + # properly formed. tryCatch( lubridate::ymd(vector), error = function(c) stop("error in parse_rebase_dates: ", c), @@ -269,7 +270,7 @@ get_assurance_type <- function(spc, improvement_direction) { #' @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 +#' @returns string. Name of the variation type #' @noRd #' get_variation_type <- function(spc, improvement_direction) { diff --git a/R/process_event_data_t.R b/R/process_event_data_t.R index bbfd2c5..85f84f1 100644 --- a/R/process_event_data_t.R +++ b/R/process_event_data_t.R @@ -1,9 +1,10 @@ #' Process event data into a time-between data frame #' #' @param event_data data frame. Raw event data -#' @param data_cutoff_dttm POSIXct. The data cutoff datetime used to calculate the final point position +#' @param data_cutoff_dttm POSIXct. The data cutoff datetime used to calculate +#' the final point position #' -#' @return data frame. A data frame with calculated dates and time-between information added +#' @returns A data frame with calculated dates and time-between information #' @noRd process_event_data_t <- function(event_data, data_cutoff_dttm){ diff --git a/R/spcr_make_data_bundle.R b/R/spcr_make_data_bundle.R index 807abd8..95175f3 100644 --- a/R/spcr_make_data_bundle.R +++ b/R/spcr_make_data_bundle.R @@ -21,10 +21,11 @@ spcr_make_data_bundle <- function( # check measure_config columns and set `ref` column to character measure_config <- check_measure_config(measure_config) - # measure data can contain two types of worksheet - # 1. a wide-format sheet containing aggregated counts, with dated columns (a_data) - # 2. a long-format sheet containing event-list data (e_data). - # separate them into a_data and e_data + # Measure data can contain two types of worksheet: + # 1. a wide-format sheet containing aggregated counts, with dated columns + # (a_data) + # 2. a long-format sheet containing event-list data (e_data). + # Separate them into a_data and e_data: e_data <- measure_data |> purrr::pluck("events") diff --git a/man/check_dataset_is_complete.Rd b/man/check_dataset_is_complete.Rd index 189bbfb..9649330 100644 --- a/man/check_dataset_is_complete.Rd +++ b/man/check_dataset_is_complete.Rd @@ -7,7 +7,8 @@ check_dataset_is_complete(report_config, measure_data) } \arguments{ -\item{report_config}{A data frame. The report config detailing required report items} +\item{report_config}{A data frame. The report config detailing required +report items} \item{measure_data}{Data frame in wide format} } diff --git a/man/spcr_make_data_bundle.Rd b/man/spcr_make_data_bundle.Rd index c16e56f..a676c42 100644 --- a/man/spcr_make_data_bundle.Rd +++ b/man/spcr_make_data_bundle.Rd @@ -18,10 +18,12 @@ spcr_make_data_bundle( \item{measure_config}{data frame. Config information for the measures} -\item{data_cutoff_dttm}{POSIXct. The data cutoff date-time (the last date-time for data in the report eg. month-end)} +\item{data_cutoff_dttm}{POSIXct. The data cutoff date-time (the last +date-time for data in the report eg. month-end)} } \value{ -data frame. A nested data frame containing source data for the report +data frame. A nested data frame containing source data for the +report } \description{ Make a bundle of data diff --git a/man/spcr_make_report.Rd b/man/spcr_make_report.Rd index 695238e..9f267b7 100644 --- a/man/spcr_make_report.Rd +++ b/man/spcr_make_report.Rd @@ -27,19 +27,25 @@ spcr_make_report( ) } \arguments{ -\item{data_bundle}{data frame. The pre-processed bundle of information (ideally made with \code{spcr_make_data_bundle()})} +\item{data_bundle}{data frame. The pre-processed bundle of information +(ideally made with \code{spcr_make_data_bundle()})} -\item{report_title}{string. The report title, printed at the top of the report} +\item{report_title}{string. The report title, printed at the top of the +report} \item{subtitle}{string. The report subtitle, printed at the top of the report} -\item{document_title}{string. A title for the document, as used in the HTML \verb{<title>} tag or as the PDF document title. If left as NULL (the default), this function will use the \code{report_title} parameter and the current date to construct a title} +\item{document_title}{string. A title for the document, as used in the HTML +\verb{<title>} tag or as the PDF document title. If left as NULL (the default), +this function will use the \code{report_title} parameter and the current date +to construct a title} \item{report_ref}{string. A unique reference for the report} \item{logo_path}{string. File path of the logo to be used on the report} -\item{department}{string. A text suffix positioned underneath the logo, for eg. department name} +\item{department}{string. A text label positioned underneath the logo, +for example the department name} \item{department_text_colour}{string. The colour of the department text} @@ -49,21 +55,29 @@ spcr_make_report( \item{author_email}{string. The author's contact email address} -\item{paper_colour}{string. Customise the background colour using a hex code, or CSS colour name} +\item{paper_colour}{string. Customise the background colour using a hex +code, or CSS colour name} -\item{accordion_colour}{string. Customise the accordion colour using a hex code, or CSS colour name} +\item{accordion_colour}{string. Customise the accordion colour using a hex +code, or CSS colour name} -\item{stale_colour}{string. Customise the date lozenge to indicate that data is stale, using a hex code, or CSS colour name} +\item{stale_colour}{string. Customise the date lozenge to indicate that +data is stale, using a hex code, or CSS colour name} -\item{fresh_colour}{string. Customise the date lozenge to indicate that data is up to date, using a hex code, or CSS colour name} +\item{fresh_colour}{string. Customise the date lozenge to indicate that +data is up to date, using a hex code, or CSS colour name} -\item{output_directory}{string. The name of the directory in which to save the resulting report} +\item{output_directory}{string. The name of the directory in which to save +the resulting report} -\item{output_type}{vector. Specify what output types are needed. Default is c("html", "csv"). "pdf" is also possible.} +\item{output_type}{vector. Specify what output types are needed. The +default is c("html", "csv"). "pdf" is also possible.} -\item{include_dq_icon}{logical. Whether to include the data quality icon on the final report} +\item{include_dq_icon}{logical. Whether to include the data quality icon +on the final report} -\item{annotate_limits}{logical. Whether to add annotations to a secondary y axis for process limits and mean} +\item{annotate_limits}{logical. Whether to add annotations to a +secondary y axis for process limits and mean} } \description{ Make the SPC Report diff --git a/tests/testthat/test-check_measure_data.R b/tests/testthat/test-check_measure_data.R index d3b3268..313b69b 100644 --- a/tests/testthat/test-check_measure_data.R +++ b/tests/testthat/test-check_measure_data.R @@ -31,11 +31,10 @@ "list containing either 'week' or 'month' is allowed" |> test_that({ - expect_no_error( list( - week = data.frame(ref = 1, measure_name = "M1", comment = NA) # month list item is not provided + week = data.frame(ref = 1, measure_name = "M1", comment = NA) ) |> check_measure_data() ) From 149a3cb7e5102a8e074e0d03a53f8c329c5ffbea Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:20:07 +0000 Subject: [PATCH 10/16] Use pick() instead of across() where appropriate --- R/helper_functions.R | 4 ++-- R/spcr_make_report.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/helper_functions.R b/R/helper_functions.R index 39a4fd5..0e66c2b 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -51,8 +51,8 @@ lengthen_measure_data <- function(.data) { ) |> 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")))) + # (pivot_longer draws from L-R wide data)... but let's make sure. + dplyr::arrange(pick(c("ref", "date"))) } diff --git a/R/spcr_make_report.R b/R/spcr_make_report.R index df15f48..21f37f9 100644 --- a/R/spcr_make_report.R +++ b/R/spcr_make_report.R @@ -222,7 +222,7 @@ make_spc_data <- function( ) { measure_data |> # remove duplicate dttms using `slice_max` to keep just one row per date - dplyr::slice_max(value, n = 1, with_ties = FALSE, by = "date") |> + dplyr::slice_max(pick("value"), n = 1, with_ties = FALSE, by = "date") |> NHSRplotthedots::ptd_spc( rebase = align_rebase_dates(rebase_dates, measure_data), value_field = "value", From d568c407592f19119be1377cb520518fe93be318 Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:21:09 +0000 Subject: [PATCH 11/16] Small tweaks to presentation --- R/helper_functions.R | 2 +- R/process_event_data_t.R | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/helper_functions.R b/R/helper_functions.R index 0e66c2b..668f264 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -114,7 +114,7 @@ get_updatedto_text <- function(last_date, aggregation) { last_date <- as.Date(last_date) # handles dttm being passed in by mistake - # Rename "calendar_year" and "none" aggregations to work with ceiling_date() + # 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 diff --git a/R/process_event_data_t.R b/R/process_event_data_t.R index 85f84f1..b1659d5 100644 --- a/R/process_event_data_t.R +++ b/R/process_event_data_t.R @@ -6,9 +6,9 @@ #' #' @returns A data frame with calculated dates and time-between information #' @noRd -process_event_data_t <- function(event_data, data_cutoff_dttm){ +process_event_data_t <- function(event_data, data_cutoff_dttm) { - if(nrow(event_data) == 0) return(NULL) + if (nrow(event_data) == 0) return(NULL) event_data |> dplyr::mutate(aggregation = "none") |> From e7ee26cccbcc940ef7d29b79b12ab6cd84f3a455 Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:21:48 +0000 Subject: [PATCH 12/16] Quote variable names --- R/process_event_data_t.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/process_event_data_t.R b/R/process_event_data_t.R index b1659d5..f14e701 100644 --- a/R/process_event_data_t.R +++ b/R/process_event_data_t.R @@ -33,7 +33,7 @@ process_event_data_t <- function(event_data, data_cutoff_dttm) { units = "days" )) ) |> - dplyr::filter(!is.na(.data$time_between)) |> + dplyr::filter(if_any("time_between", \(x) !is.na(x))) |> dplyr::ungroup() |> # fill in the gaps left by adding the "today" event From 71cdfcb23ad61cbff947c83500d666fe0d4df563 Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:22:53 +0000 Subject: [PATCH 13/16] Use .default in case_when() --- R/helper_functions.R | 8 ++++---- R/spcr_make_data_bundle.R | 2 +- tests/testthat/test-checking_functions.R | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/R/helper_functions.R b/R/helper_functions.R index 668f264..76d066f 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -75,7 +75,7 @@ get_target_text <- function(target, improvement_direction, unit) { is.na(target) ~ "-", imp_dir == "neutral" ~ "Neutral", unit == "%" ~ paste0(round(target * 100, 1), "%"), - TRUE ~ as.character(round(target, 2)) # covers decimal and integer + .default = as.character(round(target, 2)) # covers decimal and integer ) dplyr::case_when( @@ -85,7 +85,7 @@ get_target_text <- function(target, improvement_direction, unit) { !is.na(target) & imp_dir == "decrease" ~ paste0("\u2264 ", string), # \u2265 is: ≥ !is.na(target) & imp_dir == "increase" ~ paste0("\u2265 ", string), - TRUE ~ string + .default = string ) } @@ -253,7 +253,7 @@ get_assurance_type <- function(spc, improvement_direction) { upl < target & imp_dir == "decrease" ~ "PASS_TARG", lpl > target & imp_dir == "decrease" ~ "FAIL_TARG", upl < target & imp_dir == "increase" ~ "FAIL_TARG", - TRUE ~ "" + .default = "" ) if (a == "") { @@ -288,7 +288,7 @@ get_variation_type <- function(spc, improvement_direction) { 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 ~ "" + .default = "" ) if (v == "") { diff --git a/R/spcr_make_data_bundle.R b/R/spcr_make_data_bundle.R index 95175f3..b5082ca 100644 --- a/R/spcr_make_data_bundle.R +++ b/R/spcr_make_data_bundle.R @@ -113,7 +113,7 @@ spcr_make_data_bundle <- function( .data[["spc_chart_type"]] == "t" & x == "decrease" ~ "increase", # a rather unlikely situation .data[["spc_chart_type"]] == "t" & x == "increase" ~ "decrease", - TRUE ~ x + .default = x ) }), across("unit", \(x) if_else(.data[["spc_chart_type"]] == "t", "days", x)), diff --git a/tests/testthat/test-checking_functions.R b/tests/testthat/test-checking_functions.R index 5419093..c3174b5 100644 --- a/tests/testthat/test-checking_functions.R +++ b/tests/testthat/test-checking_functions.R @@ -8,7 +8,7 @@ dplyr::bind_rows(.id = "aggregation") |> dplyr::mutate(aggregation = dplyr::case_when( aggregation == "events" ~ "none", - TRUE ~ aggregation + .default = aggregation )) expect_no_error( @@ -26,7 +26,7 @@ dplyr::bind_rows(.id = "aggregation") |> dplyr::mutate(aggregation = dplyr::case_when( aggregation == "events" ~ "none", - TRUE ~ aggregation + .default = aggregation )) report_config_plus_one <- test_report_config |> From 9228b4830cca12f205aa31d4296d514cea533e8e Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:24:46 +0000 Subject: [PATCH 14/16] Use #nolint to avoid warnings in select places --- R/checking_functions.R | 4 ++-- R/helper_functions.R | 14 +++++++------- R/spcr_make_report.R | 8 ++++---- tests/testthat/test-checking_functions.R | 4 ++-- tests/testthat/test-spcr_make_data_bundle.R | 4 ++-- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index 23039a2..bc001ba 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -273,7 +273,7 @@ check_for_required_columns <- function(.data, df_name, required_columns) { if (length(missing_columns)) { # find the name of the first missing col for the error message - first_missing_column <- missing_columns[1] + first_missing_column <- missing_columns[1] # nolint # throw the error usethis::ui_stop(paste0( @@ -302,7 +302,7 @@ check_for_optional_columns <- function(.data, optional_columns) { missing_columns <- setdiff(optional_columns, names(.data)) if (length(missing_columns)) { # find the name of the first missing col for the console message - first_missing_column <- missing_columns[1] + first_missing_column <- missing_columns[1] # nolint usethis::ui_info(paste0( "check_for_optional_columns: Optional column '{first_missing_column}' ", diff --git a/R/helper_functions.R b/R/helper_functions.R index 76d066f..3f18578 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -69,9 +69,9 @@ lengthen_measure_data <- function(.data) { #' @returns A character string suitable for inclusion in the report #' @noRd get_target_text <- function(target, improvement_direction, unit) { - imp_dir <- tolower(improvement_direction) + imp_dir <- tolower(improvement_direction) # nolint - string <- dplyr::case_when( + string <- dplyr::case_when( # nolint is.na(target) ~ "-", imp_dir == "neutral" ~ "Neutral", unit == "%" ~ paste0(round(target * 100, 1), "%"), @@ -240,10 +240,10 @@ align_rebase_dates <- function(input, measure_data) { #' @returns string. Name of the assurance type #' @noRd get_assurance_type <- function(spc, improvement_direction) { - imp_dir <- tolower(improvement_direction) - upl <- spc[["upl"]][1] - lpl <- spc[["lpl"]][1] - target <- spc[["target"]][1] + imp_dir <- tolower(improvement_direction) # nolint + upl <- spc[["upl"]][1] # nolint + lpl <- spc[["lpl"]][1] # nolint + target <- spc[["target"]][1] # nolint a <- dplyr::case_when( imp_dir == "neutral" ~ "Neutral", @@ -285,7 +285,7 @@ get_variation_type <- function(spc, improvement_direction) { 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" & relative_to_mean %in% c(1, 0) ~ "SC_HI_NEUTRAL", # nolint vari == "special_cause_neutral_low" ~ "SC_LO_NEUTRAL", vari == "special_cause_neutral_high" ~ "SC_HI_NEUTRAL", .default = "" diff --git a/R/spcr_make_report.R b/R/spcr_make_report.R index 21f37f9..80bb1da 100644 --- a/R/spcr_make_report.R +++ b/R/spcr_make_report.R @@ -59,7 +59,7 @@ spcr_make_report <- function( start_time <- Sys.time() # This dttm is the same for every row in the data bundle. The first will do. - data_cutoff_dttm <- data_bundle[["data_cutoff_dttm"]][[1]] + data_cutoff_dttm <- data_bundle[["data_cutoff_dttm"]][[1]] # nolint # Create list of source data for SPC charts spc_data <- data_bundle |> @@ -97,7 +97,7 @@ spcr_make_report <- function( spc_chart_uris <- tmp_files |> purrr::map_chr(knitr::image_uri) - data_bundle_full <- data_bundle |> + data_bundle_full <- data_bundle |> # nolint dplyr::mutate( spc_data = spc_data, spc_chart_uri = spc_chart_uris, @@ -186,7 +186,7 @@ spcr_make_report <- function( beepr::beep() - process_duration <- lubridate::as.period(Sys.time() - start_time) |> + process_duration <- lubridate::as.period(Sys.time() - start_time) |> # nolint round() |> tolower() @@ -250,7 +250,7 @@ make_spc_chart <- function( percentage_y_axis = unit == "%", main_title = paste0("#", ref, " - ", measure_name), x_axis_label = NULL, - y_axis_label = if_else(spc_chart_type == "t", "Days since previous occurrence", ""), + y_axis_label = if_else(spc_chart_type == "t", "Days since previous occurrence", ""), # nolint x_axis_breaks = "1 month", x_axis_date_format = if_else(aggregation == "week", "%d-%b-%Y", "%b '%y"), label_limits = label_limits, diff --git a/tests/testthat/test-checking_functions.R b/tests/testthat/test-checking_functions.R index c3174b5..d8cad86 100644 --- a/tests/testthat/test-checking_functions.R +++ b/tests/testthat/test-checking_functions.R @@ -94,7 +94,7 @@ ) }) -"check measure config: errors helpfully when column names are missing or mis-spelled" |> +"check measure config: errors helpfully when column names are missing or mis-spelled" |> # nolint test_that({ # create the error by omitting a required column (unit) @@ -234,7 +234,7 @@ ) }) -"check report config: errors helpfully when column names are missing or mis-spelled" |> +"check report config: errors helpfully when column names are missing or mis-spelled" |> # nolint test_that({ # create the error by omitting a required column ('domain') diff --git a/tests/testthat/test-spcr_make_data_bundle.R b/tests/testthat/test-spcr_make_data_bundle.R index ba18b23..74c6aa6 100644 --- a/tests/testthat/test-spcr_make_data_bundle.R +++ b/tests/testthat/test-spcr_make_data_bundle.R @@ -24,7 +24,7 @@ ) }) -"spcr_make_data_bundle: there is a helpful error if the 'events' worksheet is missing" |> +"spcr_make_data_bundle: there is a helpful error if the 'events' worksheet is missing" |> # nolint test_that({ measure_data_no_events <- test_measure_data @@ -41,7 +41,7 @@ }) -"spcr_make_data_bundle: it is possible to make a data_bundle if no event data is supplied" |> +"spcr_make_data_bundle: it is possible to make a data_bundle if no event data is supplied" |> # nolint test_that({ measure_data_no_events <- test_measure_data From aacaa972759d6868d026a4905285dd4e9debd5e2 Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 21:24:58 +0000 Subject: [PATCH 15/16] Bump version --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3a25cc4..09c8570 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.0.9004 +Version: 0.2.0.9005 Authors@R: c( person("Tom", "Smith",, "tomsmith_uk@hotmail.com", role = c("aut", "cre")), person("Fran", "Barton",, "fbarton@alwaysdata.net", role = "aut")) @@ -15,7 +15,7 @@ Description: Takes a dataset file and a configuration file to produce an HTML License: MIT + file LICENSE Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 URL: https://github.com/ThomUK/SPCreporter, https://thomuk.github.io/SPCreporter/ BugReports: https://github.com/ThomUK/SPCreporter/issues From 8e402f2c6a7aa34b3f02feb17b881c3f4b5216eb Mon Sep 17 00:00:00 2001 From: Fran Barton <francis.barton@nhs.net> Date: Sun, 12 Jan 2025 22:01:09 +0000 Subject: [PATCH 16/16] Code comments should be in sentence case https://style.tidyverse.org/functions.html#comments --- R/checking_functions.R | 16 ++++++------ R/helper_functions.R | 16 ++++++------ R/process_event_data_t.R | 6 ++--- R/spcr_make_data_bundle.R | 28 ++++++++++----------- R/spcr_make_report.R | 18 ++++++------- tests/testthat/test-calculate_stale_data.R | 10 ++++---- tests/testthat/test-check_measure_data.R | 6 ++--- tests/testthat/test-checking_functions.R | 22 ++++++++-------- tests/testthat/test-get_assurance_type.R | 12 ++++----- tests/testthat/test-helper_functions.R | 26 +++++++++---------- tests/testthat/test-spcr_make_data_bundle.R | 21 ++++++++-------- 11 files changed, 90 insertions(+), 91 deletions(-) diff --git a/R/checking_functions.R b/R/checking_functions.R index bc001ba..f9d8c59 100644 --- a/R/checking_functions.R +++ b/R/checking_functions.R @@ -149,7 +149,7 @@ check_measure_config <- function(measure_config) { msg = "check_measure_config: config_data must be a data frame" ) - # check for column names, and provide a helpful error message if needed + # Check for column names, and provide a helpful error message if needed required_columns <- c( "ref", "measure_name", @@ -173,13 +173,13 @@ check_measure_config <- function(measure_config) { ) measure_config |> - # check required cols are present + # Check required cols are present check_for_required_columns("measure_config", required_columns) |> check_for_optional_columns(optional_columns) |> dplyr::select(c(all_of(required_columns), any_of(optional_columns))) |> dplyr::mutate( - # default all cols to character (empty cols are imported as logical NAs) + # Default all cols to character (empty cols are imported as logical NAs) across(everything(), as.character), across("unit", tolower), across("improvement_direction", tolower), @@ -215,7 +215,7 @@ check_measure_names <- function(ref_no, measure_data, measure_config) { "data frame.") ) - # find the titles to compare + # Find the titles to compare m_titles <- measure_data |> dplyr::filter(if_any("ref", \(x) x == ref_no)) |> dplyr::pull("measure_name") |> @@ -234,7 +234,7 @@ check_measure_names <- function(ref_no, measure_data, measure_config) { ) ) - # warn when the titles don't match + # Warn when the titles don't match m_titles |> purrr::walk(\(x) { ifelse( @@ -272,10 +272,10 @@ check_for_required_columns <- function(.data, df_name, required_columns) { missing_columns <- setdiff(required_columns, names(.data)) if (length(missing_columns)) { - # find the name of the first missing col for the error message + # Find the name of the first missing col for the error message first_missing_column <- missing_columns[1] # nolint - # throw the error + # Throw the error usethis::ui_stop(paste0( "check_for_required_columns: Column '{first_missing_column}' is missing ", "from the '{df_name}' data frame. Check for typos in the column names." @@ -337,7 +337,7 @@ check_dataset_is_complete <- function(report_config, measure_data) { dplyr::select(c("ref", "measure_name", "aggregation")) |> dplyr::anti_join(measure_data, by = c("ref", "aggregation")) - # build an error message if there are missing data items + # Build an error message if there are missing data items assert_that( nrow(missing_data) == 0, msg = usethis::ui_stop( diff --git a/R/helper_functions.R b/R/helper_functions.R index 3f18578..2dd1e33 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -10,7 +10,7 @@ lengthen_measure_data <- function(.data) { msg = "lengthen_measure_data: The data must be a data frame." ) - # should match date strings of the form 2022-06-01 + # Should match date strings of the form 2022-06-01 ymd_rx <- "^20[0-9]{2}-[0-9]{1,2}-[0-9]{1,2}$" init_cols <- c( "aggregation", @@ -112,9 +112,9 @@ get_updatedto_text <- function(last_date, aggregation) { msg = "get_updatedto_text: Multiple values for `aggregation` provided" ) - last_date <- as.Date(last_date) # handles dttm being passed in by mistake + last_date <- as.Date(last_date) # Handles dttm being passed in by mistake - # rename "calendar_year" and "none" aggregations to work with ceiling_date() + # 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 @@ -122,7 +122,7 @@ get_updatedto_text <- function(last_date, aggregation) { .default = aggregation ) - # allowed values + # Allowed values assert_that( all(agg %in% c("day", "week", "month", "year")), msg = glue("get_updatedto_text: invalid aggregation ({agg}) provided") @@ -176,11 +176,11 @@ parse_rebase_dates <- function(input) { if (is.na(input)) { NULL } else { - # parse into individual character strings + # 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 + 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 # properly formed. @@ -347,6 +347,6 @@ calculate_stale_data <- function(updated_to, lag, cutoff_dttm) { msg = "calculate_stale_data: The cutoff_dttm argument must be a POSIXct." ) - lag <- days(lag) + lubridate::hms("23:59:59") # convert to a period + lag <- days(lag) + lubridate::hms("23:59:59") # Convert to a period if_else((updated_to + lag) < cutoff_dttm, "stale", "fresh") } diff --git a/R/process_event_data_t.R b/R/process_event_data_t.R index f14e701..14e4355 100644 --- a/R/process_event_data_t.R +++ b/R/process_event_data_t.R @@ -20,12 +20,12 @@ process_event_data_t <- function(event_data, data_cutoff_dttm) { dplyr::group_by(pick("ref")) |> dplyr::arrange(pick("event_date_or_datetime")) |> - # add the theoretical "today" event to each group + # Add the theoretical "today" event to each group dplyr::group_modify(\(x, y) { tibble::add_row(x, event_date_or_datetime = data_cutoff_dttm) }) |> - # calculate the time between events, in days + # Calculate the time between events, in days dplyr::mutate( time_between = as.integer(difftime( .data[["event_date_or_datetime"]], @@ -36,7 +36,7 @@ process_event_data_t <- function(event_data, data_cutoff_dttm) { dplyr::filter(if_any("time_between", \(x) !is.na(x))) |> dplyr::ungroup() |> - # fill in the gaps left by adding the "today" event + # Fill in the gaps left by adding the "today" event tidyr::fill("aggregation", "measure_name") |> dplyr::relocate("aggregation") |> dplyr::rename( diff --git a/R/spcr_make_data_bundle.R b/R/spcr_make_data_bundle.R index b5082ca..50a5c9b 100644 --- a/R/spcr_make_data_bundle.R +++ b/R/spcr_make_data_bundle.R @@ -14,11 +14,11 @@ spcr_make_data_bundle <- function( report_config = test_report_config, measure_config = test_measure_config, data_cutoff_dttm = Sys.time()) { - # check measure_data (list) columns and set `ref` column to character + # Check measure_data (list) columns and set `ref` column to character measure_data <- check_measure_data(measure_data) - # check report_config columns and set `ref` column to character + # Check report_config columns and set `ref` column to character report_config <- check_report_config(report_config) - # check measure_config columns and set `ref` column to character + # Check measure_config columns and set `ref` column to character measure_config <- check_measure_config(measure_config) # Measure data can contain two types of worksheet: @@ -36,24 +36,24 @@ spcr_make_data_bundle <- function( # function to check it. a_data <- check_a_data(a_data) - # check event_data columns and set `ref` column to character + # Check event_data columns and set `ref` column to character e_data <- check_e_data(e_data) - # process event data into time-between data + # Process event data into time-between data e_data_time_between <- process_event_data_t(e_data, data_cutoff_dttm) - # reduce measure_data list to a single data frame + # Reduce measure_data list to a single data frame a_data_df <- a_data |> dplyr::bind_rows(.id = "aggregation") # Create long version of the aggregated data, sorted by date (within each - # ref), and with the processed event data added to the end + # ref), and with the processed event data added to the end. measure_data_long <- a_data_df |> lengthen_measure_data() |> dplyr::bind_rows(e_data_time_between) - # check all required data is supplied + # Check all required data is supplied check_dataset_is_complete(report_config, measure_data_long) # Check reference numbers and measure names agree across both data frames. @@ -65,9 +65,9 @@ spcr_make_data_bundle <- function( # measure_data in long format is joined on to the config files as a nested df # column. Then we mutate the data frame row by row, adding new variables and - # tidying up / formatting variables ready for reporting + # tidying up / formatting variables ready for reporting. nested_data <- report_config |> - # use measure names from report_config not from measure_config + # Use measure names from report_config not from measure_config dplyr::left_join(dplyr::select(measure_config, !"measure_name"), "ref") |> dplyr::mutate(across("measure_name", \(x) { if_else(.data[["spc_chart_type"]] == "t", paste(x, "(time-between)"), x) @@ -83,14 +83,14 @@ spcr_make_data_bundle <- function( last_date = purrr::map_vec(.data[["measure_data"]], \(x) { max(x[["date"]], na.rm = TRUE) }), - # pull most recent data point from each df in the measure_data column + # Pull most recent data point from each df in the measure_data column last_data_point = purrr::map_vec(.data[["measure_data"]], \(x) { dplyr::slice_max(x, order_by = x[["date"]], n = 1)[["value"]] }) ) # Check that measure data that is supposed to be integer data is supplied as - # such, or raise a warning message + # such, or raise a warning message. if (any(nested_data[["unit"]] == "integer")) { nested_data |> dplyr::filter(if_any("unit", \(x) x == "integer")) |> @@ -111,7 +111,7 @@ spcr_make_data_bundle <- function( across("improvement_direction", \(x) { dplyr::case_when( .data[["spc_chart_type"]] == "t" & x == "decrease" ~ "increase", - # a rather unlikely situation + # A rather unlikely situation .data[["spc_chart_type"]] == "t" & x == "increase" ~ "decrease", .default = x ) @@ -139,7 +139,7 @@ spcr_make_data_bundle <- function( updated_to = purrr::map2_chr( .data[["last_date"]], .data[["aggregation"]], - get_updatedto_text # use map2_chr as this doesn't handle vectors well + get_updatedto_text # Use map2_chr as this doesn't handle vectors well ), stale_data = calculate_stale_data( .data[["updated_to"]], diff --git a/R/spcr_make_report.R b/R/spcr_make_report.R index 80bb1da..55d1179 100644 --- a/R/spcr_make_report.R +++ b/R/spcr_make_report.R @@ -144,8 +144,8 @@ spcr_make_report <- function( gsub(" ", "_", report_title), "_", time_stamp, ".html" ) - # create a document title (HTML <title>), unless already supplied - # `pagetitle` in YAML/Pandoc + # Create a document title (HTML <title>), unless already supplied + # `pagetitle` in YAML/Pandoc. # https://community.rstudio.com/t/r-markdown-html-output-title/47294 if (is.null(document_title)) { document_title <- paste0( @@ -153,7 +153,7 @@ spcr_make_report <- function( ) } - # render the html output + # Render the html output usethis::ui_info("Making HTML output...") rmarkdown::render( @@ -169,17 +169,17 @@ spcr_make_report <- function( output_file = output_file_name ) - # print the full path to the console + # Print the full path to the console wd <- getwd() |> - stringr::str_remove("^\\\\{1}") # if network location, remove an initial '\' + stringr::str_remove("^\\\\{1}") # If network location, remove an initial '\' path <- file.path(wd, output_directory, output_file_name) usethis::ui_info("HTML filepath: {path}") usethis::ui_done("HTML output complete.") - # open the result in the browser + # Open the result in the browser utils::browseURL(path) - # render a pdf if needed + # Render a pdf if needed if ("pdf" %in% output_type) { convert_to_pdf(path) } @@ -266,7 +266,7 @@ make_spc_chart <- function( legend.margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 0, unit = "pt") ) - # conditionally add the "hollow" final data point to rare-event charts + # Conditionally add the "hollow" final data point to rare-event charts if (spc_chart_type == "t") { plot + ggplot2::annotate( @@ -275,7 +275,7 @@ make_spc_chart <- function( y = dplyr::last(spc_data[["y"]]), shape = "circle filled", colour = "grey65", # #a6a6a6 (matches plotthedots grey) - fill = NA, # so the PTD dot can be seen + fill = NA, # So the PTD dot can be seen size = 5, stroke = 2 ) diff --git a/tests/testthat/test-calculate_stale_data.R b/tests/testthat/test-calculate_stale_data.R index a347ecf..e5f1538 100644 --- a/tests/testthat/test-calculate_stale_data.R +++ b/tests/testthat/test-calculate_stale_data.R @@ -18,10 +18,10 @@ lag <- 0 cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") - # introduce the error + # Introduce the error updated_to <- as.POSIXct("2020-01-31") - # this will generate a warning message due to the incorrect date format + # This will generate a warning message due to the incorrect date format expect_error( calculate_stale_data(updated_to, lag, cutoff_dttm), paste0( @@ -35,7 +35,7 @@ test_that({ updated_to <- "31-Jan-2020" - # introduce an error + # Introduce an error lag <- 0.1 cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") @@ -51,7 +51,7 @@ updated_to <- "31-Jan-2020" lag <- 0 cutoff_dttm <- as.POSIXct("2020-01-31 23:59:59") - # introduce an error + # Introduce an error cutoff_dttm <- as.Date(cutoff_dttm) expect_error( @@ -65,7 +65,7 @@ updated_to <- "31-Jan-2020" lag <- 0 - # report one month later + # Report one month later cutoff_dttm <- as.POSIXct("2020-02-28 23:59:59") expect_equal( diff --git a/tests/testthat/test-check_measure_data.R b/tests/testthat/test-check_measure_data.R index 313b69b..043abef 100644 --- a/tests/testthat/test-check_measure_data.R +++ b/tests/testthat/test-check_measure_data.R @@ -98,7 +98,7 @@ measure_data <- list( "it coerces refs to character vectors" |> test_that({ - # create the error by assigning numeric refs + # Create the error by assigning numeric refs measure_data[["week"]]$ref <- c(1, 2, 3) measure_data[["month"]]$ref <- c(1, 2, 3) @@ -112,7 +112,7 @@ measure_data <- list( "it errors helpfully when column names are missing or mis-spelled" |> test_that({ - # create the error by removing a required column + # Create the error by removing a required column measure_data[["week"]]$ref <- NULL expect_error( @@ -123,7 +123,7 @@ measure_data <- list( ) ) - # error persists when the column is mis-spelled + # Error persists when the column is mis-spelled measure_data[["week"]]$Reference <- c(1, 2, 3) expect_error( diff --git a/tests/testthat/test-checking_functions.R b/tests/testthat/test-checking_functions.R index d8cad86..dcae5e1 100644 --- a/tests/testthat/test-checking_functions.R +++ b/tests/testthat/test-checking_functions.R @@ -66,7 +66,7 @@ # check measure config "check measure config: coerces refs to character vectors" |> test_that({ - # create the error by assigning numeric refs + # Create the error by assigning numeric refs measure_config <- tibble::tibble( ref = c(1, 2, 3), measure_name = c("M1", "M2", "M3"), @@ -97,7 +97,7 @@ "check measure config: errors helpfully when column names are missing or mis-spelled" |> # nolint test_that({ - # create the error by omitting a required column (unit) + # Create the error by omitting a required column (unit) measure_config <- tibble::tibble( ref = c("1", "2", "3"), measure_name = c("M1", "M2", "M3"), @@ -122,7 +122,7 @@ ) ) - # error persists when the column is mis-spelled + # Error persists when the column is mis-spelled measure_config <- tibble::tibble( ref = c("1", "2", "3"), measure_name = c("M1", "M2", "M3"), @@ -151,7 +151,7 @@ -# check measure names +# Check measure names "check measure names: happy path" |> test_that({ @@ -212,7 +212,7 @@ -# check report config +# Check report config "check report config: coerces refs to character vectors" |> test_that({ @@ -237,7 +237,7 @@ "check report config: errors helpfully when column names are missing or mis-spelled" |> # nolint test_that({ - # create the error by omitting a required column ('domain') + # 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"), @@ -254,7 +254,7 @@ ) ) - # error persists when the column is mis-spelled + # 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"), @@ -275,7 +275,7 @@ "check report config: missing optional columns does not throw an error" |> test_that({ - # assign numeric refs + # Assign numeric refs report_config <- tibble::tibble( ref = c(1, 2, 3, 1, 2, 3), measure_name = c("M1", "M2", "M3", "M1", "M2", "M3"), @@ -328,7 +328,7 @@ aggregated_datasheet <- tibble::tibble( ref = c(1, 2, 3), - # measure_name = c("M1", "M2", "M3"), # missing column + # measure_name = c("M1", "M2", "M3"), # Missing column comment = c("comment", "comment", "comment") ) @@ -380,7 +380,7 @@ datasheet <- tibble::tibble( ref = c(1, 2, 3), - # measure_name = c("M1", "M2", "M3"), # missing column + # measure_name = c("M1", "M2", "M3"), # Missing column comment = c("comment", "comment", "comment") ) @@ -422,7 +422,7 @@ 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 + # event_date_or_datetime = "there will be dates here" # Missing column ) expect_error( diff --git a/tests/testthat/test-get_assurance_type.R b/tests/testthat/test-get_assurance_type.R index 2b8548c..1786b75 100644 --- a/tests/testthat/test-get_assurance_type.R +++ b/tests/testthat/test-get_assurance_type.R @@ -65,11 +65,11 @@ test_that("it returns correct string in failing conditions", { ) - # improvement direction = decrease + # Improvement direction = decrease spc <- data.frame( upl = 3, lpl = 1, - target = 0 # the target is below process limits + target = 0 # The target is below process limits ) expect_equal( @@ -79,11 +79,11 @@ test_that("it returns correct string in failing conditions", { }) test_that("it returns correct string in passing conditions", { - # improvement direction = increase + # Improvement direction = increase spc <- data.frame( upl = 3, lpl = 1, - target = 0.5 # the target is below process limits + target = 0.5 # The target is below process limits ) expect_equal( @@ -91,9 +91,9 @@ test_that("it returns correct string in passing conditions", { "PASS_TARG" ) - # improvement direction = decrease + # Improvement direction = decrease spc <- data.frame( - target = 4, # the target is above process limits + target = 4, # The target is above process limits upl = 3, lpl = 1 ) diff --git a/tests/testthat/test-helper_functions.R b/tests/testthat/test-helper_functions.R index 3472c96..b87dca5 100644 --- a/tests/testthat/test-helper_functions.R +++ b/tests/testthat/test-helper_functions.R @@ -1,6 +1,6 @@ "updatedto_text handles dttms correctly 1" |> test_that({ - # failing test for current behaviour (11 March 2024) + # Failing test for current behaviour (11 March 2024) d1 <- lubridate::as_date("2024-02-01") d2 <- lubridate::as_datetime("2024-02-01") @@ -21,12 +21,12 @@ "updatedto_text handles dttms correctly 2" |> test_that({ - # failing test for current behaviour (11 March 2024) + # 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 + # The function needs to operate on a date not a datetime d1 <- as.Date(d1) d2 <- as.Date(d2) @@ -45,7 +45,7 @@ "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 + exp_out <- "29-Feb-2024" # Character not date od1 <- get_updatedto_text(d1, "none") expect_identical(od1, exp_out) @@ -54,21 +54,21 @@ expect_identical(od2, exp_out) od3 <- get_updatedto_text(d1, "day") - expect_identical(od3, "01-Feb-2024") # character not date + 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 + 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 + 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 + exp_out <- "31-Jan-2024" # Character not date od1 <- get_updatedto_text(d1, "none") expect_identical(od1, exp_out) @@ -77,21 +77,21 @@ expect_identical(od2, exp_out) od3 <- get_updatedto_text(d1, "day") - expect_identical(od3, "01-Jan-2024") # character not date + 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 + 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 + expect_identical(od5, "07-Jan-2024") # Character not date - # financial year still to be implemented + # Financial year still to be implemented # try some errors expect_error( - get_updatedto_text(d1, "quarter"), # not implemented + get_updatedto_text(d1, "quarter"), # Not implemented "get_updatedto_text: invalid aggregation (quarter) provided", fixed = TRUE ) diff --git a/tests/testthat/test-spcr_make_data_bundle.R b/tests/testthat/test-spcr_make_data_bundle.R index 74c6aa6..3a46317 100644 --- a/tests/testthat/test-spcr_make_data_bundle.R +++ b/tests/testthat/test-spcr_make_data_bundle.R @@ -33,7 +33,7 @@ expect_error( spcr_make_data_bundle( measure_data_no_events, - test_report_config, # note this will still be calling for t charts + test_report_config, # Note this will still be calling for t charts test_measure_config ), "The 'events' worksheet is missing from 'measure_data'." @@ -53,7 +53,7 @@ ) report_config <- test_report_config |> - dplyr::filter(spc_chart_type != "t") # event data needed for t charts + dplyr::filter(spc_chart_type != "t") # Event data needed for t charts expect_no_error( spcr_make_data_bundle( @@ -70,7 +70,7 @@ "test data bundle process" |> test_that({ - # stub out the Sys.time call with a repeating value + # Stub out the Sys.time call with a repeating value spcr_make_data_bundle |> mockery::stub("Sys.time", as.POSIXct("2023-12-04 21:25:25")) @@ -80,8 +80,8 @@ test_measure_config ) - # some spot checks on the above conversion of the last_data_point to the - # appropriate character format + # 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") @@ -127,12 +127,12 @@ }) -# 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 +# 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 + # 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") @@ -151,7 +151,7 @@ ) ) - # a measure_name mismatch in the measure data will throw a warning + # 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) { @@ -172,7 +172,7 @@ ) ) - # but a measure_name change in the report config should not throw an error + # 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") @@ -185,5 +185,4 @@ measure_config = test_measure_config ) ) - })