From c8b4bc15aaefd0a1225341068fc85079df595e26 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Thu, 12 Mar 2026 13:46:00 +0000 Subject: [PATCH 01/29] Add initial fns from pressure testing report --- R/helpers.R | 25 ++ R/pressure_testing.R | 580 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 605 insertions(+) create mode 100644 R/pressure_testing.R diff --git a/R/helpers.R b/R/helpers.R index 7557d02..4070345 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -35,3 +35,28 @@ make_novax_scenario <- function(disease) { names_from = "variable" ) } + +adaptive_round <- function( + x, + large_threshold = 1, + small_sigfig = 2, + large_digits = 1 +) { + ifelse( + abs(x) >= large_threshold, + round(x, large_digits), + signif(x, small_sigfig) + ) +} + +round_numeric <- function(df) { + df %>% + mutate(across( + where(is.numeric) & !matches("year", ignore.case = TRUE), + ~ adaptive_round(.x) + )) +} + +str_as_ts_year <- function(x) { + as.numeric(substr(x, 1, 6)) +} diff --git a/R/pressure_testing.R b/R/pressure_testing.R new file mode 100644 index 0000000..d4a15c6 --- /dev/null +++ b/R/pressure_testing.R @@ -0,0 +1,580 @@ +### All functions for pressure testing + +# Flexible rounding + +# Fix for scenario_type variable being included from 202310 onwards +filter_recent_ts <- function(df, threshold = 202310) { + touchstone_year <- unique(df$touchstone) + + # TODO: check that touchstone year is 6 digit - can there be more digits? + ts_number <- str_as_ts_year(touchstone_year) # see R/helpers.R + + if (ts_number >= threshold) { + df <- dplyr::filter( + df, + scenario_type == "default" + ) + } + + df +} + +# Helper for removing excluded diseases post-202110 +filter_excluded_diseases_ts <- function(df, threshold = 202110) { + exclude_dis <- c("Hib", "PCV", "Rota", "JE") + + touchstone_year <- unique(df$touchstone) + ts_number <- as.numeric(substr(touchstone_year, 1, 6)) + + if (ts_number <= threshold) { + df %>% filter(!disease %in% exclude_dis) + } else { + df + } +} + +# Identify duplicates +flag_duplicates <- function(df, key_cols) { + df %>% + add_count(across(all_of(key_cols)), name = "n_key") %>% + filter(n_key > 1) +} + +# Identify rows where deaths_averted went from non-NA to NA +comparison_prev <- function(df, prev_dat, outcome) { + prev_df <- prev_dat %>% + select(all_of(key_cols), all_of(outcome)) %>% + rename(outcome_prev = !!sym(outcome)) + + current_df <- df %>% + select(all_of(key_cols), all_of(outcome)) %>% + rename(outcome_cur = !!sym(outcome)) + + result <- prev_df %>% + inner_join(current_df, by = key_cols) %>% + filter(!is.na(outcome_prev) & is.na(outcome_cur)) + + return(result) +} + +# Explore significant changes in key outcomes (i.e. deaths/dalys) +generate_diffs <- function(prev_df, curr_df, interest_cols, key_cols) { + #fix for erroneous duplicated YF data in 201910 dataset + prev_df <- prev_df %>% + { + if (identical(pars$touchstone_old, "201910")) { + filter(., !(disease == "YF" & support_type == "other" & coverage == 0)) + } else { + . + } + } + + # Fix for multiple campaigns per year (i.e. not true duplicates) - only applicable for 2019 true non-duplicates. + add_campaign_id <- function(df, key_cols) { + df %>% + group_by(across(all_of(key_cols))) %>% + mutate(campaign_id = row_number()) %>% + ungroup() + } + + prev_df <- add_campaign_id(prev_df, key_cols) + curr_df <- add_campaign_id(curr_df, key_cols) + + diff_keys <- c(key_cols, "campaign_id") + cols_needed <- unique(c(diff_keys, interest_cols)) + + diff <- diffdf::diffdf( + prev_df[, cols_needed], + curr_df[, cols_needed], + keys = diff_keys + ) + + changes <- setNames( + lapply(interest_cols, function(v) { + nm <- paste0("VarDiff_", v) + if (nm %in% names(diff)) diff[[nm]] else NULL + }), + interest_cols + ) + + return(changes) +} + +# Generate IQR for key outcomes - for threshold of "significant" +gen_national_iqr <- function( + df, + group_cols, + value_cols, + prefix = "national_iqr_" +) { + df %>% + group_by(across(all_of(group_cols))) %>% + summarise( + across( + all_of(value_cols), + \(x) IQR(x, na.rm = TRUE), + .names = "{prefix}{.col}" + ), + .groups = "drop" + ) +} + +## Flag significant changes +flag_large_diffs <- function( + changes_list, + iqr_df, + variable, + group_cols, + threshold +) { + iqr_col <- paste0("national_iqr_", variable) + + changes_list[[variable]] %>% + mutate(diff = COMPARE - BASE) %>% + left_join( + iqr_df %>% select(all_of(group_cols), all_of(iqr_col)), + by = group_cols + ) %>% + mutate( + flag = abs(diff) > threshold * .data[[iqr_col]] & .data[[iqr_col]] > 0 + ) %>% + filter(flag) %>% + select( + country, + country_name, + year, + vaccine, + modelling_group, + activity_type, + BASE, + COMPARE, + diff + ) %>% + rename(!!as.character(old) := BASE, !!as.character(new) := COMPARE) %>% + arrange(desc(diff)) +} + +## Plot significant changes +significant_diff_plot <- function(df, outcome) { + df$label <- paste( + df$country_name, + df$vaccine, + df$activity_type, + df$year, + sep = " | " + ) + + ggplot(df, aes(x = diff, y = reorder(label, diff), color = modelling_group)) + + geom_segment(aes(x = 0, xend = diff, y = label, yend = label), size = 1) + + geom_point(size = 2) + + labs( + x = "Difference", + y = "", + title = glue( + "Significant Differences in {outcome} by Country, Vaccine, Activity Type and Year" + ) + ) + + theme_minimal() +} + +### Generate combined df +gen_combined_df <- function(prev_dat, df2, interest_cols, key_cols) { + prev_df <- prev_dat[, interest_cols] + cur_df <- df2[, interest_cols] + + combined <- full_join( + prev_df, + cur_df, + by = key_cols, + suffix = c("_old", "_new") + ) + + combined <- combined %>% + select( + country, + country_name, + disease, + vaccine, + activity_type, + year, + modelling_group, + deaths_averted_old, + deaths_averted_new, + dalys_averted_old, + dalys_averted_new + ) + return(combined) +} + +plot_diff <- function( + combined, + variable, + group_vars = c("activity_type", "vaccine") +) { + x_var <- paste0(variable, "_new") + y_var <- paste0(variable, "_old") + x_sym <- rlang::sym(x_var) + y_sym <- rlang::sym(y_var) + + combined <- combined %>% + filter(!is.na(!!x_sym) & !is.na(!!y_sym)) + + n_facets <- combined %>% + distinct(activity_type, vaccine) %>% + nrow() + + ncol_dynamic <- case_when( + n_facets <= 4 ~ 2, + n_facets <= 9 ~ 3, + n_facets <= 16 ~ 4, + n_facets <= 25 ~ 6, + TRUE ~ 8 + ) + + p <- ggplot(combined, aes(x = !!x_sym, y = !!y_sym)) + + geom_point(alpha = 0.5, colour = "#008080") + + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + + facet_wrap( + ~ activity_type + vaccine, + scales = "free", + ncol = ncol_dynamic + ) + + scale_x_log10() + + scale_y_log10() + + theme_bw() + + theme( + strip.text = element_text(size = 7), + panel.spacing = unit(0.05, "lines"), + axis.text = element_text(size = 6.5) + ) + + labs( + title = glue("{variable}: Current vs Previous Report"), + x = glue("{new} - {variable}"), + y = glue("{old} - {variable}") + ) + + return(p) +} + +### Subregional v national estimate comparison +compare_national_to_subregional <- function( + df, + outcome, + activity_filter, + threshold +) { + df <- df %>% + filter(activity_type == activity_filter) %>% + select(all_of(key_cols), subregion, !!outcome) + + results <- purrr::map_dfr(outcome, function(outcome) { + subregional_summary <- df %>% + group_by(subregion, disease, activity_type) %>% + summarise( + subregional_mean = mean(.data[[outcome]], na.rm = TRUE), + subregional_iqr = IQR(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) + + national_summary <- df %>% + select(all_of(key_cols), subregion, !!outcome) %>% + rename(national_value = !!outcome) + + comparison <- national_summary %>% + left_join(subregional_summary, by = c("subregion", "disease")) %>% + mutate( + outcome = outcome, + difference = national_value - subregional_mean, + iqr_score = abs(difference) / subregional_iqr + ) + + dynamic_threshold <- quantile(comparison$iqr_score, 0.99, na.rm = TRUE) + + comparison <- comparison %>% + mutate( + flag_iqr = iqr_score > dynamic_threshold & subregional_iqr > 0 + ) %>% + filter(flag_iqr) %>% + select( + country_name, + vaccine, + year, + modelling_group, + national_value, + subregional_mean, + subregional_iqr, + difference, + iqr_score + ) %>% + arrange(desc(iqr_score)) + + comparison + }) + + return(results) +} + +### Modelling group variations +plot_modelling_group_variation <- function(df2, df3, outc = "deaths") { + offset <- 1e-6 + + df2 %>% + left_join(df3, by = join_by(modelling_group, vaccine)) %>% + mutate(adj_outc = !!as.name(paste0(outc, "_averted")) + offset) %>% + group_by(vaccine) %>% + mutate(mean_outc = weighted.mean(adj_outc, fvps, na.rm = TRUE)) %>% + ggplot() + + aes( + fill = as.character(mod_num), + x = adj_outc, + y = reorder(vaccine, mean_outc) + ) + + geom_density_ridges( + alpha = 0.5, + stat = "binline", + bins = 200, + draw_baseline = FALSE + ) + + facet_grid(. ~ activity_type, scales = "fixed") + + theme_bw() + + theme( + legend.position = "none", + axis.text.x = element_text(angle = 90, hjust = 1) + ) + + scale_x_log10( + breaks = scales::trans_breaks("log10", function(x) 10^x), + labels = scales::trans_format("log10", math_format(10^.x)) + ) + + scale_fill_viridis_d() + + labs( + x = paste0( + "Burden averted (", + ifelse(outc == "dalys", "DALYs", outc), + ")" + ), + y = "Vaccine" + ) +} + + +# Gavi plot - future deaths and DALYS averted, 2021-2024 (current time window Gavi looking at, can be amended) +plot_vaccine_gavi <- function(df, prev_dat = NULL, outcome = "deaths_averted") { + df_cur <- df %>% + select(all_of(key_cols), !!outcome) %>% + filter(year >= 2021, year <= 2024, disease != "COVID") %>% + group_by(disease, year) %>% + summarise( + yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) %>% + mutate(dataset = as.character(new)) + + df_prev <- prev_dat %>% + select(all_of(key_cols), !!outcome) %>% + filter(year >= 2021, year <= 2024, disease != "COVID") %>% + group_by(disease, year) %>% + summarise( + yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) %>% + mutate(dataset = as.character(old)) + + df_combined <- bind_rows(df_cur, df_prev) + + df_diff <- df_cur %>% + left_join( + df_prev, + by = c("disease", "year"), + suffix = c("_curr", "_prev") + ) %>% + mutate( + yearly_outcome = yearly_outcome_curr - yearly_outcome_prev, + dataset = "Difference" + ) %>% + select(disease, year, yearly_outcome, dataset) + + df_combined <- bind_rows(df_combined, df_diff) + + df_combined$dataset <- factor( + df_combined$dataset, + levels = c(as.character(old), "Difference", as.character(new)) + ) + + ggplot( + df_combined, + aes( + x = reorder(disease, yearly_outcome), + y = yearly_outcome, + fill = factor(year) + ) + ) + + geom_col(position = "dodge") + + scale_fill_manual( + values = c( + "2021" = "#008080", + "2022" = "#E68424", + "2023" = "#9573B5", + "2024" = "#A1D15C" + ) + ) + + facet_wrap(~dataset, scales = "free_y") + + scale_y_continuous(labels = scales::scientific) + + theme_bw() + + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + + labs(x = "Disease", y = paste("Impact -", outcome), fill = "Year") +} + +### Gavi Cumulative Plot (modelling group + average) +plot_cumul <- function(df, outcome, disease_filter) { + outcome_cols <- names(df)[str_detect(names(df), paste0("^", outcome, "_"))] + + outcome_sym <- sym(outcome) + cum_col <- paste0("cum_", outcome) + avg_col <- paste0("avg_", outcome) + + col_old <- paste0(outcome, "_old") + col_new <- paste0(outcome, "_new") + + combined2 <- df %>% + select( + country, + country_name, + disease, + vaccine, + activity_type, + year, + modelling_group, + all_of(outcome_cols) + ) %>% + pivot_longer( + cols = all_of(outcome_cols), + names_to = "touchstone", + values_to = "value" + ) %>% + mutate( + touchstone = str_remove(touchstone, paste0("^", outcome, "_")), + touchstone = recode( + touchstone, + "old" = as.character(old), + "new" = as.character(new), + .default = touchstone + ), + touchstone = factor( + touchstone, + levels = c(as.character(old), as.character(new)) + ) + ) + # Cumulative values by modelling group + df_cum <- combined2 %>% + filter(disease == disease_filter) %>% + group_by(modelling_group, touchstone) %>% + complete(year = full_seq(year, 1)) %>% + arrange(year) %>% + mutate( + first_valid = min(year[!is.na(value)]), + !!cum_col := ifelse( + year < first_valid, + NA, + cumsum(replace_na(value, 0)) + ) + ) %>% + select(-first_valid) %>% + ungroup() %>% + mutate(modelling_group = paste(modelling_group, touchstone, sep = "-")) + + # Model average + df_avg <- df_cum %>% + group_by(year, touchstone) %>% + summarise( + !!avg_col := mean(!!sym(cum_col), na.rm = TRUE), + n_models = sum(!is.na(!!sym(cum_col))), + .groups = "drop" + ) %>% + filter(n_models >= 1) %>% + mutate(modelling_group = paste("Model Average", touchstone, sep = "-")) + + # Combine for plot + df_plot <- bind_rows( + df_cum %>% + select(year, modelling_group, touchstone, value = !!sym(cum_col)), + df_avg %>% + select(year, modelling_group, touchstone, value = !!sym(avg_col)) + ) + + df_plot <- df_plot %>% + group_by(modelling_group) %>% + filter(sum(value, na.rm = TRUE) > 0) %>% + ungroup() %>% + mutate( + line_type = ifelse( + grepl("Model Average", modelling_group), + "dashed", + "solid" + ) + ) + + if (nrow(df_plot) == 0 || all(df_plot$value == 0)) { + message("No non-zero data to plot for ", disease_filter, ". Skipping plot.") + return(NULL) + } + + p <- ggplot( + df_plot, + aes( + x = year, + y = value, + color = modelling_group, + linetype = line_type + ) + ) + + geom_step(direction = "hv", linewidth = 0.7, alpha = 0.9) + + scale_linetype_manual(values = c("solid" = "solid", "dashed" = "dashed")) + + guides(linetype = "none") + + scale_y_continuous(labels = scales::scientific) + + theme_minimal() + + labs( + x = "Year", + y = paste("Cumulative", outcome), + color = "Modelling Group", + title = paste("Cumulative", outcome, "Over Time –", disease_filter) + ) + + theme(legend.position = "bottom") + + return(p) +} + +save_outputs <- function() { + saveRDS( + round_numeric( + missing_in_current %>% + select(all_of(c( + "country_name", + "vaccine", + "activity_type", + "year", + "modelling_group" + ))) + ), + "outputs/missing_in_current.rds" + ) + saveRDS(round_numeric(missing_deaths), "outputs/missing_deaths.rds") + saveRDS(round_numeric(missing_dalys), "outputs/missing_dalys.rds") + saveRDS(round_numeric(changes_deaths), "outputs/changes_deaths.rds") + saveRDS(round_numeric(changes_dalys), "outputs/changes_dalys.rds") + saveRDS( + round_numeric(subregional_flags_deaths_camp), + "outputs/subregional_flags_deaths_camp.rds" + ) + saveRDS( + round_numeric(subregional_flags_deaths_rout), + "outputs/subregional_flags_deaths_rout.rds" + ) + saveRDS( + round_numeric(subregional_flags_dalys_camp), + "outputs/subregional_flags_dalys_camp.rds" + ) + saveRDS( + round_numeric(subregional_flags_dalys_rout), + "outputs/subregional_flags_dalys_rout.rds" + ) +} From db03465b35fa129a858df32d58994f6c5e62c4fa Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Thu, 12 Mar 2026 14:56:46 +0000 Subject: [PATCH 02/29] Move pressure testing plotting --- R/pressure_testing.R | 483 +++++++++---------------------------------- 1 file changed, 97 insertions(+), 386 deletions(-) diff --git a/R/pressure_testing.R b/R/pressure_testing.R index d4a15c6..d73c08f 100644 --- a/R/pressure_testing.R +++ b/R/pressure_testing.R @@ -10,24 +10,22 @@ filter_recent_ts <- function(df, threshold = 202310) { ts_number <- str_as_ts_year(touchstone_year) # see R/helpers.R if (ts_number >= threshold) { - df <- dplyr::filter( + dplyr::filter( df, scenario_type == "default" ) + } else { + df } - - df } # Helper for removing excluded diseases post-202110 filter_excluded_diseases_ts <- function(df, threshold = 202110) { - exclude_dis <- c("Hib", "PCV", "Rota", "JE") - touchstone_year <- unique(df$touchstone) - ts_number <- as.numeric(substr(touchstone_year, 1, 6)) + ts_number <- str_as_ts_year(touchstone_year) if (ts_number <= threshold) { - df %>% filter(!disease %in% exclude_dis) + filter(df, !disease %in% exclude_dis) } else { df } @@ -35,48 +33,41 @@ filter_excluded_diseases_ts <- function(df, threshold = 202110) { # Identify duplicates flag_duplicates <- function(df, key_cols) { - df %>% - add_count(across(all_of(key_cols)), name = "n_key") %>% - filter(n_key > 1) + df <- dplyr::add_count( + df, + dplyr::across(dplyr::all_of(key_cols)), + name = "n_key" + ) + + filter(df, n_key > 1) } # Identify rows where deaths_averted went from non-NA to NA comparison_prev <- function(df, prev_dat, outcome) { - prev_df <- prev_dat %>% - select(all_of(key_cols), all_of(outcome)) %>% - rename(outcome_prev = !!sym(outcome)) + prev_df <- select(prev_data, all_of(key_cols), all_of(outcome)) + prev_df <- rename(prev_df, outcome_prev = !!sym(outcome)) - current_df <- df %>% - select(all_of(key_cols), all_of(outcome)) %>% - rename(outcome_cur = !!sym(outcome)) + current_df <- select(current_df, all_of(key_cols), all_of(outcome)) + current_df <- rename(current_df, outcome_cur = !!sym(outcome)) - result <- prev_df %>% - inner_join(current_df, by = key_cols) %>% - filter(!is.na(outcome_prev) & is.na(outcome_cur)) + result <- inner_join(prev_df, current_df, by = key_cols) + result <- filter(result, !is.na(outcome_prev) & is.na(outcome_cur)) - return(result) + result } # Explore significant changes in key outcomes (i.e. deaths/dalys) generate_diffs <- function(prev_df, curr_df, interest_cols, key_cols) { #fix for erroneous duplicated YF data in 201910 dataset - prev_df <- prev_df %>% - { - if (identical(pars$touchstone_old, "201910")) { - filter(., !(disease == "YF" & support_type == "other" & coverage == 0)) - } else { - . - } - } - - # Fix for multiple campaigns per year (i.e. not true duplicates) - only applicable for 2019 true non-duplicates. - add_campaign_id <- function(df, key_cols) { - df %>% - group_by(across(all_of(key_cols))) %>% - mutate(campaign_id = row_number()) %>% - ungroup() + if (identical(pars$touchstone_old, TOUCHSTONE_OLD)) { + prev_df <- filter( + prev_df, + !(disease == "YF" & support_type == "other" & coverage == 0) + ) } + # Fix for multiple campaigns per year (i.e. not true duplicates) + # only applicable for 2019 true non-duplicates. prev_df <- add_campaign_id(prev_df, key_cols) curr_df <- add_campaign_id(curr_df, key_cols) @@ -97,7 +88,7 @@ generate_diffs <- function(prev_df, curr_df, interest_cols, key_cols) { interest_cols ) - return(changes) + changes } # Generate IQR for key outcomes - for threshold of "significant" @@ -107,18 +98,20 @@ gen_national_iqr <- function( value_cols, prefix = "national_iqr_" ) { - df %>% - group_by(across(all_of(group_cols))) %>% - summarise( - across( - all_of(value_cols), - \(x) IQR(x, na.rm = TRUE), - .names = "{prefix}{.col}" - ), - .groups = "drop" - ) + df <- group_by(df, across(all_of(group_cols))) + df <- summarise( + df, + across( + all_of(value_cols), + \(x) IQR(x, na.rm = TRUE), + .names = "{prefix}{.col}" + ), + .groups = "drop" + ) } +# TODO: I don't like how this looks - this should probably be a simpler +# functional that maps over a list in a separate function ## Flag significant changes flag_large_diffs <- function( changes_list, @@ -129,8 +122,22 @@ flag_large_diffs <- function( ) { iqr_col <- paste0("national_iqr_", variable) - changes_list[[variable]] %>% - mutate(diff = COMPARE - BASE) %>% + # returns a list so that the function can accept multiple variables + lapply( + changes_list[[variable]], + temp_fn, + iqr_df, + variable, + group_cols, + threshold + ) +} + +temp_fn <- function(df, iqr_df, variable, group_cols, threshold) { + mutate( + df, + diff = COMPARE - BASE + ) %>% left_join( iqr_df %>% select(all_of(group_cols), all_of(iqr_col)), by = group_cols @@ -154,29 +161,6 @@ flag_large_diffs <- function( arrange(desc(diff)) } -## Plot significant changes -significant_diff_plot <- function(df, outcome) { - df$label <- paste( - df$country_name, - df$vaccine, - df$activity_type, - df$year, - sep = " | " - ) - - ggplot(df, aes(x = diff, y = reorder(label, diff), color = modelling_group)) + - geom_segment(aes(x = 0, xend = diff, y = label, yend = label), size = 1) + - geom_point(size = 2) + - labs( - x = "Difference", - y = "", - title = glue( - "Significant Differences in {outcome} by Country, Vaccine, Activity Type and Year" - ) - ) + - theme_minimal() -} - ### Generate combined df gen_combined_df <- function(prev_dat, df2, interest_cols, key_cols) { prev_df <- prev_dat[, interest_cols] @@ -206,56 +190,6 @@ gen_combined_df <- function(prev_dat, df2, interest_cols, key_cols) { return(combined) } -plot_diff <- function( - combined, - variable, - group_vars = c("activity_type", "vaccine") -) { - x_var <- paste0(variable, "_new") - y_var <- paste0(variable, "_old") - x_sym <- rlang::sym(x_var) - y_sym <- rlang::sym(y_var) - - combined <- combined %>% - filter(!is.na(!!x_sym) & !is.na(!!y_sym)) - - n_facets <- combined %>% - distinct(activity_type, vaccine) %>% - nrow() - - ncol_dynamic <- case_when( - n_facets <= 4 ~ 2, - n_facets <= 9 ~ 3, - n_facets <= 16 ~ 4, - n_facets <= 25 ~ 6, - TRUE ~ 8 - ) - - p <- ggplot(combined, aes(x = !!x_sym, y = !!y_sym)) + - geom_point(alpha = 0.5, colour = "#008080") + - geom_abline(slope = 1, intercept = 0, linetype = "dashed") + - facet_wrap( - ~ activity_type + vaccine, - scales = "free", - ncol = ncol_dynamic - ) + - scale_x_log10() + - scale_y_log10() + - theme_bw() + - theme( - strip.text = element_text(size = 7), - panel.spacing = unit(0.05, "lines"), - axis.text = element_text(size = 6.5) - ) + - labs( - title = glue("{variable}: Current vs Previous Report"), - x = glue("{new} - {variable}"), - y = glue("{old} - {variable}") - ) - - return(p) -} - ### Subregional v national estimate comparison compare_national_to_subregional <- function( df, @@ -263,286 +197,63 @@ compare_national_to_subregional <- function( activity_filter, threshold ) { - df <- df %>% - filter(activity_type == activity_filter) %>% - select(all_of(key_cols), subregion, !!outcome) - - results <- purrr::map_dfr(outcome, function(outcome) { - subregional_summary <- df %>% - group_by(subregion, disease, activity_type) %>% - summarise( - subregional_mean = mean(.data[[outcome]], na.rm = TRUE), - subregional_iqr = IQR(.data[[outcome]], na.rm = TRUE), - .groups = "drop" - ) - - national_summary <- df %>% - select(all_of(key_cols), subregion, !!outcome) %>% - rename(national_value = !!outcome) - - comparison <- national_summary %>% - left_join(subregional_summary, by = c("subregion", "disease")) %>% - mutate( - outcome = outcome, - difference = national_value - subregional_mean, - iqr_score = abs(difference) / subregional_iqr - ) - - dynamic_threshold <- quantile(comparison$iqr_score, 0.99, na.rm = TRUE) - - comparison <- comparison %>% - mutate( - flag_iqr = iqr_score > dynamic_threshold & subregional_iqr > 0 - ) %>% - filter(flag_iqr) %>% - select( - country_name, - vaccine, - year, - modelling_group, - national_value, - subregional_mean, - subregional_iqr, - difference, - iqr_score - ) %>% - arrange(desc(iqr_score)) - - comparison - }) - - return(results) -} - -### Modelling group variations -plot_modelling_group_variation <- function(df2, df3, outc = "deaths") { - offset <- 1e-6 - - df2 %>% - left_join(df3, by = join_by(modelling_group, vaccine)) %>% - mutate(adj_outc = !!as.name(paste0(outc, "_averted")) + offset) %>% - group_by(vaccine) %>% - mutate(mean_outc = weighted.mean(adj_outc, fvps, na.rm = TRUE)) %>% - ggplot() + - aes( - fill = as.character(mod_num), - x = adj_outc, - y = reorder(vaccine, mean_outc) - ) + - geom_density_ridges( - alpha = 0.5, - stat = "binline", - bins = 200, - draw_baseline = FALSE - ) + - facet_grid(. ~ activity_type, scales = "fixed") + - theme_bw() + - theme( - legend.position = "none", - axis.text.x = element_text(angle = 90, hjust = 1) - ) + - scale_x_log10( - breaks = scales::trans_breaks("log10", function(x) 10^x), - labels = scales::trans_format("log10", math_format(10^.x)) - ) + - scale_fill_viridis_d() + - labs( - x = paste0( - "Burden averted (", - ifelse(outc == "dalys", "DALYs", outc), - ")" - ), - y = "Vaccine" - ) -} - - -# Gavi plot - future deaths and DALYS averted, 2021-2024 (current time window Gavi looking at, can be amended) -plot_vaccine_gavi <- function(df, prev_dat = NULL, outcome = "deaths_averted") { - df_cur <- df %>% - select(all_of(key_cols), !!outcome) %>% - filter(year >= 2021, year <= 2024, disease != "COVID") %>% - group_by(disease, year) %>% - summarise( - yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), + df <- filter(df, activity_type == activity_filter) + df <- select(df, all_of(key_cols), subregion, !!outcome) + + results <- purrr::map_dfr(outcome, function(otc) { + subregional_summary <- + group_by(df, subregion, disease, activity_type) + subregional_summary <- summarise( + subregional_summary, + subregional_mean = mean(.data[[otc]], na.rm = TRUE), + subregional_iqr = IQR(.data[[otc]], na.rm = TRUE), .groups = "drop" - ) %>% - mutate(dataset = as.character(new)) - - df_prev <- prev_dat %>% - select(all_of(key_cols), !!outcome) %>% - filter(year >= 2021, year <= 2024, disease != "COVID") %>% - group_by(disease, year) %>% - summarise( - yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), - .groups = "drop" - ) %>% - mutate(dataset = as.character(old)) - - df_combined <- bind_rows(df_cur, df_prev) - - df_diff <- df_cur %>% - left_join( - df_prev, - by = c("disease", "year"), - suffix = c("_curr", "_prev") - ) %>% - mutate( - yearly_outcome = yearly_outcome_curr - yearly_outcome_prev, - dataset = "Difference" - ) %>% - select(disease, year, yearly_outcome, dataset) - - df_combined <- bind_rows(df_combined, df_diff) - - df_combined$dataset <- factor( - df_combined$dataset, - levels = c(as.character(old), "Difference", as.character(new)) - ) - - ggplot( - df_combined, - aes( - x = reorder(disease, yearly_outcome), - y = yearly_outcome, - fill = factor(year) ) - ) + - geom_col(position = "dodge") + - scale_fill_manual( - values = c( - "2021" = "#008080", - "2022" = "#E68424", - "2023" = "#9573B5", - "2024" = "#A1D15C" - ) - ) + - facet_wrap(~dataset, scales = "free_y") + - scale_y_continuous(labels = scales::scientific) + - theme_bw() + - theme(axis.text.x = element_text(angle = 45, hjust = 1)) + - labs(x = "Disease", y = paste("Impact -", outcome), fill = "Year") -} -### Gavi Cumulative Plot (modelling group + average) -plot_cumul <- function(df, outcome, disease_filter) { - outcome_cols <- names(df)[str_detect(names(df), paste0("^", outcome, "_"))] + national_summary <- + select(df, all_of(key_cols), subregion, !!outcome) + national_summary <- rename(national_summary, national_value = !!outcome) - outcome_sym <- sym(outcome) - cum_col <- paste0("cum_", outcome) - avg_col <- paste0("avg_", outcome) + comparison <- left_join( + national_summary, + subregional_summary, + by = c("subregion", "disease") + ) + comparison <- mutate( + comparison, + outcome = outcome, + difference = national_value - subregional_mean, + iqr_score = abs(difference) / subregional_iqr + ) - col_old <- paste0(outcome, "_old") - col_new <- paste0(outcome, "_new") + dynamic_threshold <- quantile(comparison$iqr_score, 0.99, na.rm = TRUE) - combined2 <- df %>% - select( - country, + comparison <- mutate( + comparison, + flag_iqr = iqr_score > dynamic_threshold & subregional_iqr > 0 + ) + comparison <- filter(comparison, flag_iqr) + comparison <- select( + comparison, country_name, - disease, vaccine, - activity_type, year, modelling_group, - all_of(outcome_cols) - ) %>% - pivot_longer( - cols = all_of(outcome_cols), - names_to = "touchstone", - values_to = "value" - ) %>% - mutate( - touchstone = str_remove(touchstone, paste0("^", outcome, "_")), - touchstone = recode( - touchstone, - "old" = as.character(old), - "new" = as.character(new), - .default = touchstone - ), - touchstone = factor( - touchstone, - levels = c(as.character(old), as.character(new)) - ) - ) - # Cumulative values by modelling group - df_cum <- combined2 %>% - filter(disease == disease_filter) %>% - group_by(modelling_group, touchstone) %>% - complete(year = full_seq(year, 1)) %>% - arrange(year) %>% - mutate( - first_valid = min(year[!is.na(value)]), - !!cum_col := ifelse( - year < first_valid, - NA, - cumsum(replace_na(value, 0)) - ) - ) %>% - select(-first_valid) %>% - ungroup() %>% - mutate(modelling_group = paste(modelling_group, touchstone, sep = "-")) - - # Model average - df_avg <- df_cum %>% - group_by(year, touchstone) %>% - summarise( - !!avg_col := mean(!!sym(cum_col), na.rm = TRUE), - n_models = sum(!is.na(!!sym(cum_col))), - .groups = "drop" - ) %>% - filter(n_models >= 1) %>% - mutate(modelling_group = paste("Model Average", touchstone, sep = "-")) - - # Combine for plot - df_plot <- bind_rows( - df_cum %>% - select(year, modelling_group, touchstone, value = !!sym(cum_col)), - df_avg %>% - select(year, modelling_group, touchstone, value = !!sym(avg_col)) - ) - - df_plot <- df_plot %>% - group_by(modelling_group) %>% - filter(sum(value, na.rm = TRUE) > 0) %>% - ungroup() %>% - mutate( - line_type = ifelse( - grepl("Model Average", modelling_group), - "dashed", - "solid" - ) + national_value, + subregional_mean, + subregional_iqr, + difference, + iqr_score ) + comparison <- arrange(comparison, desc(iqr_score)) - if (nrow(df_plot) == 0 || all(df_plot$value == 0)) { - message("No non-zero data to plot for ", disease_filter, ". Skipping plot.") - return(NULL) - } + comparison + }) - p <- ggplot( - df_plot, - aes( - x = year, - y = value, - color = modelling_group, - linetype = line_type - ) - ) + - geom_step(direction = "hv", linewidth = 0.7, alpha = 0.9) + - scale_linetype_manual(values = c("solid" = "solid", "dashed" = "dashed")) + - guides(linetype = "none") + - scale_y_continuous(labels = scales::scientific) + - theme_minimal() + - labs( - x = "Year", - y = paste("Cumulative", outcome), - color = "Modelling Group", - title = paste("Cumulative", outcome, "Over Time –", disease_filter) - ) + - theme(legend.position = "bottom") - - return(p) + results } +### Modelling group variations save_outputs <- function() { saveRDS( round_numeric( From 50f6b0d4e35a51382c13cd57a1dae7f85d7d482c Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Thu, 12 Mar 2026 14:57:14 +0000 Subject: [PATCH 03/29] Clean up funs and add constants --- R/constants.R | 6 + R/helpers.R | 7 + R/plotting_pressure_testing.R | 300 ++++++++++++++++++++++++++++++++++ man/constants.Rd | 10 ++ 4 files changed, 323 insertions(+) create mode 100644 R/plotting_pressure_testing.R diff --git a/R/constants.R b/R/constants.R index 03cd537..e214aa2 100644 --- a/R/constants.R +++ b/R/constants.R @@ -46,3 +46,9 @@ colnames_plot_demog_compare <- c( "value", "value_millions" ) + +#' @name constants +EXCLUDED_DISEASES <- c("Hib", "PCV", "Rota", "JE") + +#' @name constants +TOUCHSTONE_OLD <- "201910" diff --git a/R/helpers.R b/R/helpers.R index 4070345..d065a9e 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -60,3 +60,10 @@ round_numeric <- function(df) { str_as_ts_year <- function(x) { as.numeric(substr(x, 1, 6)) } + +add_campaign_id <- function(df, key_cols) { + df <- group_by(df, across(all_of(key_cols))) + df <- mutate(df, campaign_id = row_number()) + + ungroup(df) +} diff --git a/R/plotting_pressure_testing.R b/R/plotting_pressure_testing.R new file mode 100644 index 0000000..08a4329 --- /dev/null +++ b/R/plotting_pressure_testing.R @@ -0,0 +1,300 @@ +## Plot significant changes +significant_diff_plot <- function(df, outcome) { + df$label <- paste( + df$country_name, + df$vaccine, + df$activity_type, + df$year, + sep = " | " + ) + + ggplot(df, aes(x = diff, y = reorder(label, diff), color = modelling_group)) + + geom_segment(aes(x = 0, xend = diff, y = label, yend = label), size = 1) + + geom_point(size = 2) + + labs( + x = "Difference", + y = "", + title = glue( + "Significant Differences in {outcome} by Country, Vaccine, Activity Type and Year" + ) + ) + + theme_minimal() +} + +plot_diff <- function( + combined, + variable, + group_vars = c("activity_type", "vaccine") +) { + x_var <- paste0(variable, "_new") + y_var <- paste0(variable, "_old") + x_sym <- rlang::sym(x_var) + y_sym <- rlang::sym(y_var) + + combined <- combined %>% + filter(!is.na(!!x_sym) & !is.na(!!y_sym)) + + n_facets <- combined %>% + distinct(activity_type, vaccine) %>% + nrow() + + ncol_dynamic <- case_when( + n_facets <= 4 ~ 2, + n_facets <= 9 ~ 3, + n_facets <= 16 ~ 4, + n_facets <= 25 ~ 6, + TRUE ~ 8 + ) + + p <- ggplot(combined, aes(x = !!x_sym, y = !!y_sym)) + + geom_point(alpha = 0.5, colour = "#008080") + + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + + facet_wrap( + ~ activity_type + vaccine, + scales = "free", + ncol = ncol_dynamic + ) + + scale_x_log10() + + scale_y_log10() + + theme_bw() + + theme( + strip.text = element_text(size = 7), + panel.spacing = unit(0.05, "lines"), + axis.text = element_text(size = 6.5) + ) + + labs( + title = glue("{variable}: Current vs Previous Report"), + x = glue("{new} - {variable}"), + y = glue("{old} - {variable}") + ) + + return(p) +} + +plot_modelling_group_variation <- function(df2, df3, outc = "deaths") { + offset <- 1e-6 + + df2 %>% + left_join(df3, by = join_by(modelling_group, vaccine)) %>% + mutate(adj_outc = !!as.name(paste0(outc, "_averted")) + offset) %>% + group_by(vaccine) %>% + mutate(mean_outc = weighted.mean(adj_outc, fvps, na.rm = TRUE)) %>% + ggplot() + + aes( + fill = as.character(mod_num), + x = adj_outc, + y = reorder(vaccine, mean_outc) + ) + + geom_density_ridges( + alpha = 0.5, + stat = "binline", + bins = 200, + draw_baseline = FALSE + ) + + facet_grid(. ~ activity_type, scales = "fixed") + + theme_bw() + + theme( + legend.position = "none", + axis.text.x = element_text(angle = 90, hjust = 1) + ) + + scale_x_log10( + breaks = scales::trans_breaks("log10", function(x) 10^x), + labels = scales::trans_format("log10", math_format(10^.x)) + ) + + scale_fill_viridis_d() + + labs( + x = paste0( + "Burden averted (", + ifelse(outc == "dalys", "DALYs", outc), + ")" + ), + y = "Vaccine" + ) +} + + +# Gavi plot - future deaths and DALYS averted, 2021-2024 (current time window Gavi looking at, can be amended) +plot_vaccine_gavi <- function(df, prev_dat = NULL, outcome = "deaths_averted") { + df_cur <- df %>% + select(all_of(key_cols), !!outcome) %>% + filter(year >= 2021, year <= 2024, disease != "COVID") %>% + group_by(disease, year) %>% + summarise( + yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) %>% + mutate(dataset = as.character(new)) + + df_prev <- prev_dat %>% + select(all_of(key_cols), !!outcome) %>% + filter(year >= 2021, year <= 2024, disease != "COVID") %>% + group_by(disease, year) %>% + summarise( + yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) %>% + mutate(dataset = as.character(old)) + + df_combined <- bind_rows(df_cur, df_prev) + + df_diff <- df_cur %>% + left_join( + df_prev, + by = c("disease", "year"), + suffix = c("_curr", "_prev") + ) %>% + mutate( + yearly_outcome = yearly_outcome_curr - yearly_outcome_prev, + dataset = "Difference" + ) %>% + select(disease, year, yearly_outcome, dataset) + + df_combined <- bind_rows(df_combined, df_diff) + + df_combined$dataset <- factor( + df_combined$dataset, + levels = c(as.character(old), "Difference", as.character(new)) + ) + + ggplot( + df_combined, + aes( + x = reorder(disease, yearly_outcome), + y = yearly_outcome, + fill = factor(year) + ) + ) + + geom_col(position = "dodge") + + scale_fill_manual( + values = c( + "2021" = "#008080", + "2022" = "#E68424", + "2023" = "#9573B5", + "2024" = "#A1D15C" + ) + ) + + facet_wrap(~dataset, scales = "free_y") + + scale_y_continuous(labels = scales::scientific) + + theme_bw() + + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + + labs(x = "Disease", y = paste("Impact -", outcome), fill = "Year") +} + +### Gavi Cumulative Plot (modelling group + average) +plot_cumul <- function(df, outcome, disease_filter) { + outcome_cols <- names(df)[str_detect(names(df), paste0("^", outcome, "_"))] + + outcome_sym <- sym(outcome) + cum_col <- paste0("cum_", outcome) + avg_col <- paste0("avg_", outcome) + + col_old <- paste0(outcome, "_old") + col_new <- paste0(outcome, "_new") + + combined2 <- df %>% + select( + country, + country_name, + disease, + vaccine, + activity_type, + year, + modelling_group, + all_of(outcome_cols) + ) %>% + pivot_longer( + cols = all_of(outcome_cols), + names_to = "touchstone", + values_to = "value" + ) %>% + mutate( + touchstone = str_remove(touchstone, paste0("^", outcome, "_")), + touchstone = recode( + touchstone, + "old" = as.character(old), + "new" = as.character(new), + .default = touchstone + ), + touchstone = factor( + touchstone, + levels = c(as.character(old), as.character(new)) + ) + ) + # Cumulative values by modelling group + df_cum <- combined2 %>% + filter(disease == disease_filter) %>% + group_by(modelling_group, touchstone) %>% + complete(year = full_seq(year, 1)) %>% + arrange(year) %>% + mutate( + first_valid = min(year[!is.na(value)]), + !!cum_col := ifelse( + year < first_valid, + NA, + cumsum(replace_na(value, 0)) + ) + ) %>% + select(-first_valid) %>% + ungroup() %>% + mutate(modelling_group = paste(modelling_group, touchstone, sep = "-")) + + # Model average + df_avg <- df_cum %>% + group_by(year, touchstone) %>% + summarise( + !!avg_col := mean(!!sym(cum_col), na.rm = TRUE), + n_models = sum(!is.na(!!sym(cum_col))), + .groups = "drop" + ) %>% + filter(n_models >= 1) %>% + mutate(modelling_group = paste("Model Average", touchstone, sep = "-")) + + # Combine for plot + df_plot <- bind_rows( + df_cum %>% + select(year, modelling_group, touchstone, value = !!sym(cum_col)), + df_avg %>% + select(year, modelling_group, touchstone, value = !!sym(avg_col)) + ) + + df_plot <- df_plot %>% + group_by(modelling_group) %>% + filter(sum(value, na.rm = TRUE) > 0) %>% + ungroup() %>% + mutate( + line_type = ifelse( + grepl("Model Average", modelling_group), + "dashed", + "solid" + ) + ) + + if (nrow(df_plot) == 0 || all(df_plot$value == 0)) { + message("No non-zero data to plot for ", disease_filter, ". Skipping plot.") + return(NULL) + } + + p <- ggplot( + df_plot, + aes( + x = year, + y = value, + color = modelling_group, + linetype = line_type + ) + ) + + geom_step(direction = "hv", linewidth = 0.7, alpha = 0.9) + + scale_linetype_manual(values = c("solid" = "solid", "dashed" = "dashed")) + + guides(linetype = "none") + + scale_y_continuous(labels = scales::scientific) + + theme_minimal() + + labs( + x = "Year", + y = paste("Cumulative", outcome), + color = "Modelling Group", + title = paste("Cumulative", outcome, "Over Time –", disease_filter) + ) + + theme(legend.position = "bottom") + + return(p) +} diff --git a/man/constants.Rd b/man/constants.Rd index 70b14da..7608951 100644 --- a/man/constants.Rd +++ b/man/constants.Rd @@ -7,6 +7,8 @@ \alias{scenario_data_colnames} \alias{burden_outcome_names} \alias{colnames_plot_demog_compare} +\alias{EXCLUDED_DISEASES} +\alias{TOUCHSTONE_OLD} \title{Package constants} \format{ An object of class \code{character} of length 5. @@ -16,6 +18,10 @@ An object of class \code{character} of length 4. An object of class \code{character} of length 10. An object of class \code{character} of length 7. + +An object of class \code{character} of length 4. + +An object of class \code{character} of length 1. } \usage{ file_dict_colnames @@ -25,6 +31,10 @@ scenario_data_colnames burden_outcome_names colnames_plot_demog_compare + +EXCLUDED_DISEASES + +TOUCHSTONE_OLD } \description{ Package constants From 13d624435632dedd107d1939cbafb389cffd2656 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Fri, 13 Mar 2026 12:14:18 +0000 Subject: [PATCH 04/29] Clean up fns and add constants --- R/constants.R | 6 + ...sting.R => fn_plotting_pressure_testing.R} | 26 +- R/fn_pressure_testing.R | 361 ++++++++++++++++++ 3 files changed, 382 insertions(+), 11 deletions(-) rename R/{plotting_pressure_testing.R => fn_plotting_pressure_testing.R} (94%) create mode 100644 R/fn_pressure_testing.R diff --git a/R/constants.R b/R/constants.R index e214aa2..20ae152 100644 --- a/R/constants.R +++ b/R/constants.R @@ -52,3 +52,9 @@ EXCLUDED_DISEASES <- c("Hib", "PCV", "Rota", "JE") #' @name constants TOUCHSTONE_OLD <- "201910" + +#' @name constants +TOUCHSTONE_NEW <- "202310" + +#' @name constants +TOUCHSTONE_OLD_OLD <- "202110" diff --git a/R/plotting_pressure_testing.R b/R/fn_plotting_pressure_testing.R similarity index 94% rename from R/plotting_pressure_testing.R rename to R/fn_plotting_pressure_testing.R index 08a4329..8aaad49 100644 --- a/R/plotting_pressure_testing.R +++ b/R/fn_plotting_pressure_testing.R @@ -1,11 +1,14 @@ -## Plot significant changes +#' Plot significant changes +#' +#' @importFrom ggplot2 ggplot aes geom_col geom_hline facet_wrap facet_grid +#' scale_fill_distiller scale_x_continuous scale_y_continuous labs vars +#' labeller label_wrap_gen +#' +#' @export significant_diff_plot <- function(df, outcome) { - df$label <- paste( - df$country_name, - df$vaccine, - df$activity_type, - df$year, - sep = " | " + # retained here as this is a small df and a small operation + df$label <- glue::glue( + "{df$country_name} | {df$vaccine} | {df$activity_type} | {df$year}" ) ggplot(df, aes(x = diff, y = reorder(label, diff), color = modelling_group)) + @@ -13,12 +16,13 @@ significant_diff_plot <- function(df, outcome) { geom_point(size = 2) + labs( x = "Difference", - y = "", - title = glue( - "Significant Differences in {outcome} by Country, Vaccine, Activity Type and Year" + y = NULL, + title = glue::glue( + "Significant Differences in {outcome} by Country, Vaccine, \\ + Activity Type and Year" ) ) + - theme_minimal() + theme_vimc(x_text_angle = 0) } plot_diff <- function( diff --git a/R/fn_pressure_testing.R b/R/fn_pressure_testing.R new file mode 100644 index 0000000..140cc79 --- /dev/null +++ b/R/fn_pressure_testing.R @@ -0,0 +1,361 @@ +#' Fix for scenario_type variable being included from 202310 onwards +#' +#' @keywords pressure_testing +#' +#' @export +filter_recent_ts <- function(df, threshold = 202310) { + touchstone_year <- unique(df$touchstone) + + # TODO: check that touchstone year is 6 digit - can there be more digits? + ts_number <- str_as_ts_year(touchstone_year) # see R/helpers.R + + if (ts_number >= threshold) { + dplyr::filter( + df, + .data$scenario_type == "default" + ) + } else { + df + } +} + +#' Helper for removing excluded diseases post-202110 +#' +#' @export +filter_excluded_diseases_ts <- function(df, threshold = 202110) { + touchstone_year <- unique(df$touchstone) + ts_number <- str_as_ts_year(touchstone_year) + + if (ts_number <= threshold) { + dplyr::filter(df, !.data$disease %in% EXCLUDED_DISEASES) + } else { + df + } +} + +#' Identify duplicates +#' +#' @export +flag_duplicates <- function(df, key_cols) { + df <- dplyr::add_count( + df, + dplyr::across(dplyr::all_of(key_cols)), + name = "n_key" + ) + + dplyr::filter(df, .data$n_key > 1) +} + +#' Identify rows where deaths_averted went from non-NA to NA +#' +#' @export +comparison_prev <- function(df, prev_data, outcome) { + prev_df <- dplyr::select( + prev_data, + dplyr::all_of(key_cols), + dplyr::all_of(outcome) + ) + prev_df <- dplyr::rename(prev_df, outcome_prev = {{ outcome }}) + + current_df <- dplyr::select( + df, + dplyr::all_of(key_cols), + dplyr::all_of(outcome) + ) + current_df <- dplyr::rename(current_df, outcome_cur = {{ outcome }}) + + result <- dplyr::inner_join(prev_df, current_df, by = key_cols) + # `,` replaces `&` for dplyr syntax + result <- dplyr::filter(result, !is.na(outcome_prev), is.na(outcome_cur)) + + result +} + +#' Explore significant changes in deaths and DALYs +#' +#' @keywords pressure_testing +#' +#' @export +generate_diffs <- function( + prev_df, + curr_df, + interest_cols, + key_cols, + touchstone = TOUCHSTONE_OLD +) { + # TODO: replace use of `pars$touchstone_old` with arg `touchstone` + #fix for erroneous duplicated YF data in 201910 dataset + if (identical(touchstone, TOUCHSTONE_OLD)) { + prev_df <- dplyr::filter( + prev_df, + !(.data$disease == "YF" & + .data$support_type == "other" & + .data$coverage == 0) + ) + } + + # Fix for multiple campaigns per year (i.e. not true duplicates) + # only applicable for 2019 true non-duplicates. + prev_df <- add_campaign_id(prev_df, key_cols) + curr_df <- add_campaign_id(curr_df, key_cols) + + diff_keys <- c(key_cols, "campaign_id") + cols_needed <- unique(c(diff_keys, interest_cols)) + + diff <- diffdf::diffdf( + prev_df[, cols_needed], + curr_df[, cols_needed], + keys = diff_keys + ) + + changes <- stats::setNames( + lapply(interest_cols, function(v) { + nm <- glue::glue("VarDiff_{v}") + if (nm %in% names(diff)) diff[[nm]] else NULL + }), + interest_cols + ) + + changes +} + +#' Generate IQR for key outcomes +#' +#' @keywords pressure_testing +#' +#' @export +gen_national_iqr <- function( + df, + group_cols, + value_cols, + prefix = "national_iqr_" +) { + df <- dplyr::group_by(df, dplyr::across(dplyr::all_of(group_cols))) + df <- dplyr::summarise( + df, + dplyr::across( + dplyr::all_of(value_cols), + function(x) { + IQR(x, na.rm = TRUE) + }, + .names = "{prefix}{.col}" + ), + .groups = "drop" + ) +} + +#' Flag significant changes +#' +#' @keywords pressure_testing +#' +#' @export +flag_large_diffs <- function( + changes_list, + iqr_df, + variable = c("deaths_averted", "dalys_averted"), + group_cols, + threshold +) { + # TODO: input checking + variable <- rlang::arg_match(variable) + + iqr_col <- glue::glue("national_iqr_{variable}") + + df <- dplyr::mutate( + changes_list[[variable]], + diff = .data$COMPARE - .data$BASE + ) + + iqr_df <- dplyr::select( + iqr_df, + dplyr::all_of(group_cols), + dplyr::all_of(iqr_col) + ) + + df <- left_join( + df, + iqr_df, + by = group_cols + ) + + df <- dplyr::mutate( + df, + flag = abs(.data$diff) > threshold * .data[[iqr_col]] & .data[[iqr_col]] > 0 + ) + + df <- dplyr::filter(df, .data$flag) + + cols_to_select <- c( + "country", + "country_name", + "year", + "vaccine", + "modelling_group", + "activity_type", + "BASE", + "COMPARE", + "diff" + ) + + df <- dplyr::select( + df, + {{ cols_to_select }} + ) + + # TODO: replace `old` and `new` with defined objs --- see scratch.R + # unsure why this syntax was used + df <- dplyr::rename( + df, + !!as.character(old) := BASE, + !!as.character(new) := COMPARE + ) + + dplyr::arrange(df, dplyr::desc(diff)) +} + +#' Generate combined df +#' +#' @keywords pressure_testing +#' +#' @export +gen_combined_df <- function(prev_dat, df2, interest_cols, key_cols) { + # TODO: input checks + # TODO: df2 needs a better name + prev_df <- dplyr::select(prev_dat, {{ interest_cols }}) + cur_df <- dplyr::select(df2, {{ interest_cols }}) + + combined <- dplyr::full_join( + prev_df, + cur_df, + by = key_cols, + suffix = c("_old", "_new") + ) + + dplyr::select( + combined, + country, + country_name, + disease, + vaccine, + activity_type, + year, + modelling_group, + deaths_averted_old, + deaths_averted_new, + dalys_averted_old, + dalys_averted_new + ) +} + +### Subregional v national estimate comparison +compare_national_to_subregional <- function( + df, + outcome, + activity_filter, + threshold +) { + df <- dplyr::filter(df, activity_type == activity_filter) + df <- dplyr::select(df, dplyr::all_of(key_cols), subregion, !!outcome) + + results <- purrr::map_dfr(outcome, function(otc) { + subregional_summary <- + dplyr::group_by(df, subregion, disease, activity_type) + + subregional_summary <- dplyr::summarise( + subregional_summary, + subregional_mean = mean(.data[[otc]], na.rm = TRUE), + subregional_iqr = IQR(.data[[otc]], na.rm = TRUE), + .groups = "drop" + ) + + national_summary <- + dplyr::select(df, dplyr::all_of(key_cols), subregion, !!outcome) + national_summary <- dplyr::rename( + national_summary, + national_value = !!outcome + ) + + comparison <- dplyr::left_join( + national_summary, + subregional_summary, + by = c("subregion", "disease") + ) + comparison <- dplyr::mutate( + comparison, + outcome = outcome, + difference = .data$national_value - .data$subregional_mean, + iqr_score = abs(.data$difference) / .data$subregional_iqr + ) + + dynamic_threshold <- stats::quantile( + comparison$iqr_score, + 0.99, + na.rm = TRUE + ) + + comparison <- dplyr::mutate( + comparison, + flag_iqr = .data$iqr_score > dynamic_threshold & .data$subregional_iqr > 0 + ) + comparison <- dplyr::filter(comparison, .data$flag_iqr) + comparison <- dplyr::select( + comparison, + country_name, + vaccine, + year, + modelling_group, + national_value, + subregional_mean, + subregional_iqr, + difference, + iqr_score + ) + comparison <- dplyr::arrange(comparison, dplyr::desc(.data$iqr_score)) + + comparison + }) + + results +} + +# TODO: reconsider function name, add explicit arguments +#' Modelling group variations +#' +#' @keywords pressure_testing +#' +#' @export +save_outputs <- function() { + saveRDS( + round_numeric( + missing_in_current %>% + dplyr::select(dplyr::all_of(c( + "country_name", + "vaccine", + "activity_type", + "year", + "modelling_group" + ))) + ), + "outputs/missing_in_current.rds" + ) + saveRDS(round_numeric(missing_deaths), "outputs/missing_deaths.rds") + saveRDS(round_numeric(missing_dalys), "outputs/missing_dalys.rds") + saveRDS(round_numeric(changes_deaths), "outputs/changes_deaths.rds") + saveRDS(round_numeric(changes_dalys), "outputs/changes_dalys.rds") + saveRDS( + round_numeric(subregional_flags_deaths_camp), + "outputs/subregional_flags_deaths_camp.rds" + ) + saveRDS( + round_numeric(subregional_flags_deaths_rout), + "outputs/subregional_flags_deaths_rout.rds" + ) + saveRDS( + round_numeric(subregional_flags_dalys_camp), + "outputs/subregional_flags_dalys_camp.rds" + ) + saveRDS( + round_numeric(subregional_flags_dalys_rout), + "outputs/subregional_flags_dalys_rout.rds" + ) +} From 8aa8494dfab033d9d4e70092f1b2237343ccf6af Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Fri, 13 Mar 2026 12:15:14 +0000 Subject: [PATCH 05/29] Rename files --- ..._diagnostics.R => fn_burden_diagnostics.R} | 0 R/{helpers.R => fn_helpers.R} | 0 ...ing.R => fn_plotting_burden_diagnostics.R} | 0 ...ing_prep.R => fn_plotting_prep_bur_diag.R} | 0 R/pressure_testing.R | 291 ------------------ 5 files changed, 291 deletions(-) rename R/{burden_diagnostics.R => fn_burden_diagnostics.R} (100%) rename R/{helpers.R => fn_helpers.R} (100%) rename R/{plotting.R => fn_plotting_burden_diagnostics.R} (100%) rename R/{plotting_prep.R => fn_plotting_prep_bur_diag.R} (100%) delete mode 100644 R/pressure_testing.R diff --git a/R/burden_diagnostics.R b/R/fn_burden_diagnostics.R similarity index 100% rename from R/burden_diagnostics.R rename to R/fn_burden_diagnostics.R diff --git a/R/helpers.R b/R/fn_helpers.R similarity index 100% rename from R/helpers.R rename to R/fn_helpers.R diff --git a/R/plotting.R b/R/fn_plotting_burden_diagnostics.R similarity index 100% rename from R/plotting.R rename to R/fn_plotting_burden_diagnostics.R diff --git a/R/plotting_prep.R b/R/fn_plotting_prep_bur_diag.R similarity index 100% rename from R/plotting_prep.R rename to R/fn_plotting_prep_bur_diag.R diff --git a/R/pressure_testing.R b/R/pressure_testing.R deleted file mode 100644 index d73c08f..0000000 --- a/R/pressure_testing.R +++ /dev/null @@ -1,291 +0,0 @@ -### All functions for pressure testing - -# Flexible rounding - -# Fix for scenario_type variable being included from 202310 onwards -filter_recent_ts <- function(df, threshold = 202310) { - touchstone_year <- unique(df$touchstone) - - # TODO: check that touchstone year is 6 digit - can there be more digits? - ts_number <- str_as_ts_year(touchstone_year) # see R/helpers.R - - if (ts_number >= threshold) { - dplyr::filter( - df, - scenario_type == "default" - ) - } else { - df - } -} - -# Helper for removing excluded diseases post-202110 -filter_excluded_diseases_ts <- function(df, threshold = 202110) { - touchstone_year <- unique(df$touchstone) - ts_number <- str_as_ts_year(touchstone_year) - - if (ts_number <= threshold) { - filter(df, !disease %in% exclude_dis) - } else { - df - } -} - -# Identify duplicates -flag_duplicates <- function(df, key_cols) { - df <- dplyr::add_count( - df, - dplyr::across(dplyr::all_of(key_cols)), - name = "n_key" - ) - - filter(df, n_key > 1) -} - -# Identify rows where deaths_averted went from non-NA to NA -comparison_prev <- function(df, prev_dat, outcome) { - prev_df <- select(prev_data, all_of(key_cols), all_of(outcome)) - prev_df <- rename(prev_df, outcome_prev = !!sym(outcome)) - - current_df <- select(current_df, all_of(key_cols), all_of(outcome)) - current_df <- rename(current_df, outcome_cur = !!sym(outcome)) - - result <- inner_join(prev_df, current_df, by = key_cols) - result <- filter(result, !is.na(outcome_prev) & is.na(outcome_cur)) - - result -} - -# Explore significant changes in key outcomes (i.e. deaths/dalys) -generate_diffs <- function(prev_df, curr_df, interest_cols, key_cols) { - #fix for erroneous duplicated YF data in 201910 dataset - if (identical(pars$touchstone_old, TOUCHSTONE_OLD)) { - prev_df <- filter( - prev_df, - !(disease == "YF" & support_type == "other" & coverage == 0) - ) - } - - # Fix for multiple campaigns per year (i.e. not true duplicates) - # only applicable for 2019 true non-duplicates. - prev_df <- add_campaign_id(prev_df, key_cols) - curr_df <- add_campaign_id(curr_df, key_cols) - - diff_keys <- c(key_cols, "campaign_id") - cols_needed <- unique(c(diff_keys, interest_cols)) - - diff <- diffdf::diffdf( - prev_df[, cols_needed], - curr_df[, cols_needed], - keys = diff_keys - ) - - changes <- setNames( - lapply(interest_cols, function(v) { - nm <- paste0("VarDiff_", v) - if (nm %in% names(diff)) diff[[nm]] else NULL - }), - interest_cols - ) - - changes -} - -# Generate IQR for key outcomes - for threshold of "significant" -gen_national_iqr <- function( - df, - group_cols, - value_cols, - prefix = "national_iqr_" -) { - df <- group_by(df, across(all_of(group_cols))) - df <- summarise( - df, - across( - all_of(value_cols), - \(x) IQR(x, na.rm = TRUE), - .names = "{prefix}{.col}" - ), - .groups = "drop" - ) -} - -# TODO: I don't like how this looks - this should probably be a simpler -# functional that maps over a list in a separate function -## Flag significant changes -flag_large_diffs <- function( - changes_list, - iqr_df, - variable, - group_cols, - threshold -) { - iqr_col <- paste0("national_iqr_", variable) - - # returns a list so that the function can accept multiple variables - lapply( - changes_list[[variable]], - temp_fn, - iqr_df, - variable, - group_cols, - threshold - ) -} - -temp_fn <- function(df, iqr_df, variable, group_cols, threshold) { - mutate( - df, - diff = COMPARE - BASE - ) %>% - left_join( - iqr_df %>% select(all_of(group_cols), all_of(iqr_col)), - by = group_cols - ) %>% - mutate( - flag = abs(diff) > threshold * .data[[iqr_col]] & .data[[iqr_col]] > 0 - ) %>% - filter(flag) %>% - select( - country, - country_name, - year, - vaccine, - modelling_group, - activity_type, - BASE, - COMPARE, - diff - ) %>% - rename(!!as.character(old) := BASE, !!as.character(new) := COMPARE) %>% - arrange(desc(diff)) -} - -### Generate combined df -gen_combined_df <- function(prev_dat, df2, interest_cols, key_cols) { - prev_df <- prev_dat[, interest_cols] - cur_df <- df2[, interest_cols] - - combined <- full_join( - prev_df, - cur_df, - by = key_cols, - suffix = c("_old", "_new") - ) - - combined <- combined %>% - select( - country, - country_name, - disease, - vaccine, - activity_type, - year, - modelling_group, - deaths_averted_old, - deaths_averted_new, - dalys_averted_old, - dalys_averted_new - ) - return(combined) -} - -### Subregional v national estimate comparison -compare_national_to_subregional <- function( - df, - outcome, - activity_filter, - threshold -) { - df <- filter(df, activity_type == activity_filter) - df <- select(df, all_of(key_cols), subregion, !!outcome) - - results <- purrr::map_dfr(outcome, function(otc) { - subregional_summary <- - group_by(df, subregion, disease, activity_type) - subregional_summary <- summarise( - subregional_summary, - subregional_mean = mean(.data[[otc]], na.rm = TRUE), - subregional_iqr = IQR(.data[[otc]], na.rm = TRUE), - .groups = "drop" - ) - - national_summary <- - select(df, all_of(key_cols), subregion, !!outcome) - national_summary <- rename(national_summary, national_value = !!outcome) - - comparison <- left_join( - national_summary, - subregional_summary, - by = c("subregion", "disease") - ) - comparison <- mutate( - comparison, - outcome = outcome, - difference = national_value - subregional_mean, - iqr_score = abs(difference) / subregional_iqr - ) - - dynamic_threshold <- quantile(comparison$iqr_score, 0.99, na.rm = TRUE) - - comparison <- mutate( - comparison, - flag_iqr = iqr_score > dynamic_threshold & subregional_iqr > 0 - ) - comparison <- filter(comparison, flag_iqr) - comparison <- select( - comparison, - country_name, - vaccine, - year, - modelling_group, - national_value, - subregional_mean, - subregional_iqr, - difference, - iqr_score - ) - comparison <- arrange(comparison, desc(iqr_score)) - - comparison - }) - - results -} - -### Modelling group variations -save_outputs <- function() { - saveRDS( - round_numeric( - missing_in_current %>% - select(all_of(c( - "country_name", - "vaccine", - "activity_type", - "year", - "modelling_group" - ))) - ), - "outputs/missing_in_current.rds" - ) - saveRDS(round_numeric(missing_deaths), "outputs/missing_deaths.rds") - saveRDS(round_numeric(missing_dalys), "outputs/missing_dalys.rds") - saveRDS(round_numeric(changes_deaths), "outputs/changes_deaths.rds") - saveRDS(round_numeric(changes_dalys), "outputs/changes_dalys.rds") - saveRDS( - round_numeric(subregional_flags_deaths_camp), - "outputs/subregional_flags_deaths_camp.rds" - ) - saveRDS( - round_numeric(subregional_flags_deaths_rout), - "outputs/subregional_flags_deaths_rout.rds" - ) - saveRDS( - round_numeric(subregional_flags_dalys_camp), - "outputs/subregional_flags_dalys_camp.rds" - ) - saveRDS( - round_numeric(subregional_flags_dalys_rout), - "outputs/subregional_flags_dalys_rout.rds" - ) -} From de1eda658e8402d12a0624e716f797ecac0fdeed Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 20 Apr 2026 16:55:14 +0100 Subject: [PATCH 06/29] Add checks and docs for pressure testing fns --- R/fn_pressure_testing.R | 683 ++++++++++++++++++++++++++++++---------- 1 file changed, 523 insertions(+), 160 deletions(-) diff --git a/R/fn_pressure_testing.R b/R/fn_pressure_testing.R index 140cc79..9f25309 100644 --- a/R/fn_pressure_testing.R +++ b/R/fn_pressure_testing.R @@ -1,14 +1,50 @@ -#' Fix for scenario_type variable being included from 202310 onwards +#' Filter data for touchstones or diseases +#' +#' @name pres_test_filter_data +#' @rdname pres_test_filter_data +#' +#' @description +#' A pair of helper functions allowing filtering out of recent touchstone values +#' and excluded diseases. +#' +#' @param df A `` holding impact data. This data.frame is not +#' checked for contents +#' +#' @param threshold A six-digit number that is checked as a valid touchstone +#' identifier (YYYYMM format) using [validate_ts_year()]. #' #' @keywords pressure_testing #' +#' @return A filtered ``. +#' +#' - `filter_recent_ts()` returns `df` with rows where the touchstone condition +#' is not met excluded. +#' +#' - `filter_excluded_diseases_ts()` returns `df` with rows where rows relating +#' to the [EXCLUDED_DISEASES], when the touchstone year in `df` is less than the +#' `threshold`, excluded. +#' +#' - `filter_duplicates()` returns `df` with duplicated combinations of +#' `key_cols` removed. +#' +#' - `filter_invalid_trajectories()` returns `df` with bad outcome trajectories +#' (`NA` to non-`NA`) removed. +#' #' @export filter_recent_ts <- function(df, threshold = 202310) { - touchstone_year <- unique(df$touchstone) + checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 1L) + checkmate::assert_names( + names(df), + must.include = "touchstone" + ) + threshold <- validate_ts_year(threshold) # apply same rule as data ts year - # TODO: check that touchstone year is 6 digit - can there be more digits? - ts_number <- str_as_ts_year(touchstone_year) # see R/helpers.R + touchstone_year <- unique(df[["touchstone"]]) + ts_number <- validate_ts_year(touchstone_year) # see R/helpers.R + + # NOTE: consider converting to Date and checking - numeric comparison + # works okay for now if (ts_number >= threshold) { dplyr::filter( df, @@ -19,12 +55,20 @@ filter_recent_ts <- function(df, threshold = 202310) { } } -#' Helper for removing excluded diseases post-202110 +#' @name pres_test_filter_data #' #' @export filter_excluded_diseases_ts <- function(df, threshold = 202110) { + checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 1L) + checkmate::assert_names( + names(df), + must.include = "touchstone" + ) + + threshold <- validate_ts_year(threshold) + touchstone_year <- unique(df$touchstone) - ts_number <- str_as_ts_year(touchstone_year) + ts_number <- validate_ts_year(touchstone_year) if (ts_number <= threshold) { dplyr::filter(df, !.data$disease %in% EXCLUDED_DISEASES) @@ -33,10 +77,27 @@ filter_excluded_diseases_ts <- function(df, threshold = 202110) { } } -#' Identify duplicates +#' @name pres_test_filter_data +#' +#' @param key_cols Key columns in `df` to check for duplicates. #' #' @export -flag_duplicates <- function(df, key_cols) { +filter_duplicates <- function(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) { + checkmate::assert_data_frame(df, min.cols = 1L, min.rows = 1L) + checkmate::assert_character(key_cols) + + has_cols <- checkmate::test_names( + colnames(df), + must.include = key_cols + ) + if (!has_cols) { + missing_cols <- setdiff(colnames(df), key_cols) # nolint used in cli + cli::cli_abort( + "Expected {.code df} to have columns {.str {key_cols}}, but columns \ + {.str {.strong {missing_cols}}} were missing!" + ) + } + df <- dplyr::add_count( df, dplyr::across(dplyr::all_of(key_cols)), @@ -46,46 +107,136 @@ flag_duplicates <- function(df, key_cols) { dplyr::filter(df, .data$n_key > 1) } -#' Identify rows where deaths_averted went from non-NA to NA +#' @name pres_test_filter_data +#' +#' @param prev_data A `` holding data from a previous touchstone for +#' the same scenarios as `df`. +#' +#' @param outcome A string giving the outcome of interest; may be one of +#' `"deaths_averted"` or `"dalys_averted"`. #' #' @export -comparison_prev <- function(df, prev_data, outcome) { +filter_invalid_trajectories <- function( + df, + prev_data, + outcome = c("deaths_averted", "dalys_averted") +) { + checkmate::assert_data_frame(df, min.cols = 1L, min.rows = 1L) + + # TODO: can we assume prev_data is at least the size of df? + checkmate::assert_data_frame( + prev_data, + min.cols = ncol(df), + min.rows = nrow(df) + ) + + outcome <- rlang::arg_match(outcome) + + has_cols <- checkmate::test_names( + colnames(df), + must.include = c(COLNAMES_KEY_PRESSURE_TEST, outcome) + ) + if (!has_cols) { + missing_cols <- setdiff(colnames(df), COLNAMES_KEY_PRESSURE_TEST) # nolint + cli::cli_abort( + "Expected {.code df} to have columns \ + {.str {COLNAMES_KEY_PRESSURE_TEST}}, but columns \ + {.str {.strong {missing_cols}}} were missing!" + ) + } + + has_cols <- checkmate::test_names( + colnames(prev_data), + must.include = c(COLNAMES_KEY_PRESSURE_TEST, outcome) + ) + if (!has_cols) { + missing_cols <- setdiff(colnames(prev_data), COLNAMES_KEY_PRESSURE_TEST) + cli::cli_abort( + "Expected {.code prev_data} to have columns \ + {.str {COLNAMES_KEY_PRESSURE_TEST}}, but columns \ + {.str {.strong {missing_cols}}} were missing!" + ) + } + prev_df <- dplyr::select( prev_data, - dplyr::all_of(key_cols), + dplyr::all_of(COLNAMES_KEY_PRESSURE_TEST), dplyr::all_of(outcome) ) prev_df <- dplyr::rename(prev_df, outcome_prev = {{ outcome }}) current_df <- dplyr::select( df, - dplyr::all_of(key_cols), + dplyr::all_of(COLNAMES_KEY_PRESSURE_TEST), dplyr::all_of(outcome) ) current_df <- dplyr::rename(current_df, outcome_cur = {{ outcome }}) - result <- dplyr::inner_join(prev_df, current_df, by = key_cols) - # `,` replaces `&` for dplyr syntax - result <- dplyr::filter(result, !is.na(outcome_prev), is.na(outcome_cur)) + result <- dplyr::inner_join( + prev_df, + current_df, + by = COLNAMES_KEY_PRESSURE_TEST + ) - result + # `,` replaces `&` for dplyr syntax + dplyr::filter( + result, + !is.na(.data$outcome_prev), + is.na(.data$outcome_cur) + ) } #' Explore significant changes in deaths and DALYs #' +#' @param prev_df A `` of impact estimates from the previous +#' touchstone. +#' +#' @param curr_df A `` of impact estimates for the current +#' touchstone. +#' +#' @param interest_cols A character vector of columns to check for differences. +#' Defaults to [COLNAMES_INTEREST_PRESSURE_TEST]. +#' +#' @param key_cols A character vector of columns to use when assigning campaign +#' identifiers. Passed to [add_campaign_id()], defaults to +#' [COLNAMES_KEY_PRESSURE_TEST]. +#' +#' @param touchstone A six character string that can be converted to a six digit +#' numeric giving a touchstone identifier in `YYYYMM` format. +#' +#' @return A list of data.frames of differences between `prev_df` and `curr_df`, +#' with one list element per element of `interest_cols`. +#' #' @keywords pressure_testing #' #' @export generate_diffs <- function( prev_df, curr_df, - interest_cols, - key_cols, - touchstone = TOUCHSTONE_OLD + interest_cols = COLNAMES_INTEREST_PRESSURE_TEST, + key_cols = COLNAMES_KEY_PRESSURE_TEST, + touchstone = DEF_TOUCHSTONE_OLD ) { - # TODO: replace use of `pars$touchstone_old` with arg `touchstone` - #fix for erroneous duplicated YF data in 201910 dataset - if (identical(touchstone, TOUCHSTONE_OLD)) { + checkmate::assert_data_frame(prev_df, min.rows = 1L, min.cols = 1L) + checkmate::assert_data_frame(curr_df, min.rows = 1L, min.cols = 1L) + + checkmate::assert_character(interest_cols, min.len = 1L) + checkmate::assert_character(key_cols, min.len = 1L) + + # check interest cols in dfs. key cols are check in `add_campaign_id` + checkmate::assert_names( + colnames(prev_df), + interest_cols + ) + checkmate::assert_names( + colnames(curr_df), + interest_cols + ) + + touchstone <- validate_ts_year(touchstone) + + # fix for erroneous duplicated YF data in 201910 dataset + if (touchstone == DEF_TOUCHSTONE_OLD) { prev_df <- dplyr::filter( prev_df, !(.data$disease == "YF" & @@ -100,9 +251,9 @@ generate_diffs <- function( curr_df <- add_campaign_id(curr_df, key_cols) diff_keys <- c(key_cols, "campaign_id") - cols_needed <- unique(c(diff_keys, interest_cols)) + cols_needed <- union(diff_keys, interest_cols) - diff <- diffdf::diffdf( + df_diff <- diffdf::diffdf( prev_df[, cols_needed], curr_df[, cols_needed], keys = diff_keys @@ -111,7 +262,7 @@ generate_diffs <- function( changes <- stats::setNames( lapply(interest_cols, function(v) { nm <- glue::glue("VarDiff_{v}") - if (nm %in% names(diff)) diff[[nm]] else NULL + if (nm %in% names(df_diff)) df_diff[[nm]] else NULL }), interest_cols ) @@ -123,28 +274,89 @@ generate_diffs <- function( #' #' @keywords pressure_testing #' +#' @param df A data.frame of impact estimates. +#' +#' @param group_cols A character vector of grouping columns. Defaults to +#' "country", "vaccine", "activity_type". +#' +#' @param value_cols A character vector of value columns. Defaults to +#' "deaths_averted" and "dalys_averted". +#' +#' @param prefix A string for the prefix applied to every IQR summary column. +#' Defaults to "national_iqr". +#' +#' @return A `` with the inter-quartile range of the columns +#' in `value_cols`, with the column name constructed as `{prefix}_{value_col}` +#' using string interpolation. +#' #' @export gen_national_iqr <- function( df, - group_cols, - value_cols, - prefix = "national_iqr_" + group_cols = c("country", "vaccine", "activity_type"), + value_cols = c("deaths_averted", "dalys_averted"), + prefix = "national_iqr" ) { + checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 1L) + checkmate::assert_character(group_cols, min.len = 1L, any.missing = FALSE) + + # NOTE: restricting value columns to deaths and dalys averted + value_cols <- rlang::arg_match( + value_cols, + c("deaths_averted", "dalys_averted"), + multiple = TRUE + ) + + checkmate::assert_string(prefix) + + checkmate::assert_names( + colnames(df), + must.include = union(group_cols, value_cols) + ) + df <- dplyr::group_by(df, dplyr::across(dplyr::all_of(group_cols))) df <- dplyr::summarise( df, dplyr::across( dplyr::all_of(value_cols), function(x) { - IQR(x, na.rm = TRUE) + stats::IQR(x, na.rm = TRUE) }, - .names = "{prefix}{.col}" + .names = "{prefix}_{.col}" ), .groups = "drop" ) } -#' Flag significant changes +#' Flag significant changes in impact estimates +#' +#' @description Calculates and flags whether the difference in impact estimates +#' between touchstones is greater than expected. A row is flagged if the +#' difference is greater than `threshold` \eqn{\times} the inter-quartile range +#' for cases where the IQR is greater than zero. +#' +#' @param changes_list A list of data.frames with one element per variable of +#' interest (see `variable`). Usually generated using [generate_diffs()]. +#' +#' @param iqr_df A data.frame of inter-quartile differences generated using +#' [gen_national_iqr()]. +#' +#' @param variable A string specifying the variable of interest. Must be one of +#' "deaths_averted" and "dalys_averted", and must be present as a name and +#' element of `changes_list`. +#' +#' @inheritParams gen_national_iqr +#' +#' @param threshold A single numeric value for the IQR multiplier. Defaults to +#' 100. +#' +#' @param touchstone_old The previous touchstone identifier. Defaults to +#' [DEF_TOUCHSTONE_OLD_OLD]. +#' +#' @param touchstone_new The new touchstone identifier. Defaults to +#' [DEF_TOUCHSTONE_NEW]. +#' +#' @return A filtered data.frame of differences in impact estimates flagged +#' as too large. Rows with differences within tolerance are removed. #' #' @keywords pressure_testing #' @@ -153,16 +365,46 @@ flag_large_diffs <- function( changes_list, iqr_df, variable = c("deaths_averted", "dalys_averted"), - group_cols, - threshold + group_cols = c("country", "vaccine", "activity_type"), + threshold = 100, + touchstone_old = DEF_TOUCHSTONE_OLD_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW ) { - # TODO: input checking + checkmate::assert_list(changes_list, "data.frame") + checkmate::assert_data_frame(iqr_df, min.rows = 1L, min.cols = 1L) + variable <- rlang::arg_match(variable) + checkmate::assert_character(group_cols, min.len = 1L, any.missing = FALSE) + + # TODO: check what a sensible upper limit might be + checkmate::assert_number(threshold, lower = 1.0, finite = TRUE) + + touchstone_old <- validate_ts_year(touchstone_old) + touchstone_new <- validate_ts_year(touchstone_new) + + # cross checking + has_var <- variable %in% names(changes_list) + if (!has_var) { + cli::cli_abort( + "Expected list {.code changes_list} to have an element with the name \ + {.str {variable}}, but it does not." + ) + } + df_compare <- changes_list[[variable]] + + checkmate::assert_names( + colnames(df_compare), + must.include = group_cols + ) + checkmate::assert_names( + colnames(iqr_df), + must.include = group_cols + ) iqr_col <- glue::glue("national_iqr_{variable}") - df <- dplyr::mutate( - changes_list[[variable]], + df_compare <- dplyr::mutate( + df_compare, diff = .data$COMPARE - .data$BASE ) @@ -172,18 +414,18 @@ flag_large_diffs <- function( dplyr::all_of(iqr_col) ) - df <- left_join( - df, + df_compare <- dplyr::left_join( + df_compare, iqr_df, by = group_cols ) - df <- dplyr::mutate( - df, + df_compare <- dplyr::mutate( + df_compare, flag = abs(.data$diff) > threshold * .data[[iqr_col]] & .data[[iqr_col]] > 0 ) - df <- dplyr::filter(df, .data$flag) + df_compare <- dplyr::filter(df_compare, .data$flag) cols_to_select <- c( "country", @@ -197,29 +439,59 @@ flag_large_diffs <- function( "diff" ) - df <- dplyr::select( - df, + df_compare <- dplyr::select( + df_compare, {{ cols_to_select }} ) - # TODO: replace `old` and `new` with defined objs --- see scratch.R - # unsure why this syntax was used - df <- dplyr::rename( - df, - !!as.character(old) := BASE, - !!as.character(new) := COMPARE + rename_lookup <- c("BASE", "COMPARE") + names(rename_lookup) <- c( + as.character(touchstone_old), + as.character(touchstone_new) + ) + df_compare <- dplyr::rename( + df_compare, + rename_lookup ) - dplyr::arrange(df, dplyr::desc(diff)) + dplyr::arrange(df_compare, dplyr::desc(diff)) } -#' Generate combined df +#' Combine and align data from two touchstones +#' +#' @description +#' Generates a full join of two data.frames, selecting for columns of interest. +#' +#' @param prev_dat A data.frame of impact estimates corresponding to an earlier +#' touchstone. +#' +#' @param df2 A data.frame of impact estimates corresponding to a more recent +#' touchstone. +#' +#' @param interest_cols A character vector of columns of interest. Defaults to +#' [COLNAMES_INTEREST_PRESSURE_TEST]. +#' +#' @param key_cols A character vector of columns of interest. Defaults to +#' [COLNAMES_KEY_PRESSURE_TEST]. +#' +#' @return A data.frame which is a full join of `prev_dat` and `df2`. Columns +#' are disambiguated with the suffixes `"_old"` and `"_new"`. #' #' @keywords pressure_testing #' #' @export -gen_combined_df <- function(prev_dat, df2, interest_cols, key_cols) { - # TODO: input checks +gen_combined_df <- function( + prev_dat, + df2, + interest_cols = COLNAMES_INTEREST_PRESSURE_TEST, + key_cols = COLNAMES_KEY_PRESSURE_TEST +) { + checkmate::assert_data_frame( + prev_dat, + min.cols = 1L, + min.rows = 1L + ) + # TODO: df2 needs a better name prev_df <- dplyr::select(prev_dat, {{ interest_cols }}) cur_df <- dplyr::select(df2, {{ interest_cols }}) @@ -231,131 +503,222 @@ gen_combined_df <- function(prev_dat, df2, interest_cols, key_cols) { suffix = c("_old", "_new") ) + cols_to_select <- c( + "country", + "country_name", + "disease", + "vaccine", + "activity_type", + "year", + "modelling_group", + "deaths_averted_old", + "deaths_averted_new", + "dalys_averted_old", + "dalys_averted_new" + ) + dplyr::select( combined, - country, - country_name, - disease, - vaccine, - activity_type, - year, - modelling_group, - deaths_averted_old, - deaths_averted_new, - dalys_averted_old, - dalys_averted_new + {{ cols_to_select }} ) } -### Subregional v national estimate comparison -compare_national_to_subregional <- function( +#' Compare sub-regional and national estimates +#' +#' @param df A data.frame with sub-region level data on vaccination impact +#' outcomes. +#' +#' @param outcome A string for the outcome of interest. May be one of +#' `"deaths_averted_rate"` or `"dalys_averted_rate"`. +#' +#' @param activity_filter A string for the type of vaccination activity. May be +#' one of `"campaign"` or `"routine"`. +#' +#' @return A data.frame of sub-regional vaccination impact estimates where the +#' impact is considered to be outside the tolerance limit. +#' +#' @keywords pressure_testing +#' +#' @export +compare_natl_subreg <- function( df, - outcome, - activity_filter, - threshold + outcome = c("deaths_averted_rate", "dalys_averted_rate"), + activity_filter = c("campaign", "routine") ) { - df <- dplyr::filter(df, activity_type == activity_filter) - df <- dplyr::select(df, dplyr::all_of(key_cols), subregion, !!outcome) - - results <- purrr::map_dfr(outcome, function(otc) { - subregional_summary <- - dplyr::group_by(df, subregion, disease, activity_type) - - subregional_summary <- dplyr::summarise( - subregional_summary, - subregional_mean = mean(.data[[otc]], na.rm = TRUE), - subregional_iqr = IQR(.data[[otc]], na.rm = TRUE), - .groups = "drop" - ) + df <- dplyr::filter(df, .data$activity_type == activity_filter) + df <- dplyr::select( + df, + dplyr::all_of(COLNAMES_KEY_PRESSURE_TEST), + "subregion", + !!outcome + ) - national_summary <- - dplyr::select(df, dplyr::all_of(key_cols), subregion, !!outcome) - national_summary <- dplyr::rename( - national_summary, - national_value = !!outcome - ) + # first get national summary + national_summary <- dplyr::select( + df, + dplyr::all_of(COLNAMES_KEY_PRESSURE_TEST), + .data$subregion, + !!outcome + ) + national_summary <- dplyr::rename( + national_summary, + national_value = !!outcome + ) - comparison <- dplyr::left_join( - national_summary, - subregional_summary, - by = c("subregion", "disease") - ) - comparison <- dplyr::mutate( - comparison, - outcome = outcome, - difference = .data$national_value - .data$subregional_mean, - iqr_score = abs(.data$difference) / .data$subregional_iqr - ) + # next get sub-regional summary + subregional_summary <- + dplyr::group_by(df, .data$subregion, .data$disease, .data$activity_type) - dynamic_threshold <- stats::quantile( - comparison$iqr_score, - 0.99, - na.rm = TRUE - ) + subregional_summary <- dplyr::summarise( + subregional_summary, + subregional_mean = mean(.data[[outcome]], na.rm = TRUE), + subregional_iqr = IQR(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) - comparison <- dplyr::mutate( - comparison, - flag_iqr = .data$iqr_score > dynamic_threshold & .data$subregional_iqr > 0 - ) - comparison <- dplyr::filter(comparison, .data$flag_iqr) - comparison <- dplyr::select( - comparison, - country_name, - vaccine, - year, - modelling_group, - national_value, - subregional_mean, - subregional_iqr, - difference, - iqr_score - ) - comparison <- dplyr::arrange(comparison, dplyr::desc(.data$iqr_score)) + comparison <- dplyr::left_join( + national_summary, + subregional_summary, + by = c("subregion", "disease") + ) + comparison <- dplyr::mutate( + comparison, + outcome = outcome, + difference = .data$national_value - .data$subregional_mean, + iqr_score = abs(.data$difference) / .data$subregional_iqr + ) - comparison - }) + dynamic_threshold <- stats::quantile( + comparison$iqr_score, + 0.99, + na.rm = TRUE + ) - results + comparison <- dplyr::mutate( + comparison, + flag_iqr = .data$iqr_score > dynamic_threshold & .data$subregional_iqr > 0 + ) + comparison <- dplyr::filter(comparison, .data$flag_iqr) + + cols_to_select <- c( + "country_name", + "vaccine", + "year", + "modelling_group", + "national_value", + "subregional_mean", + "subregional_iqr", + "difference", + "iqr_score" + ) + comparison <- dplyr::select(comparison, {{ cols_to_select }}) + comparison <- dplyr::arrange(comparison, dplyr::desc(.data$iqr_score)) + + comparison } -# TODO: reconsider function name, add explicit arguments -#' Modelling group variations +#' Save pressure-testing diagnostics to local file +#' +#' @description +#' Save pressure-testing diagnostics data.frames to local compressed files in +#' the `.Rds` format. Input data.frames are generated by other package functions +#' and are not checked here. +#' +#' @param missing_in_current A data.frame. +#' +#' @param missing_deaths A data.frame that is the output of +#' [filter_invalid_trajectories()] with the outcome `"deaths_averted"`. +#' +#' @param missing_dalys A data.frame that is the output of +#' [filter_invalid_trajectories()] with the outcome `"dalys_averted"`. +#' +#' @param changes_deaths A data.frame that is the output of [flag_large_diffs()] +#' with the outcome `"deaths_averted"`. +#' +#' @param changes_dalys A data.frame that is the output of [flag_large_diffs()] +#' with the outcome `"dalys_averted"`. +#' +#' @param subregional_flags_deaths_camp A data.frame that is the output of +#' [compare_natl_subreg()] with the outcome `"deaths_averted_rate"` for the +#' `"campaign"` activity type. +#' +#' @param subregional_flags_deaths_rout A data.frame that is the output of +#' [compare_natl_subreg()] with the outcome `"deaths_averted_rate"` for the +#' `"routine"` activity type. +#' +#' @param subregional_flags_dalys_camp A data.frame that is the output of +#' [compare_natl_subreg()] with the outcome `"dalys_averted_rate"` for the +#' `"campaign"` activity type. +#' +#' @param subregional_flags_dalys_rout A data.frame that is the output of +#' [compare_natl_subreg()] with the outcome `"dalys_averted_rate"` for the +#' `"campaign"` activity type. +#' +#' @return None. Called for the convenience side-effect of saving data.frames as +#' `.Rds` format. #' #' @keywords pressure_testing #' #' @export -save_outputs <- function() { - saveRDS( - round_numeric( - missing_in_current %>% - dplyr::select(dplyr::all_of(c( - "country_name", - "vaccine", - "activity_type", - "year", - "modelling_group" - ))) - ), - "outputs/missing_in_current.rds" - ) - saveRDS(round_numeric(missing_deaths), "outputs/missing_deaths.rds") - saveRDS(round_numeric(missing_dalys), "outputs/missing_dalys.rds") - saveRDS(round_numeric(changes_deaths), "outputs/changes_deaths.rds") - saveRDS(round_numeric(changes_dalys), "outputs/changes_dalys.rds") - saveRDS( - round_numeric(subregional_flags_deaths_camp), - "outputs/subregional_flags_deaths_camp.rds" - ) - saveRDS( - round_numeric(subregional_flags_deaths_rout), - "outputs/subregional_flags_deaths_rout.rds" - ) - saveRDS( - round_numeric(subregional_flags_dalys_camp), - "outputs/subregional_flags_dalys_camp.rds" - ) - saveRDS( - round_numeric(subregional_flags_dalys_rout), - "outputs/subregional_flags_dalys_rout.rds" +save_outputs <- function( + missing_in_current, + missing_deaths, + missing_dalys, + changes_deaths, + changes_dalys, + subregional_flags_deaths_camp, + subregional_flags_deaths_rout, + subregional_flags_dalys_camp, + subregional_flags_dalys_rout, + output_dir = here::here("outputs") +) { + # NOTE: not checking most input args as these are generated from other pkg fns + + output_dir_exists <- dir.exists(output_dir) + if (!output_dir_exists) { + cli::cli_abort( + "Expected output directory {.arg {output_dir}} but it does not exist!" + ) + } + + # NOTE: consider writing to agnostic format e.g. CSV + missing_in_current <- dplyr::select( + missing_in_current, + {{ colnames_df_missing_cols }} + ) + + filenames <- c( + "missing_in_current", + "missing_deaths", + "missing_dalys", + "changes_deaths", + "changes_dalys", + "subregional_flags_deaths_camp", + "subregional_flags_deaths_rout", + "subregional_flags_dalys_camp", + "subregional_flags_dalys_rout" + ) + + df_list <- list( + missing_in_current, + missing_deaths, + missing_dalys, + changes_deaths, + changes_dalys, + subregional_flags_deaths_camp, + subregional_flags_deaths_rout, + subregional_flags_dalys_camp, + subregional_flags_dalys_rout + ) + + Map( + df_list, + filenames, + f = function(df, name) { + saveRDS( + round_numeric(df), + file.path(output_dir, glue::glue("{name}.Rds")) + ) + } ) } From 46d3d974131d34d115a658d1cfc87e49f9cbdd63 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 20 Apr 2026 16:55:25 +0100 Subject: [PATCH 07/29] Add pkg constants --- R/constants.R | 58 ++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 55 insertions(+), 3 deletions(-) diff --git a/R/constants.R b/R/constants.R index 20ae152..adb8175 100644 --- a/R/constants.R +++ b/R/constants.R @@ -47,14 +47,66 @@ colnames_plot_demog_compare <- c( "value_millions" ) +#' @name constants +colnames_df_missing_cols <- c( + "country_name", + "vaccine", + "activity_type", + "year", + "modelling_group" +) + +#' @name constants +COLNAMES_KEY_PRESSURE_TEST <- c( + "country", + "country_name", + "vaccine", + "activity_type", + "year", + "disease", + "modelling_group" +) + +#' @name constants +COLNAMES_INTEREST_PRESSURE_TEST <- union( + COLNAMES_KEY_PRESSURE_TEST, + c( + "fvps", + "target_population", + "coverage", + "deaths_averted", + "dalys_averted", + "deaths_averted_rate", + "dalys_averted_rate" + ) +) + #' @name constants EXCLUDED_DISEASES <- c("Hib", "PCV", "Rota", "JE") #' @name constants -TOUCHSTONE_OLD <- "201910" +N_TS_MIN_CHARS <- 6L + +#' @name constants +N_TS_YEAR_CHARS <- 4L + +#' @name constants +MIN_TS_YEAR <- 2000 + +#' @name constants +MAX_TS_YEAR <- 2100 + +#' @name constants +MIN_TS_MONTH <- 1 + +#' @name constants +MAX_TS_MONTH <- 12 + +#' @name constants +DEF_TOUCHSTONE_OLD <- "201910" #' @name constants -TOUCHSTONE_NEW <- "202310" +DEF_TOUCHSTONE_NEW <- "202310" #' @name constants -TOUCHSTONE_OLD_OLD <- "202110" +DEF_TOUCHSTONE_OLD_OLD <- "202110" From 63e5871eb95be0d2e787e0a92f89dfc74f75977f Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 20 Apr 2026 16:55:48 +0100 Subject: [PATCH 08/29] Add pkg helpers --- R/fn_helpers.R | 135 +++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 125 insertions(+), 10 deletions(-) diff --git a/R/fn_helpers.R b/R/fn_helpers.R index d065a9e..5159361 100644 --- a/R/fn_helpers.R +++ b/R/fn_helpers.R @@ -36,12 +36,34 @@ make_novax_scenario <- function(disease) { ) } +#' Adaptively round numerics +#' +#' @param x A numeric vector. +#' +#' @param large_threshold A single number for the threshold over which numbers +#' are to be considered 'large'. +#' +#' @param small_sigfig A single number for the number of significant digits for +#' 'small' numbers. +#' +#' @param large_digits A single number for the number of places to which 'large' +#' numbers should be rounded. +#' +#' @return `x` rounded to either `large_digits` or to `small_sigfig`. +#' +#' @keywords internal adaptive_round <- function( x, large_threshold = 1, small_sigfig = 2, large_digits = 1 ) { + # basic checks for numeric + checkmate::assert_numeric(x, finite = TRUE, any.missing = FALSE) + checkmate::assert_number(large_threshold) + checkmate::assert_count(small_sigfig, positive = TRUE) + checkmate::assert_count(large_digits, positive = TRUE) + ifelse( abs(x) >= large_threshold, round(x, large_digits), @@ -49,21 +71,114 @@ adaptive_round <- function( ) } +#' Round numeric columns of a data.frame +#' +#' @param df A data.frame. +#' +#' @keywords internal round_numeric <- function(df) { - df %>% - mutate(across( - where(is.numeric) & !matches("year", ignore.case = TRUE), - ~ adaptive_round(.x) - )) + checkmate::assert_data_frame( + df, + min.rows = 1L, + min.cols = 1L + ) + + dplyr::mutate( + df, + dplyr::across( + .cols = dplyr::where(is.numeric) & !matches("year", ignore.case = TRUE), + .fns = adaptive_round + ) + ) } -str_as_ts_year <- function(x) { - as.numeric(substr(x, 1, 6)) +#' Check and return touchstone year-month +#' +#' @param x A string for the touchstone identifier. +#' +#' @return The first 6 characters of `x` converted to a numeric. Also has side +#' effects of erroring if conditions on `x` are not met. +#' +#' @keywords internal +validate_ts_year <- function(x) { + has_n_chars <- checkmate::test_string( + x, + min.chars = N_TS_MIN_CHARS + ) + if (!has_n_chars) { + n_chars <- nchars(x) + cli::cli_abort( + "Touchstone year string should have at least {N_TS_MIN_CHARS}, but got \ + {n_chars} characters." + ) + } + + inferred_year <- as.numeric(substr(x, 1, N_TS_YEAR_CHARS)) + is_good_year <- checkmate::test_number( + inferred_year, + lower = MIN_TS_YEAR, + upper = MAX_TS_YEAR, + finite = TRUE + ) + + if (!is_good_year) { + cli::cli_abort( + "Touchstone year string has an inferred year of \ + {.strong {inferred_year}} but expected an year in the range \ + [{MIN_TS_YEAR}, {MAX_TS_YEAR}]." + ) + } + + inferred_month <- as.numeric( + substr(x, N_TS_YEAR_CHARS + 1, N_TS_YEAR_CHARS + 2) + ) + is_good_month <- checkmate::test_number( + inferred_month, + lower = MIN_TS_MONTH, + upper = MAX_TS_MONTH, + finite = TRUE + ) + + if (!is_good_month) { + cli::cli_abort( + "Touchstone month string has an inferred month of \ + {.strong {inferred_month}} but expected an month in the range \ + [{MIN_TS_MONTH}, {MAX_TS_MONTH}]." + ) + } + + # return year-month as numeric + substr(x, 1, N_TS_MIN_CHARS) } +#' Add campaign id to dataframe +#' +#' @param df A data.frame. +#' +#' @param key_cols A character vector of columns in `df` by which the data are +#' to be grouped. +#' +#' @return `df` with a campaign identifier as a numeric. +#' +#' @keywords internal add_campaign_id <- function(df, key_cols) { - df <- group_by(df, across(all_of(key_cols))) - df <- mutate(df, campaign_id = row_number()) + checkmate::assert_data_frame(df) + checkmate::assert_character(key_cols, any.missing = FALSE) + + has_cols <- checkmate::test_names( + names(df), + must.include = key_cols + ) + if (!has_cols) { + missing_cols <- setdiff(colnames(df), key_cols) + cli::cli_abort( + "Expected {.code df} to have columns {.str {key_cols}} but columns \ + {.str {missing_cols}} are missing." + ) + } + + df <- dplyr::group_by(df, dplyr::across(dplyr::all_of(key_cols))) + df <- dplyr::mutate(df, campaign_id = dplyr::row_number()) - ungroup(df) + dplyr::ungroup(df) } From ffff8400c9308d53d06ff610aa46a64ab6733266 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 20 Apr 2026 17:05:50 +0100 Subject: [PATCH 09/29] WIP separate plot prep from plot code --- R/fn_plotting_prep_pres_test.R | 154 ++++++++++++++++++++++++++++++ R/fn_plotting_pressure_testing.R | 159 +++---------------------------- 2 files changed, 165 insertions(+), 148 deletions(-) create mode 100644 R/fn_plotting_prep_pres_test.R diff --git a/R/fn_plotting_prep_pres_test.R b/R/fn_plotting_prep_pres_test.R new file mode 100644 index 0000000..d1959dd --- /dev/null +++ b/R/fn_plotting_prep_pres_test.R @@ -0,0 +1,154 @@ +prep_plot_mod_grp_varn <- function(df2, df3, outc = "deaths") { + offset <- 1e-6 + + df2 %>% + left_join(df3, by = join_by(modelling_group, vaccine)) %>% + mutate(adj_outc = !!as.name(paste0(outc, "_averted")) + offset) %>% + group_by(vaccine) %>% + mutate(mean_outc = weighted.mean(adj_outc, fvps, na.rm = TRUE)) +} + +prep_plot_vax_gavi <- function( + df, + prev_dat = NULL, + outcome = "deaths_averted" +) { + df_cur <- df %>% + select(all_of(key_cols), !!outcome) %>% + filter(year >= 2021, year <= 2024, disease != "COVID") %>% + group_by(disease, year) %>% + summarise( + yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) %>% + mutate(dataset = as.character(new)) + + df_prev <- prev_dat %>% + select(all_of(key_cols), !!outcome) %>% + filter(year >= 2021, year <= 2024, disease != "COVID") %>% + group_by(disease, year) %>% + summarise( + yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), + .groups = "drop" + ) %>% + mutate(dataset = as.character(old)) + + df_combined <- bind_rows(df_cur, df_prev) + + df_diff <- df_cur %>% + left_join( + df_prev, + by = c("disease", "year"), + suffix = c("_curr", "_prev") + ) %>% + mutate( + yearly_outcome = yearly_outcome_curr - yearly_outcome_prev, + dataset = "Difference" + ) %>% + select(disease, year, yearly_outcome, dataset) + + df_combined <- bind_rows(df_combined, df_diff) + + df_combined$dataset <- factor( + df_combined$dataset, + levels = c(as.character(old), "Difference", as.character(new)) + ) + + df_combined +} + +prep_plot_cumul <- function(df, outcome, disease_filter) { + outcome_cols <- names(df)[str_detect(names(df), paste0("^", outcome, "_"))] + + outcome_sym <- sym(outcome) + cum_col <- paste0("cum_", outcome) + avg_col <- paste0("avg_", outcome) + + col_old <- paste0(outcome, "_old") + col_new <- paste0(outcome, "_new") + + combined2 <- df %>% + select( + country, + country_name, + disease, + vaccine, + activity_type, + year, + modelling_group, + all_of(outcome_cols) + ) %>% + pivot_longer( + cols = all_of(outcome_cols), + names_to = "touchstone", + values_to = "value" + ) %>% + mutate( + touchstone = str_remove(touchstone, paste0("^", outcome, "_")), + touchstone = recode( + touchstone, + "old" = as.character(old), + "new" = as.character(new), + .default = touchstone + ), + touchstone = factor( + touchstone, + levels = c(as.character(old), as.character(new)) + ) + ) + # Cumulative values by modelling group + df_cum <- combined2 %>% + filter(disease == disease_filter) %>% + group_by(modelling_group, touchstone) %>% + complete(year = full_seq(year, 1)) %>% + arrange(year) %>% + mutate( + first_valid = min(year[!is.na(value)]), + !!cum_col := ifelse( + year < first_valid, + NA, + cumsum(replace_na(value, 0)) + ) + ) %>% + select(-first_valid) %>% + ungroup() %>% + mutate(modelling_group = paste(modelling_group, touchstone, sep = "-")) + + # Model average + df_avg <- df_cum %>% + group_by(year, touchstone) %>% + summarise( + !!avg_col := mean(!!sym(cum_col), na.rm = TRUE), + n_models = sum(!is.na(!!sym(cum_col))), + .groups = "drop" + ) %>% + filter(n_models >= 1) %>% + mutate(modelling_group = paste("Model Average", touchstone, sep = "-")) + + # Combine for plot + df_plot <- bind_rows( + df_cum %>% + select(year, modelling_group, touchstone, value = !!sym(cum_col)), + df_avg %>% + select(year, modelling_group, touchstone, value = !!sym(avg_col)) + ) + + df_plot <- df_plot %>% + group_by(modelling_group) %>% + filter(sum(value, na.rm = TRUE) > 0) %>% + ungroup() %>% + mutate( + line_type = ifelse( + grepl("Model Average", modelling_group), + "dashed", + "solid" + ) + ) + + if (nrow(df_plot) == 0 || all(df_plot$value == 0)) { + message("No non-zero data to plot for ", disease_filter, ". Skipping plot.") + return(NULL) + } + + df_plot +} diff --git a/R/fn_plotting_pressure_testing.R b/R/fn_plotting_pressure_testing.R index 8aaad49..1bb3da4 100644 --- a/R/fn_plotting_pressure_testing.R +++ b/R/fn_plotting_pressure_testing.R @@ -4,8 +4,10 @@ #' scale_fill_distiller scale_x_continuous scale_y_continuous labs vars #' labeller label_wrap_gen #' +#' @keywords internal +#' #' @export -significant_diff_plot <- function(df, outcome) { +plot_sig_diff <- function(df, outcome) { # retained here as this is a small df and a small operation df$label <- glue::glue( "{df$country_name} | {df$vaccine} | {df$activity_type} | {df$year}" @@ -75,15 +77,8 @@ plot_diff <- function( return(p) } -plot_modelling_group_variation <- function(df2, df3, outc = "deaths") { - offset <- 1e-6 - - df2 %>% - left_join(df3, by = join_by(modelling_group, vaccine)) %>% - mutate(adj_outc = !!as.name(paste0(outc, "_averted")) + offset) %>% - group_by(vaccine) %>% - mutate(mean_outc = weighted.mean(adj_outc, fvps, na.rm = TRUE)) %>% - ggplot() + +plot_modelling_group_variation <- function(df, outcome) { + ggplot(df) + aes( fill = as.character(mod_num), x = adj_outc, @@ -109,7 +104,7 @@ plot_modelling_group_variation <- function(df2, df3, outc = "deaths") { labs( x = paste0( "Burden averted (", - ifelse(outc == "dalys", "DALYs", outc), + ifelse(outcome == "dalys", "DALYs", outcome), ")" ), y = "Vaccine" @@ -117,51 +112,11 @@ plot_modelling_group_variation <- function(df2, df3, outc = "deaths") { } -# Gavi plot - future deaths and DALYS averted, 2021-2024 (current time window Gavi looking at, can be amended) -plot_vaccine_gavi <- function(df, prev_dat = NULL, outcome = "deaths_averted") { - df_cur <- df %>% - select(all_of(key_cols), !!outcome) %>% - filter(year >= 2021, year <= 2024, disease != "COVID") %>% - group_by(disease, year) %>% - summarise( - yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), - .groups = "drop" - ) %>% - mutate(dataset = as.character(new)) - - df_prev <- prev_dat %>% - select(all_of(key_cols), !!outcome) %>% - filter(year >= 2021, year <= 2024, disease != "COVID") %>% - group_by(disease, year) %>% - summarise( - yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), - .groups = "drop" - ) %>% - mutate(dataset = as.character(old)) - - df_combined <- bind_rows(df_cur, df_prev) - - df_diff <- df_cur %>% - left_join( - df_prev, - by = c("disease", "year"), - suffix = c("_curr", "_prev") - ) %>% - mutate( - yearly_outcome = yearly_outcome_curr - yearly_outcome_prev, - dataset = "Difference" - ) %>% - select(disease, year, yearly_outcome, dataset) - - df_combined <- bind_rows(df_combined, df_diff) - - df_combined$dataset <- factor( - df_combined$dataset, - levels = c(as.character(old), "Difference", as.character(new)) - ) - +#' Gavi plot - future deaths and DALYS averted, 2021-2024 +#' (current time window Gavi looking at, can be amended) +plot_vaccine_gavi <- function(df, outcome = "deaths_averted") { ggplot( - df_combined, + df, aes( x = reorder(disease, yearly_outcome), y = yearly_outcome, @@ -186,100 +141,8 @@ plot_vaccine_gavi <- function(df, prev_dat = NULL, outcome = "deaths_averted") { ### Gavi Cumulative Plot (modelling group + average) plot_cumul <- function(df, outcome, disease_filter) { - outcome_cols <- names(df)[str_detect(names(df), paste0("^", outcome, "_"))] - - outcome_sym <- sym(outcome) - cum_col <- paste0("cum_", outcome) - avg_col <- paste0("avg_", outcome) - - col_old <- paste0(outcome, "_old") - col_new <- paste0(outcome, "_new") - - combined2 <- df %>% - select( - country, - country_name, - disease, - vaccine, - activity_type, - year, - modelling_group, - all_of(outcome_cols) - ) %>% - pivot_longer( - cols = all_of(outcome_cols), - names_to = "touchstone", - values_to = "value" - ) %>% - mutate( - touchstone = str_remove(touchstone, paste0("^", outcome, "_")), - touchstone = recode( - touchstone, - "old" = as.character(old), - "new" = as.character(new), - .default = touchstone - ), - touchstone = factor( - touchstone, - levels = c(as.character(old), as.character(new)) - ) - ) - # Cumulative values by modelling group - df_cum <- combined2 %>% - filter(disease == disease_filter) %>% - group_by(modelling_group, touchstone) %>% - complete(year = full_seq(year, 1)) %>% - arrange(year) %>% - mutate( - first_valid = min(year[!is.na(value)]), - !!cum_col := ifelse( - year < first_valid, - NA, - cumsum(replace_na(value, 0)) - ) - ) %>% - select(-first_valid) %>% - ungroup() %>% - mutate(modelling_group = paste(modelling_group, touchstone, sep = "-")) - - # Model average - df_avg <- df_cum %>% - group_by(year, touchstone) %>% - summarise( - !!avg_col := mean(!!sym(cum_col), na.rm = TRUE), - n_models = sum(!is.na(!!sym(cum_col))), - .groups = "drop" - ) %>% - filter(n_models >= 1) %>% - mutate(modelling_group = paste("Model Average", touchstone, sep = "-")) - - # Combine for plot - df_plot <- bind_rows( - df_cum %>% - select(year, modelling_group, touchstone, value = !!sym(cum_col)), - df_avg %>% - select(year, modelling_group, touchstone, value = !!sym(avg_col)) - ) - - df_plot <- df_plot %>% - group_by(modelling_group) %>% - filter(sum(value, na.rm = TRUE) > 0) %>% - ungroup() %>% - mutate( - line_type = ifelse( - grepl("Model Average", modelling_group), - "dashed", - "solid" - ) - ) - - if (nrow(df_plot) == 0 || all(df_plot$value == 0)) { - message("No non-zero data to plot for ", disease_filter, ". Skipping plot.") - return(NULL) - } - p <- ggplot( - df_plot, + df, aes( x = year, y = value, From d0237fb1411aaf5244beffb0b6ee500e5814fe01 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 21 Apr 2026 09:08:02 +0100 Subject: [PATCH 10/29] WIP add docs and pkg infra --- .Rbuildignore | 1 + DESCRIPTION | 2 +- NAMESPACE | 11 +++++ _pkgdown.yml | 8 +++- jarl.toml | 2 + man/adaptive_round.Rd | 27 +++++++++++ man/add_campaign_id.Rd | 21 +++++++++ man/basic_burden_sanity.Rd | 2 +- man/check_demography_alignment.Rd | 2 +- man/compare_natl_subreg.Rd | 30 +++++++++++++ man/constants.Rd | 59 +++++++++++++++++++++++- man/flag_large_diffs.Rd | 50 +++++++++++++++++++++ man/gen_combined_df.Rd | 34 ++++++++++++++ man/gen_national_iqr.Rd | 34 ++++++++++++++ man/generate_diffs.Rd | 39 ++++++++++++++++ man/helpers.Rd | 2 +- man/plotting.Rd | 2 +- man/plotting_prep.Rd | 2 +- man/plotting_theme.Rd | 2 +- man/pres_test_filter_data.Rd | 56 +++++++++++++++++++++++ man/round_numeric.Rd | 15 +++++++ man/save_outputs.Rd | 60 +++++++++++++++++++++++++ man/significant_diff_plot.Rd | 12 +++++ man/validate_complete_incoming_files.Rd | 2 +- man/validate_file_dict_template.Rd | 2 +- man/validate_template_alignment.Rd | 2 +- man/validate_ts_year.Rd | 19 ++++++++ tests/spelling.R | 3 +- 28 files changed, 486 insertions(+), 15 deletions(-) create mode 100644 jarl.toml create mode 100644 man/adaptive_round.Rd create mode 100644 man/add_campaign_id.Rd create mode 100644 man/compare_natl_subreg.Rd create mode 100644 man/flag_large_diffs.Rd create mode 100644 man/gen_combined_df.Rd create mode 100644 man/gen_national_iqr.Rd create mode 100644 man/generate_diffs.Rd create mode 100644 man/pres_test_filter_data.Rd create mode 100644 man/round_numeric.Rd create mode 100644 man/save_outputs.Rd create mode 100644 man/significant_diff_plot.Rd create mode 100644 man/validate_ts_year.Rd diff --git a/.Rbuildignore b/.Rbuildignore index 73513b2..fa4bfd8 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,4 @@ ^scratch\.R$ ^scratch$ ^data-raw$ +^jarl\.toml$ diff --git a/DESCRIPTION b/DESCRIPTION index 1dee4e4..93969a5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -48,4 +48,4 @@ Encoding: UTF-8 Language: en-GB LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 9bcbd19..6a9f7c8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,7 +2,16 @@ export(basic_burden_sanity) export(check_demography_alignment) +export(compare_natl_subreg) export(file_dict_colnames) +export(filter_duplicates) +export(filter_excluded_diseases_ts) +export(filter_invalid_trajectories) +export(filter_recent_ts) +export(flag_large_diffs) +export(gen_combined_df) +export(gen_national_iqr) +export(generate_diffs) export(plot_age_patterns) export(plot_compare_demography) export(plot_coverage_set) @@ -15,6 +24,8 @@ export(prep_plot_coverage_set) export(prep_plot_demography) export(prep_plot_fvp) export(prep_plot_global_burden) +export(save_outputs) +export(significant_diff_plot) export(theme_vimc) export(theme_vimc_noxaxis) export(validate_complete_incoming_files) diff --git a/_pkgdown.yml b/_pkgdown.yml index bbc0826..ae53f13 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -7,10 +7,14 @@ reference: - title: Package-level documentation contents: - has_keyword("package_doc") - - title: Diagnostic functions - desc: Package diagnostic functions. + - title: Burden estimate diagnostics + desc: Functions to pressure-test burden estimates. contents: - has_keyword("diagnostics") + - title: Impact estimate diagnostics + desc: Functions to pressure-test impact estimates. + contents: + - has_keyword("pressure_testing") - title: Plotting prepartion desc: Prepare validated data for plotting. contents: diff --git a/jarl.toml b/jarl.toml new file mode 100644 index 0000000..a2e2af7 --- /dev/null +++ b/jarl.toml @@ -0,0 +1,2 @@ +[lint.assignment] +operator = "<-" diff --git a/man/adaptive_round.Rd b/man/adaptive_round.Rd new file mode 100644 index 0000000..ab1ae9c --- /dev/null +++ b/man/adaptive_round.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_helpers.R +\name{adaptive_round} +\alias{adaptive_round} +\title{Adaptively round numerics} +\usage{ +adaptive_round(x, large_threshold = 1, small_sigfig = 2, large_digits = 1) +} +\arguments{ +\item{x}{A numeric vector.} + +\item{large_threshold}{A single number for the threshold over which numbers +are to be considered 'large'.} + +\item{small_sigfig}{A single number for the number of significant digits for +'small' numbers.} + +\item{large_digits}{A single number for the number of places to which 'large' +numbers should be rounded.} +} +\value{ +\code{x} rounded to either \code{large_digits} or to \code{small_sigfig}. +} +\description{ +Adaptively round numerics +} +\keyword{internal} diff --git a/man/add_campaign_id.Rd b/man/add_campaign_id.Rd new file mode 100644 index 0000000..7e007ed --- /dev/null +++ b/man/add_campaign_id.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_helpers.R +\name{add_campaign_id} +\alias{add_campaign_id} +\title{Add campaign id to dataframe} +\usage{ +add_campaign_id(df, key_cols) +} +\arguments{ +\item{df}{A data.frame.} + +\item{key_cols}{A character vector of columns in \code{df} by which the data are +to be grouped.} +} +\value{ +\code{df} with a campaign identifier as a numeric. +} +\description{ +Add campaign id to dataframe +} +\keyword{internal} diff --git a/man/basic_burden_sanity.Rd b/man/basic_burden_sanity.Rd index 7217a7d..004cffd 100644 --- a/man/basic_burden_sanity.Rd +++ b/man/basic_burden_sanity.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/burden_diagnostics.R +% Please edit documentation in R/fn_burden_diagnostics.R \name{basic_burden_sanity} \alias{basic_burden_sanity} \title{Sanity checks on burden estimates} diff --git a/man/check_demography_alignment.Rd b/man/check_demography_alignment.Rd index 1b5ca1f..5afb1f0 100644 --- a/man/check_demography_alignment.Rd +++ b/man/check_demography_alignment.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/burden_diagnostics.R +% Please edit documentation in R/fn_burden_diagnostics.R \name{check_demography_alignment} \alias{check_demography_alignment} \title{Check incoming burden cohort size against interpolated population} diff --git a/man/compare_natl_subreg.Rd b/man/compare_natl_subreg.Rd new file mode 100644 index 0000000..ecf5cea --- /dev/null +++ b/man/compare_natl_subreg.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_pressure_testing.R +\name{compare_natl_subreg} +\alias{compare_natl_subreg} +\title{Compare sub-regional and national estimates} +\usage{ +compare_natl_subreg( + df, + outcome = c("deaths_averted_rate", "dalys_averted_rate"), + activity_filter = c("campaign", "routine") +) +} +\arguments{ +\item{df}{A data.frame with sub-region level data on vaccination impact +outcomes.} + +\item{outcome}{A string for the outcome of interest. May be one of +\code{"deaths_averted_rate"} or \code{"dalys_averted_rate"}.} + +\item{activity_filter}{A string for the type of vaccination activity. May be +one of \code{"campaign"} or \code{"routine"}.} +} +\value{ +A data.frame of sub-regional vaccination impact estimates where the +impact is considered to be outside the tolerance limit. +} +\description{ +Compare sub-regional and national estimates +} +\keyword{pressure_testing} diff --git a/man/constants.Rd b/man/constants.Rd index 7608951..8faa19a 100644 --- a/man/constants.Rd +++ b/man/constants.Rd @@ -7,8 +7,19 @@ \alias{scenario_data_colnames} \alias{burden_outcome_names} \alias{colnames_plot_demog_compare} +\alias{colnames_df_missing_cols} +\alias{COLNAMES_KEY_PRESSURE_TEST} +\alias{COLNAMES_INTEREST_PRESSURE_TEST} \alias{EXCLUDED_DISEASES} -\alias{TOUCHSTONE_OLD} +\alias{N_TS_MIN_CHARS} +\alias{N_TS_YEAR_CHARS} +\alias{MIN_TS_YEAR} +\alias{MAX_TS_YEAR} +\alias{MIN_TS_MONTH} +\alias{MAX_TS_MONTH} +\alias{DEF_TOUCHSTONE_OLD} +\alias{DEF_TOUCHSTONE_NEW} +\alias{DEF_TOUCHSTONE_OLD_OLD} \title{Package constants} \format{ An object of class \code{character} of length 5. @@ -19,8 +30,30 @@ An object of class \code{character} of length 10. An object of class \code{character} of length 7. +An object of class \code{character} of length 5. + +An object of class \code{character} of length 7. + +An object of class \code{character} of length 14. + An object of class \code{character} of length 4. +An object of class \code{integer} of length 1. + +An object of class \code{integer} of length 1. + +An object of class \code{numeric} of length 1. + +An object of class \code{numeric} of length 1. + +An object of class \code{numeric} of length 1. + +An object of class \code{numeric} of length 1. + +An object of class \code{character} of length 1. + +An object of class \code{character} of length 1. + An object of class \code{character} of length 1. } \usage{ @@ -32,9 +65,31 @@ burden_outcome_names colnames_plot_demog_compare +colnames_df_missing_cols + +COLNAMES_KEY_PRESSURE_TEST + +COLNAMES_INTEREST_PRESSURE_TEST + EXCLUDED_DISEASES -TOUCHSTONE_OLD +N_TS_MIN_CHARS + +N_TS_YEAR_CHARS + +MIN_TS_YEAR + +MAX_TS_YEAR + +MIN_TS_MONTH + +MAX_TS_MONTH + +DEF_TOUCHSTONE_OLD + +DEF_TOUCHSTONE_NEW + +DEF_TOUCHSTONE_OLD_OLD } \description{ Package constants diff --git a/man/flag_large_diffs.Rd b/man/flag_large_diffs.Rd new file mode 100644 index 0000000..e0379b1 --- /dev/null +++ b/man/flag_large_diffs.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_pressure_testing.R +\name{flag_large_diffs} +\alias{flag_large_diffs} +\title{Flag significant changes in impact estimates} +\usage{ +flag_large_diffs( + changes_list, + iqr_df, + variable = c("deaths_averted", "dalys_averted"), + group_cols = c("country", "vaccine", "activity_type"), + threshold = 100, + touchstone_old = DEF_TOUCHSTONE_OLD_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW +) +} +\arguments{ +\item{changes_list}{A list of data.frames with one element per variable of +interest (see \code{variable}). Usually generated using \code{\link[=generate_diffs]{generate_diffs()}}.} + +\item{iqr_df}{A data.frame of inter-quartile differences generated using +\code{\link[=gen_national_iqr]{gen_national_iqr()}}.} + +\item{variable}{A string specifying the variable of interest. Must be one of +"deaths_averted" and "dalys_averted", and must be present as a name and +element of \code{changes_list}.} + +\item{group_cols}{A character vector of grouping columns. Defaults to +"country", "vaccine", "activity_type".} + +\item{threshold}{A single numeric value for the IQR multiplier. Defaults to +100.} + +\item{touchstone_old}{The previous touchstone identifier. Defaults to +\link{DEF_TOUCHSTONE_OLD_OLD}.} + +\item{touchstone_new}{The new touchstone identifier. Defaults to +\link{DEF_TOUCHSTONE_NEW}.} +} +\value{ +A filtered data.frame of differences in impact estimates flagged +as too large. Rows with differences within tolerance are removed. +} +\description{ +Calculates and flags whether the difference in impact estimates +between touchstones is greater than expected. A row is flagged if the +difference is greater than \code{threshold} \eqn{\times} the inter-quartile range +for cases where the IQR is greater than zero. +} +\keyword{pressure_testing} diff --git a/man/gen_combined_df.Rd b/man/gen_combined_df.Rd new file mode 100644 index 0000000..9a329d3 --- /dev/null +++ b/man/gen_combined_df.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_pressure_testing.R +\name{gen_combined_df} +\alias{gen_combined_df} +\title{Combine and align data from two touchstones} +\usage{ +gen_combined_df( + prev_dat, + df2, + interest_cols = COLNAMES_INTEREST_PRESSURE_TEST, + key_cols = COLNAMES_KEY_PRESSURE_TEST +) +} +\arguments{ +\item{prev_dat}{A data.frame of impact estimates corresponding to an earlier +touchstone.} + +\item{df2}{A data.frame of impact estimates corresponding to a more recent +touchstone.} + +\item{interest_cols}{A character vector of columns of interest. Defaults to +\link{COLNAMES_INTEREST_PRESSURE_TEST}.} + +\item{key_cols}{A character vector of columns of interest. Defaults to +\link{COLNAMES_KEY_PRESSURE_TEST}.} +} +\value{ +A data.frame which is a full join of \code{prev_dat} and \code{df2}. Columns +are disambiguated with the suffixes \code{"_old"} and \code{"_new"}. +} +\description{ +Generates a full join of two data.frames, selecting for columns of interest. +} +\keyword{pressure_testing} diff --git a/man/gen_national_iqr.Rd b/man/gen_national_iqr.Rd new file mode 100644 index 0000000..c722e66 --- /dev/null +++ b/man/gen_national_iqr.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_pressure_testing.R +\name{gen_national_iqr} +\alias{gen_national_iqr} +\title{Generate IQR for key outcomes} +\usage{ +gen_national_iqr( + df, + group_cols = c("country", "vaccine", "activity_type"), + value_cols = c("deaths_averted", "dalys_averted"), + prefix = "national_iqr" +) +} +\arguments{ +\item{df}{A data.frame of impact estimates.} + +\item{group_cols}{A character vector of grouping columns. Defaults to +"country", "vaccine", "activity_type".} + +\item{value_cols}{A character vector of value columns. Defaults to +"deaths_averted" and "dalys_averted".} + +\item{prefix}{A string for the prefix applied to every IQR summary column. +Defaults to "national_iqr".} +} +\value{ +A \verb{} with the inter-quartile range of the columns +in \code{value_cols}, with the column name constructed as \verb{\{prefix\}_\{value_col\}} +using string interpolation. +} +\description{ +Generate IQR for key outcomes +} +\keyword{pressure_testing} diff --git a/man/generate_diffs.Rd b/man/generate_diffs.Rd new file mode 100644 index 0000000..17fcf32 --- /dev/null +++ b/man/generate_diffs.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_pressure_testing.R +\name{generate_diffs} +\alias{generate_diffs} +\title{Explore significant changes in deaths and DALYs} +\usage{ +generate_diffs( + prev_df, + curr_df, + interest_cols = COLNAMES_INTEREST_PRESSURE_TEST, + key_cols = COLNAMES_KEY_PRESSURE_TEST, + touchstone = DEF_TOUCHSTONE_OLD +) +} +\arguments{ +\item{prev_df}{A \verb{} of impact estimates from the previous +touchstone.} + +\item{curr_df}{A \verb{} of impact estimates for the current +touchstone.} + +\item{interest_cols}{A character vector of columns to check for differences. +Defaults to \link{COLNAMES_INTEREST_PRESSURE_TEST}.} + +\item{key_cols}{A character vector of columns to use when assigning campaign +identifiers. Passed to \code{\link[=add_campaign_id]{add_campaign_id()}}, defaults to +\link{COLNAMES_KEY_PRESSURE_TEST}.} + +\item{touchstone}{A six character string that can be converted to a six digit +numeric giving a touchstone identifier in \code{YYYYMM} format.} +} +\value{ +A list of data.frames of differences between \code{prev_df} and \code{curr_df}, +with one list element per element of \code{interest_cols}. +} +\description{ +Explore significant changes in deaths and DALYs +} +\keyword{pressure_testing} diff --git a/man/helpers.Rd b/man/helpers.Rd index fb9c4df..af26b2d 100644 --- a/man/helpers.Rd +++ b/man/helpers.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/helpers.R +% Please edit documentation in R/fn_helpers.R \name{helpers} \alias{helpers} \alias{make_novax_scenario} diff --git a/man/plotting.Rd b/man/plotting.Rd index 8dd565e..7f915a3 100644 --- a/man/plotting.Rd +++ b/man/plotting.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plotting.R +% Please edit documentation in R/fn_plotting_burden_diagnostics.R \name{plotting} \alias{plotting} \alias{plot_compare_demography} diff --git a/man/plotting_prep.Rd b/man/plotting_prep.Rd index 881a9f3..f8124bc 100644 --- a/man/plotting_prep.Rd +++ b/man/plotting_prep.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plotting_prep.R +% Please edit documentation in R/fn_plotting_prep_bur_diag.R \name{plotting_prep} \alias{plotting_prep} \alias{prep_plot_demography} diff --git a/man/plotting_theme.Rd b/man/plotting_theme.Rd index c2c49e0..fe46d78 100644 --- a/man/plotting_theme.Rd +++ b/man/plotting_theme.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plotting.R +% Please edit documentation in R/fn_plotting_burden_diagnostics.R \name{plotting_theme} \alias{plotting_theme} \alias{theme_vimc} diff --git a/man/pres_test_filter_data.Rd b/man/pres_test_filter_data.Rd new file mode 100644 index 0000000..003617a --- /dev/null +++ b/man/pres_test_filter_data.Rd @@ -0,0 +1,56 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_pressure_testing.R +\name{pres_test_filter_data} +\alias{pres_test_filter_data} +\alias{filter_recent_ts} +\alias{filter_excluded_diseases_ts} +\alias{filter_duplicates} +\alias{filter_invalid_trajectories} +\title{Filter data for touchstones or diseases} +\usage{ +filter_recent_ts(df, threshold = 202310) + +filter_excluded_diseases_ts(df, threshold = 202110) + +filter_duplicates(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) + +filter_invalid_trajectories( + df, + prev_data, + outcome = c("deaths_averted", "dalys_averted") +) +} +\arguments{ +\item{df}{A \verb{} holding impact data. This data.frame is not +checked for contents} + +\item{threshold}{A six-digit number that is checked as a valid touchstone +identifier (YYYYMM format) using \code{\link[=validate_ts_year]{validate_ts_year()}}.} + +\item{key_cols}{Key columns in \code{df} to check for duplicates.} + +\item{prev_data}{A \verb{} holding data from a previous touchstone for +the same scenarios as \code{df}.} + +\item{outcome}{A string giving the outcome of interest; may be one of +\code{"deaths_averted"} or \code{"dalys_averted"}.} +} +\value{ +A filtered \verb{}. +\itemize{ +\item \code{filter_recent_ts()} returns \code{df} with rows where the touchstone condition +is not met excluded. +\item \code{filter_excluded_diseases_ts()} returns \code{df} with rows where rows relating +to the \link{EXCLUDED_DISEASES}, when the touchstone year in \code{df} is less than the +\code{threshold}, excluded. +\item \code{filter_duplicates()} returns \code{df} with duplicated combinations of +\code{key_cols} removed. +\item \code{filter_invalid_trajectories()} returns \code{df} with bad outcome trajectories +(\code{NA} to non-\code{NA}) removed. +} +} +\description{ +A pair of helper functions allowing filtering out of recent touchstone values +and excluded diseases. +} +\keyword{pressure_testing} diff --git a/man/round_numeric.Rd b/man/round_numeric.Rd new file mode 100644 index 0000000..3c95234 --- /dev/null +++ b/man/round_numeric.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_helpers.R +\name{round_numeric} +\alias{round_numeric} +\title{Round numeric columns of a data.frame} +\usage{ +round_numeric(df) +} +\arguments{ +\item{df}{A data.frame.} +} +\description{ +Round numeric columns of a data.frame +} +\keyword{internal} diff --git a/man/save_outputs.Rd b/man/save_outputs.Rd new file mode 100644 index 0000000..db41a66 --- /dev/null +++ b/man/save_outputs.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_pressure_testing.R +\name{save_outputs} +\alias{save_outputs} +\title{Save pressure-testing diagnostics to local file} +\usage{ +save_outputs( + missing_in_current, + missing_deaths, + missing_dalys, + changes_deaths, + changes_dalys, + subregional_flags_deaths_camp, + subregional_flags_deaths_rout, + subregional_flags_dalys_camp, + subregional_flags_dalys_rout, + output_dir = here::here("outputs") +) +} +\arguments{ +\item{missing_in_current}{A data.frame.} + +\item{missing_deaths}{A data.frame that is the output of +\code{\link[=filter_invalid_trajectories]{filter_invalid_trajectories()}} with the outcome \code{"deaths_averted"}.} + +\item{missing_dalys}{A data.frame that is the output of +\code{\link[=filter_invalid_trajectories]{filter_invalid_trajectories()}} with the outcome \code{"dalys_averted"}.} + +\item{changes_deaths}{A data.frame that is the output of \code{\link[=flag_large_diffs]{flag_large_diffs()}} +with the outcome \code{"deaths_averted"}.} + +\item{changes_dalys}{A data.frame that is the output of \code{\link[=flag_large_diffs]{flag_large_diffs()}} +with the outcome \code{"dalys_averted"}.} + +\item{subregional_flags_deaths_camp}{A data.frame that is the output of +\code{\link[=compare_natl_subreg]{compare_natl_subreg()}} with the outcome \code{"deaths_averted_rate"} for the +\code{"campaign"} activity type.} + +\item{subregional_flags_deaths_rout}{A data.frame that is the output of +\code{\link[=compare_natl_subreg]{compare_natl_subreg()}} with the outcome \code{"deaths_averted_rate"} for the +\code{"routine"} activity type.} + +\item{subregional_flags_dalys_camp}{A data.frame that is the output of +\code{\link[=compare_natl_subreg]{compare_natl_subreg()}} with the outcome \code{"dalys_averted_rate"} for the +\code{"campaign"} activity type.} + +\item{subregional_flags_dalys_rout}{A data.frame that is the output of +\code{\link[=compare_natl_subreg]{compare_natl_subreg()}} with the outcome \code{"dalys_averted_rate"} for the +\code{"campaign"} activity type.} +} +\value{ +None. Called for the convenience side-effect of saving data.frames as +\code{.Rds} format. +} +\description{ +Save pressure-testing diagnostics data.frames to local compressed files in +the \code{.Rds} format. Input data.frames are generated by other package functions +and are not checked here. +} +\keyword{pressure_testing} diff --git a/man/significant_diff_plot.Rd b/man/significant_diff_plot.Rd new file mode 100644 index 0000000..11b7cb4 --- /dev/null +++ b/man/significant_diff_plot.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_plotting_pressure_testing.R +\name{significant_diff_plot} +\alias{significant_diff_plot} +\title{Plot significant changes} +\usage{ +significant_diff_plot(df, outcome) +} +\description{ +Plot significant changes +} +\keyword{internal} diff --git a/man/validate_complete_incoming_files.Rd b/man/validate_complete_incoming_files.Rd index 148311b..75d3cd9 100644 --- a/man/validate_complete_incoming_files.Rd +++ b/man/validate_complete_incoming_files.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/burden_diagnostics.R +% Please edit documentation in R/fn_burden_diagnostics.R \name{validate_complete_incoming_files} \alias{validate_complete_incoming_files} \title{Validate files in a burden estimate} diff --git a/man/validate_file_dict_template.Rd b/man/validate_file_dict_template.Rd index 293a605..af2d770 100644 --- a/man/validate_file_dict_template.Rd +++ b/man/validate_file_dict_template.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/burden_diagnostics.R +% Please edit documentation in R/fn_burden_diagnostics.R \name{validate_file_dict_template} \alias{validate_file_dict_template} \title{Validate file dictionary template} diff --git a/man/validate_template_alignment.Rd b/man/validate_template_alignment.Rd index 7ff801a..7bbccc6 100644 --- a/man/validate_template_alignment.Rd +++ b/man/validate_template_alignment.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/burden_diagnostics.R +% Please edit documentation in R/fn_burden_diagnostics.R \name{validate_template_alignment} \alias{validate_template_alignment} \title{Check incoming burden set against template} diff --git a/man/validate_ts_year.Rd b/man/validate_ts_year.Rd new file mode 100644 index 0000000..6812fcf --- /dev/null +++ b/man/validate_ts_year.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_helpers.R +\name{validate_ts_year} +\alias{validate_ts_year} +\title{Check and return touchstone year-month} +\usage{ +validate_ts_year(x) +} +\arguments{ +\item{x}{A string for the touchstone identifier.} +} +\value{ +The first 6 characters of \code{x} converted to a numeric. Also has side +effects of erroring if conditions on \code{x} are not met. +} +\description{ +Check and return touchstone year-month +} +\keyword{internal} diff --git a/tests/spelling.R b/tests/spelling.R index a8cf85b..d60e024 100644 --- a/tests/spelling.R +++ b/tests/spelling.R @@ -1,6 +1,7 @@ -if (requireNamespace('spelling', quietly = TRUE)) +if (requireNamespace("spelling", quietly = TRUE)) { spelling::spell_check_test( vignettes = TRUE, error = FALSE, skip_on_cran = TRUE ) +} From 4a52fbb619331bd717bc7604aba97634f237ee4b Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 21 Apr 2026 10:27:22 +0100 Subject: [PATCH 11/29] Reorganise docs --- R/fn_burden_diagnostics.R | 10 ++-- R/fn_plotting_burden_diagnostics.R | 81 +++--------------------------- R/fn_plotting_helpers.R | 64 +++++++++++++++++++++++ R/fn_plotting_prep_bur_diag.R | 31 ++++++++---- R/fn_pressure_testing.R | 14 +++--- _pkgdown.yml | 42 ++++++++++------ 6 files changed, 133 insertions(+), 109 deletions(-) create mode 100644 R/fn_plotting_helpers.R diff --git a/R/fn_burden_diagnostics.R b/R/fn_burden_diagnostics.R index 0986acf..f77f09c 100644 --- a/R/fn_burden_diagnostics.R +++ b/R/fn_burden_diagnostics.R @@ -17,7 +17,7 @@ #' Prints a message to screen informing the user whether any action has been #' taken. #' -#' @keywords diagnostics +#' @keywords burden_diagnostics #' #' @export validate_file_dict_template <- function( @@ -121,7 +121,7 @@ validate_file_dict_template <- function( #' @return A `` of the scenario file dictionary in `path_burden` if all #' checks pass. Otherwise, exits with informative errors on failed checks. #' -#' @keywords diagnostics +#' @keywords burden_diagnostics #' #' @export validate_complete_incoming_files <- function( @@ -212,7 +212,7 @@ validate_complete_incoming_files <- function( #' @return A named list of checks carried out on `burden_set` to compare it #' against `template`, with information on missing and extra data. #' -#' @keywords diagnostics +#' @keywords burden_diagnostics #' #' @export validate_template_alignment <- function(burden_set, template) { @@ -276,7 +276,7 @@ validate_template_alignment <- function(burden_set, template) { #' @return A `` giving the alignment, i.e., percentage difference of #' modelled population size from the WPP-derived population estimates. #' -#' @keywords diagnostics +#' @keywords burden_diagnostics #' #' @export check_demography_alignment <- function( @@ -344,7 +344,7 @@ check_demography_alignment <- function( #' @return A character vector of messages generated by checks on burden #' estimates, with the length of the vector depending on how many checks fail. #' -#' @keywords diagnostics +#' @keywords burden_diagnostics #' #' @export basic_burden_sanity <- function(burden) { diff --git a/R/fn_plotting_burden_diagnostics.R b/R/fn_plotting_burden_diagnostics.R index 9d137ac..71b7d54 100644 --- a/R/fn_plotting_burden_diagnostics.R +++ b/R/fn_plotting_burden_diagnostics.R @@ -1,72 +1,7 @@ -#' Plotting theme for vimcheck -#' -#' @description -#' A simple plotting theme building on [ggplot2::theme_bw()]. -#' -#' @name plotting_theme -#' @rdname plotting_theme -#' -#' @param x_text_angle The angle for X-axis labels. Defaults to 45 degrees. -#' -#' @param y_text_angle The angle for Y-axis labels. Defaults to 0 degrees. -#' -#' @param ... <[`dynamic-dots`][rlang::dyn-dots]> Other arguments passed to -#' [ggplot2::theme()]. These will be applied in addition to, or in place of, -#' pre-existing elements defined by this theme. See the examples for this -#' theme's appearance. -#' -#' @return A `ggplot2` theme that can be added to `ggplot2` plots or objects. -#' -#' @keywords plotting -#' -#' @examples -#' # using an inbuilt dataset -#' data(mtcars) -#' -#' # standard theme -#' ggplot2::ggplot(mtcars, ggplot2::aes(disp, mpg)) + -#' ggplot2::geom_point() + -#' theme_vimc() -#' -#' # with X-axis suppression -#' ggplot2::ggplot(mtcars, ggplot2::aes(disp, mpg)) + -#' ggplot2::geom_point() + -#' theme_vimc_noxaxis() -#' -#' @export -theme_vimc <- function(x_text_angle = 45, y_text_angle = 0, ...) { - ggplot2::theme_bw() + - ggplot2::theme( - axis.text.x = ggplot2::element_text( - size = 10, - angle = x_text_angle - ), - strip.text.y = ggplot2::element_text( - angle = y_text_angle - ), - plot.margin = ggplot2::margin(1, 0, 1, 0, "cm"), - ... - ) -} - -#' @name plotting_theme -#' -#' @importFrom ggplot2 '%+replace%' -#' -#' @export -theme_vimc_noxaxis <- function() { - theme_vimc() %+replace% - ggplot2::theme( - axis.title.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.ticks.x = ggplot2::element_blank() - ) -} - #' Plot burden and impact diagnostics #' -#' @name plotting -#' @rdname plotting +#' @name plot_burden_diagnostics +#' @rdname plot_burden_diagnostics #' #' @importFrom ggplot2 ggplot aes geom_col geom_hline facet_wrap facet_grid #' scale_fill_distiller scale_x_continuous scale_y_continuous labs vars @@ -77,7 +12,7 @@ theme_vimc_noxaxis <- function() { #' @description #' Plotting functions for burden and impact diagnostics. All functions operate #' on data prepared for plotting by a corresponding -#' [plotting-preparation function][plotting_prep]. +#' [plotting-preparation function][plot_prep_burden_diagnostics]. #' #' @param fig_number The figure number displayed in the plot title. #' @@ -121,7 +56,7 @@ plot_compare_demography <- function(data, fig_number) { g } -#' @name plotting +#' @name plot_burden_diagnostics #' #' @param burden_age A `` with the minimum column names #' "age", "value_millions", "burden_outcome", and "scenario"; expected to be the @@ -154,7 +89,7 @@ plot_age_patterns <- function(burden_age, fig_number) { g } -#' @name plotting +#' @name plot_burden_diagnostics #' #' @param burden_decades A `` giving the burden by decade, up to #' `year_max`; expected to be the output of [prep_plot_burden_decades()]. @@ -182,7 +117,7 @@ plot_global_burden_decades <- function(burden_decades, fig_number) { g } -#' @name plotting +#' @name plot_burden_diagnostics #' #' @param burden_data This is expected to be a `` from a #' nested-`` constructed using [prep_plot_global_burden()]. @@ -226,7 +161,7 @@ plot_global_burden <- function(burden_data, outcome_name, fig_number) { g } -#' @name plotting +#' @name plot_burden_diagnostics #' #' @param coverage_set A `` that is the output of #' [prep_plot_coverage_set()]. @@ -271,7 +206,7 @@ plot_coverage_set <- function(coverage_set, fig_number) { g } -#' @name plotting +#' @name plot_burden_diagnostics #' #' @param fvp_data A `` of estimates of fully-vaccinated persons (FVPs) #' per scenario, with scenarios as factors in order of the number of diff --git a/R/fn_plotting_helpers.R b/R/fn_plotting_helpers.R new file mode 100644 index 0000000..4d14cce --- /dev/null +++ b/R/fn_plotting_helpers.R @@ -0,0 +1,64 @@ +#' Plotting theme for vimcheck +#' +#' @description +#' A simple plotting theme building on [ggplot2::theme_bw()]. +#' +#' @name plotting_theme +#' @rdname plotting_theme +#' +#' @param x_text_angle The angle for X-axis labels. Defaults to 45 degrees. +#' +#' @param y_text_angle The angle for Y-axis labels. Defaults to 0 degrees. +#' +#' @param ... <[`dynamic-dots`][rlang::dyn-dots]> Other arguments passed to +#' [ggplot2::theme()]. These will be applied in addition to, or in place of, +#' pre-existing elements defined by this theme. See the examples for this +#' theme's appearance. +#' +#' @return A `ggplot2` theme that can be added to `ggplot2` plots or objects. +#' +#' @keywords plotting +#' +#' @examples +#' # using an inbuilt dataset +#' data(mtcars) +#' +#' # standard theme +#' ggplot2::ggplot(mtcars, ggplot2::aes(disp, mpg)) + +#' ggplot2::geom_point() + +#' theme_vimc() +#' +#' # with X-axis suppression +#' ggplot2::ggplot(mtcars, ggplot2::aes(disp, mpg)) + +#' ggplot2::geom_point() + +#' theme_vimc_noxaxis() +#' +#' @export +theme_vimc <- function(x_text_angle = 45, y_text_angle = 0, ...) { + ggplot2::theme_bw() + + ggplot2::theme( + axis.text.x = ggplot2::element_text( + size = 10, + angle = x_text_angle + ), + strip.text.y = ggplot2::element_text( + angle = y_text_angle + ), + plot.margin = ggplot2::margin(1, 0, 1, 0, "cm"), + ... + ) +} + +#' @name plotting_theme +#' +#' @importFrom ggplot2 '%+replace%' +#' +#' @export +theme_vimc_noxaxis <- function() { + theme_vimc() %+replace% + ggplot2::theme( + axis.title.x = ggplot2::element_blank(), + axis.text.x = ggplot2::element_blank(), + axis.ticks.x = ggplot2::element_blank() + ) +} diff --git a/R/fn_plotting_prep_bur_diag.R b/R/fn_plotting_prep_bur_diag.R index 277c083..b76b29f 100644 --- a/R/fn_plotting_prep_bur_diag.R +++ b/R/fn_plotting_prep_bur_diag.R @@ -1,12 +1,13 @@ #' Prepare data for plotting #' -#' @name plotting_prep -#' @rdname plotting_prep +#' @name plot_prep_burden_diagnostics +#' @rdname plot_prep_burden_diagnostics #' #' @description #' Transform burden estimate data from modelling groups to make them suitable -#' for plotting using an appropriate [plotting function][plotting]. Each -#' preparation function corresponds to a plotting function. +#' for plotting using an appropriate +#' [plotting function][plot_prep_burden_diagnostics]. Each preparation function +#' corresponds to a plotting function. #' #' @param burden For `prep_plot_demography()`, a `` output from #' [check_demography_alignment()]. @@ -31,6 +32,8 @@ #' #' - For `prep_plot_fvp()`: WIP. #' +#' @keywords plot_prep_burden_diagnostics +#' #' @export prep_plot_demography <- function(burden) { checkmate::assert_tibble(burden) @@ -88,7 +91,9 @@ prep_plot_demography <- function(burden) { burden_long } -#' @name plotting_prep +#' @name plot_prep_burden_diagnostics +#' +#' @keywords plot_prep_burden_diagnostics #' #' @export prep_plot_age <- function(burden) { @@ -109,11 +114,13 @@ prep_plot_age <- function(burden) { burden_summary } -#' @name plotting_prep +#' @name plot_prep_burden_diagnostics #' #' @param year_max The maximum year to be represented in a subsequent figure. #' For `prep_plot_burden_decades()`, must be a decade, i.e., multiple of 10. #' +#' @keywords plot_prep_burden_diagnostics +#' #' @export prep_plot_burden_decades <- function(burden, year_max) { checkmate::assert_tibble(burden) @@ -158,7 +165,9 @@ prep_plot_burden_decades <- function(burden, year_max) { burden_data } -#' @name plotting_prep +#' @name plot_prep_burden_diagnostics +#' +#' @keywords plot_prep_burden_diagnostics #' #' @export prep_plot_global_burden <- function(burden) { @@ -184,10 +193,12 @@ prep_plot_global_burden <- function(burden) { burden_nested } -#' @name plotting_prep +#' @name plot_prep_burden_diagnostics #' #' @param coverage WIP. Coverage data. #' +#' @keywords plot_prep_burden_diagnostics +#' #' @export prep_plot_coverage_set <- function(coverage) { checkmate::assert_tibble(coverage) @@ -245,12 +256,14 @@ prep_plot_coverage_set <- function(coverage) { coverage_set } -#' @name plotting_prep +#' @name plot_prep_burden_diagnostics #' #' @param fvp WIP. Data on counts of fully vaccinated persons. #' #' @param year_min Minimum year. #' +#' @keywords plot_prep_burden_diagnostics +#' #' @export prep_plot_fvp <- function(fvp, year_min, year_max) { checkmate::assert_tibble(fvp) diff --git a/R/fn_pressure_testing.R b/R/fn_pressure_testing.R index 9f25309..fbcc3fb 100644 --- a/R/fn_pressure_testing.R +++ b/R/fn_pressure_testing.R @@ -13,7 +13,7 @@ #' @param threshold A six-digit number that is checked as a valid touchstone #' identifier (YYYYMM format) using [validate_ts_year()]. #' -#' @keywords pressure_testing +#' @keywords impact_diagnostics #' #' @return A filtered ``. #' @@ -207,7 +207,7 @@ filter_invalid_trajectories <- function( #' @return A list of data.frames of differences between `prev_df` and `curr_df`, #' with one list element per element of `interest_cols`. #' -#' @keywords pressure_testing +#' @keywords impact_diagnostics #' #' @export generate_diffs <- function( @@ -272,7 +272,7 @@ generate_diffs <- function( #' Generate IQR for key outcomes #' -#' @keywords pressure_testing +#' @keywords impact_diagnostics #' #' @param df A data.frame of impact estimates. #' @@ -358,7 +358,7 @@ gen_national_iqr <- function( #' @return A filtered data.frame of differences in impact estimates flagged #' as too large. Rows with differences within tolerance are removed. #' -#' @keywords pressure_testing +#' @keywords impact_diagnostics #' #' @export flag_large_diffs <- function( @@ -477,7 +477,7 @@ flag_large_diffs <- function( #' @return A data.frame which is a full join of `prev_dat` and `df2`. Columns #' are disambiguated with the suffixes `"_old"` and `"_new"`. #' -#' @keywords pressure_testing +#' @keywords impact_diagnostics #' #' @export gen_combined_df <- function( @@ -537,7 +537,7 @@ gen_combined_df <- function( #' @return A data.frame of sub-regional vaccination impact estimates where the #' impact is considered to be outside the tolerance limit. #' -#' @keywords pressure_testing +#' @keywords impact_diagnostics #' #' @export compare_natl_subreg <- function( @@ -657,7 +657,7 @@ compare_natl_subreg <- function( #' @return None. Called for the convenience side-effect of saving data.frames as #' `.Rds` format. #' -#' @keywords pressure_testing +#' @keywords impact_diagnostics #' #' @export save_outputs <- function( diff --git a/_pkgdown.yml b/_pkgdown.yml index ae53f13..40a29ee 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -7,32 +7,44 @@ reference: - title: Package-level documentation contents: - has_keyword("package_doc") + - title: Burden estimate diagnostics - desc: Functions to pressure-test burden estimates. + + - subtitle: Check burden estimates + contents: + - has_keyword("burden_diagnostics") + - subtitle: Prepare burden estimates for plotting + contents: + - plot_prep_burden_diagnostics + - subtitle: Plot burden estimates contents: - - has_keyword("diagnostics") + - plot_burden_diagnostics + + - title: Impact estimate diagnostics - desc: Functions to pressure-test impact estimates. + + - subtitle: Check impact estimates + contents: + - has_keyword("impact_diagnostics") + - subtitle: Prepare impact estimate checks for plotting contents: - - has_keyword("pressure_testing") - - title: Plotting prepartion - desc: Prepare validated data for plotting. + - plot_prep_impact_diagnostics + - subtitle: Plot impact estimates contents: - - plotting_prep - - title: Plotting functions - desc: Package plotting functions. + - plot_impact_diagnostics + + - title: Plotting helper functions contents: - - plotting - plotting_theme + - title: Internal functions - desc: Internal helper functions. contents: - has_keyword("internal") - - title: Data - desc: Package data. + + - title: Package data contents: - has_keyword("data") - - title: Constants - desc: Package constants. + + - title: Package constants contents: - has_keyword("constants") From bba30c5b5f66f90613a585b607eefbc384a66bd4 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 21 Apr 2026 10:27:57 +0100 Subject: [PATCH 12/29] WIP plotting and prep fns impact diagnostics --- ...ing.R => fn_plotting_impact_diagnostics.R} | 24 +++++++++++++----- ... => fn_plotting_prep_impact_diagnostics.R} | 25 +++++++++++++++++++ 2 files changed, 43 insertions(+), 6 deletions(-) rename R/{fn_plotting_pressure_testing.R => fn_plotting_impact_diagnostics.R} (90%) rename R/{fn_plotting_prep_pres_test.R => fn_plotting_prep_impact_diagnostics.R} (85%) diff --git a/R/fn_plotting_pressure_testing.R b/R/fn_plotting_impact_diagnostics.R similarity index 90% rename from R/fn_plotting_pressure_testing.R rename to R/fn_plotting_impact_diagnostics.R index 1bb3da4..66477a8 100644 --- a/R/fn_plotting_pressure_testing.R +++ b/R/fn_plotting_impact_diagnostics.R @@ -1,11 +1,12 @@ #' Plot significant changes #' +#' @name plot_impact_diagnostics +#' @rdname plot_impact_diagnostics +#' #' @importFrom ggplot2 ggplot aes geom_col geom_hline facet_wrap facet_grid #' scale_fill_distiller scale_x_continuous scale_y_continuous labs vars #' labeller label_wrap_gen #' -#' @keywords internal -#' #' @export plot_sig_diff <- function(df, outcome) { # retained here as this is a small df and a small operation @@ -27,6 +28,9 @@ plot_sig_diff <- function(df, outcome) { theme_vimc(x_text_angle = 0) } +#' @name plot_impact_diagnostics +#' +#' @export plot_diff <- function( combined, variable, @@ -77,6 +81,9 @@ plot_diff <- function( return(p) } +#' @name plot_impact_diagnostics +#' +#' @export plot_modelling_group_variation <- function(df, outcome) { ggplot(df) + aes( @@ -111,9 +118,11 @@ plot_modelling_group_variation <- function(df, outcome) { ) } - -#' Gavi plot - future deaths and DALYS averted, 2021-2024 -#' (current time window Gavi looking at, can be amended) +# Gavi plot - future deaths and DALYS averted, 2021-2024 +# (current time window Gavi looking at, can be amended) +#' @name plot_impact_diagnostics +#' +#' @export plot_vaccine_gavi <- function(df, outcome = "deaths_averted") { ggplot( df, @@ -139,7 +148,10 @@ plot_vaccine_gavi <- function(df, outcome = "deaths_averted") { labs(x = "Disease", y = paste("Impact -", outcome), fill = "Year") } -### Gavi Cumulative Plot (modelling group + average) +# Gavi Cumulative Plot (modelling group + average) +#' @name plot_impact_diagnostics +#' +#' @export plot_cumul <- function(df, outcome, disease_filter) { p <- ggplot( df, diff --git a/R/fn_plotting_prep_pres_test.R b/R/fn_plotting_prep_impact_diagnostics.R similarity index 85% rename from R/fn_plotting_prep_pres_test.R rename to R/fn_plotting_prep_impact_diagnostics.R index d1959dd..ca5328b 100644 --- a/R/fn_plotting_prep_pres_test.R +++ b/R/fn_plotting_prep_impact_diagnostics.R @@ -1,3 +1,18 @@ +#' Prepare impact diagnostics for plotting +#' +#' @name plot_prep_impact_diagnostics +#' @rdname plot_prep_impact_diagnostics +#' +#' @description +#' A suite of helper functions that sit between impact diagnostics functions and +#' plotting functions. These functions have some basic checks on the input data, +#' but otherwise assume that users will not modify inputs. +#' +#' @param name description +#' +#' @return [prep_plot_mod_grp_varn()] returns a ... TODO add +#' +#' @export prep_plot_mod_grp_varn <- function(df2, df3, outc = "deaths") { offset <- 1e-6 @@ -8,6 +23,11 @@ prep_plot_mod_grp_varn <- function(df2, df3, outc = "deaths") { mutate(mean_outc = weighted.mean(adj_outc, fvps, na.rm = TRUE)) } +#' @name plot_prep_impact_diagnostics +#' +#' @return [prep_plot_vax_gavi()] returns a ... TODO add +#' +#' @export prep_plot_vax_gavi <- function( df, prev_dat = NULL, @@ -57,6 +77,11 @@ prep_plot_vax_gavi <- function( df_combined } +#' @name plot_prep_impact_diagnostics +#' +#' @param df description +#' +#' @export prep_plot_cumul <- function(df, outcome, disease_filter) { outcome_cols <- names(df)[str_detect(names(df), paste0("^", outcome, "_"))] From a455c5ae37ced424d171c57bb5a8ae298425edc6 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 21 Apr 2026 16:31:42 +0100 Subject: [PATCH 13/29] Add constants --- R/constants.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/constants.R b/R/constants.R index adb8175..0dc3a3f 100644 --- a/R/constants.R +++ b/R/constants.R @@ -81,6 +81,11 @@ COLNAMES_INTEREST_PRESSURE_TEST <- union( ) ) +#' @name constants +IMPACT_OUTCOMES <- c("deaths_averted", "dalys_averted") + +IMPACT_GROUP_VARS <- c("activity_type", "vaccine") + #' @name constants EXCLUDED_DISEASES <- c("Hib", "PCV", "Rota", "JE") @@ -110,3 +115,6 @@ DEF_TOUCHSTONE_NEW <- "202310" #' @name constants DEF_TOUCHSTONE_OLD_OLD <- "202110" + +#' @name constants +COLOUR_VIMC <- "#008080" From beb2a0721f50069904f1f6e346132328b704bfff Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 21 Apr 2026 16:32:30 +0100 Subject: [PATCH 14/29] Update plot prep and plot fns --- R/fn_plotting_impact_diagnostics.R | 178 ++++++++---- R/fn_plotting_prep_impact_diagnostics.R | 372 +++++++++++++++--------- 2 files changed, 359 insertions(+), 191 deletions(-) diff --git a/R/fn_plotting_impact_diagnostics.R b/R/fn_plotting_impact_diagnostics.R index 66477a8..bc07b25 100644 --- a/R/fn_plotting_impact_diagnostics.R +++ b/R/fn_plotting_impact_diagnostics.R @@ -1,21 +1,45 @@ -#' Plot significant changes +#' Create impact diagnostics plots #' #' @name plot_impact_diagnostics #' @rdname plot_impact_diagnostics #' #' @importFrom ggplot2 ggplot aes geom_col geom_hline facet_wrap facet_grid #' scale_fill_distiller scale_x_continuous scale_y_continuous labs vars -#' labeller label_wrap_gen +#' labeller label_wrap_gen theme geom_segment geom_point +#' +#' @importFrom rlang .data +#' +#' @description +#' Plotting functions for impact diagnostics. See +#' [plotting-preparation functions][plot_prep_impact_diagnostics] for a set of +#' helper functions that prepare impact diagnostics for plotting. +#' +#' @param data A data.frame that gives the +#' +#' @param outcome #' #' @export -plot_sig_diff <- function(df, outcome) { +plot_sig_diff <- function(data, outcome = IMPACT_OUTCOMES) { + checkmate::assert_tibble(data) + outcome <- rlang::arg_match(outcome, IMPACT_OUTCOMES) + # retained here as this is a small df and a small operation - df$label <- glue::glue( + data$label <- glue::glue( "{df$country_name} | {df$vaccine} | {df$activity_type} | {df$year}" ) - ggplot(df, aes(x = diff, y = reorder(label, diff), color = modelling_group)) + - geom_segment(aes(x = 0, xend = diff, y = label, yend = label), size = 1) + + ggplot( + df, + aes( + .data$diff, + reorder(.data$label, .data$diff), + color = .data$modelling_group + ) + ) + + geom_segment( + aes(x = 0, xend = .data$diff, y = .data$label, yend = .data$label), + size = 1 + ) + geom_point(size = 2) + labs( x = "Difference", @@ -30,25 +54,53 @@ plot_sig_diff <- function(df, outcome) { #' @name plot_impact_diagnostics #' +#' @param group_vars A single string for the grouping variables. May be any of +#' `"activity_type"` and `"vaccine"`. +#' +#' @param touchstone_old A string for the previous touchstone in +#' format `"YYYYMM"`. +#' +#' @param touchstone_new A string for the current or new touchstone in +#' format `"YYYYMM"`. +#' #' @export plot_diff <- function( - combined, - variable, - group_vars = c("activity_type", "vaccine") + data, + outcome = IMPACT_OUTCOMES, + group_vars = IMPACT_GROUP_VARS, + touchstone_old = DEF_TOUCHSTONE_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW ) { - x_var <- paste0(variable, "_new") - y_var <- paste0(variable, "_old") - x_sym <- rlang::sym(x_var) - y_sym <- rlang::sym(y_var) + checkmate::assert_tibble(data) + outcome <- rlang::arg_match(outcome, IMPACT_OUTCOMES) + group_vars <- rlang::arg_match(group_vars, IMPACT_GROUP_VARS, multiple = TRUE) + + touchstone_old <- validate_ts_year(touchstone_old) + touchstone_new <- validate_ts_year(touchstone_new) - combined <- combined %>% - filter(!is.na(!!x_sym) & !is.na(!!y_sym)) + x_var <- glue::glue("{outcome}_new") + y_var <- glue::glue("{outcome}_old") - n_facets <- combined %>% - distinct(activity_type, vaccine) %>% - nrow() + # small operations retained + combined <- dplyr::filter( + combined, + dplyr::filter( + !is.na({{ x_var }}), + !is.na({{ y_var }}) + ) + ) - ncol_dynamic <- case_when( + # nolint start + n_facets <- nrow( + dplyr::distinct( + combined, + .data$activity_type, + .data$vaccine + ) + ) + # nolint end + + ncol_dynamic <- dplyr::case_when( n_facets <= 4 ~ 2, n_facets <= 9 ~ 3, n_facets <= 16 ~ 4, @@ -56,58 +108,62 @@ plot_diff <- function( TRUE ~ 8 ) - p <- ggplot(combined, aes(x = !!x_sym, y = !!y_sym)) + - geom_point(alpha = 0.5, colour = "#008080") + - geom_abline(slope = 1, intercept = 0, linetype = "dashed") + + p <- ggplot( + combined, + aes({{ x_var }}, {{ y_var }}) + ) + + ggplot2::geom_point(alpha = 0.5, colour = COLOUR_VIMC) + + ggplot2::geom_abline(slope = 1, intercept = 0, linetype = "dashed") + facet_wrap( - ~ activity_type + vaccine, + facets = c("activity_type", "vaccine,"), scales = "free", ncol = ncol_dynamic ) + - scale_x_log10() + - scale_y_log10() + - theme_bw() + + ggplot2::scale_x_log10() + + ggplot2::scale_y_log10() + + # TODO: check if VIMC theme okay here + theme_vimc() + theme( - strip.text = element_text(size = 7), - panel.spacing = unit(0.05, "lines"), - axis.text = element_text(size = 6.5) + strip.text = ggplot2::element_text(size = 7), + panel.spacing = ggplot2::unit(0.05, "lines"), + axis.text = ggplot2::element_text(size = 6.5) ) + labs( - title = glue("{variable}: Current vs Previous Report"), - x = glue("{new} - {variable}"), - y = glue("{old} - {variable}") + title = glue::glue("{variable}: Current vs Previous Report"), + x = glue::glue("{new} - {variable}"), + y = glue::glue("{old} - {variable}") ) - return(p) + p } #' @name plot_impact_diagnostics #' #' @export -plot_modelling_group_variation <- function(df, outcome) { - ggplot(df) + +plot_modelling_group_variation <- function(data, outcome) { + ggplot(data) + aes( - fill = as.character(mod_num), - x = adj_outc, - y = reorder(vaccine, mean_outc) + fill = as.character(.data$mod_num), + x = .data$adj_outc, + y = reorder(.data$vaccine, .data$mean_outc) ) + - geom_density_ridges( + ggridges::geom_density_ridges( alpha = 0.5, stat = "binline", bins = 200, draw_baseline = FALSE ) + - facet_grid(. ~ activity_type, scales = "fixed") + - theme_bw() + + facet_grid(cols = ggplot2::vars("activity_type"), scales = "fixed") + + theme_vimc + theme( legend.position = "none", - axis.text.x = element_text(angle = 90, hjust = 1) + axis.text.x = ggplot2::element_text(angle = 90, hjust = 1) ) + - scale_x_log10( + ggplot2::scale_x_log10( breaks = scales::trans_breaks("log10", function(x) 10^x), - labels = scales::trans_format("log10", math_format(10^.x)) + labels = scales::trans_format("log10", scales::math_format(10^.x)) ) + - scale_fill_viridis_d() + + ggplot2::scale_fill_viridis_d() + labs( x = paste0( "Burden averted (", @@ -127,13 +183,13 @@ plot_vaccine_gavi <- function(df, outcome = "deaths_averted") { ggplot( df, aes( - x = reorder(disease, yearly_outcome), - y = yearly_outcome, - fill = factor(year) + x = reorder(.data$disease, .data$yearly_outcome), + y = .data$yearly_outcome, + fill = factor(.data$year) ) ) + geom_col(position = "dodge") + - scale_fill_manual( + ggplot2::scale_fill_manual( values = c( "2021" = "#008080", "2022" = "#E68424", @@ -143,8 +199,8 @@ plot_vaccine_gavi <- function(df, outcome = "deaths_averted") { ) + facet_wrap(~dataset, scales = "free_y") + scale_y_continuous(labels = scales::scientific) + - theme_bw() + - theme(axis.text.x = element_text(angle = 45, hjust = 1)) + + theme_vimc() + + theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) + labs(x = "Disease", y = paste("Impact -", outcome), fill = "Year") } @@ -156,17 +212,19 @@ plot_cumul <- function(df, outcome, disease_filter) { p <- ggplot( df, aes( - x = year, - y = value, - color = modelling_group, - linetype = line_type + x = .data$year, + y = .data$value, + color = .data$modelling_group, + linetype = .data$line_type ) ) + - geom_step(direction = "hv", linewidth = 0.7, alpha = 0.9) + - scale_linetype_manual(values = c("solid" = "solid", "dashed" = "dashed")) + - guides(linetype = "none") + + ggplot2::geom_step(direction = "hv", linewidth = 0.7, alpha = 0.9) + + ggplot2::scale_linetype_manual( + values = c(solid = "solid", dashed = "dashed") + ) + + ggplot2::guides(linetype = "none") + scale_y_continuous(labels = scales::scientific) + - theme_minimal() + + theme_vimc() + labs( x = "Year", y = paste("Cumulative", outcome), @@ -175,5 +233,5 @@ plot_cumul <- function(df, outcome, disease_filter) { ) + theme(legend.position = "bottom") - return(p) + p } diff --git a/R/fn_plotting_prep_impact_diagnostics.R b/R/fn_plotting_prep_impact_diagnostics.R index ca5328b..b999d33 100644 --- a/R/fn_plotting_prep_impact_diagnostics.R +++ b/R/fn_plotting_prep_impact_diagnostics.R @@ -8,70 +8,137 @@ #' plotting functions. These functions have some basic checks on the input data, #' but otherwise assume that users will not modify inputs. #' -#' @param name description +#' @param data A data.frame of impact estimates. #' -#' @return [prep_plot_mod_grp_varn()] returns a ... TODO add +#' @param comparison A data.frame of impact estimates used as a comparator for +#' `comparison`. +#' +#' @param outcome A string for the impact outcome; may be one of +#' "deaths_averted" or "dalys_averted". +#' +#' @return +#' +#' - [prep_plot_mod_grp_varn()] returns a `` TODO add #' #' @export -prep_plot_mod_grp_varn <- function(df2, df3, outc = "deaths") { - offset <- 1e-6 - - df2 %>% - left_join(df3, by = join_by(modelling_group, vaccine)) %>% - mutate(adj_outc = !!as.name(paste0(outc, "_averted")) + offset) %>% - group_by(vaccine) %>% - mutate(mean_outc = weighted.mean(adj_outc, fvps, na.rm = TRUE)) +prep_plot_mod_grp_varn <- function(df2, df3, outcome = IMPACT_OUTCOMES) { + # TODO: df2 and df3 need informative names + + offset_manual <- 1e-6 + df_combined <- dplyr::left_join( + df2, + df3, + by = c("modelling_group", "vaccine") + ) + + df_combined <- dplyr::mutate( + df_combined, + adj_outc = {{ outcome }} + offset_manual + ) + + df_combined <- dplyr::group_by( + df_combined, + .data$vaccine + ) + + df_combined <- dplyr::mutate( + df_combined, + mean_outc = stats::weighted.mean(.data$adj_outc, .data$fvps, na.rm = TRUE) + ) + + df_combined } #' @name plot_prep_impact_diagnostics #' +#' @param data description +#' +#' @param outcome +#' +#' @param disease +#' +#' @param touchstone_old +#' +#' @param touchstone_new +#' #' @return [prep_plot_vax_gavi()] returns a ... TODO add #' #' @export prep_plot_vax_gavi <- function( - df, - prev_dat = NULL, - outcome = "deaths_averted" + data, + prev_data, + outcome = IMPACT_OUTCOMES, + touchstone_old = DEF_TOUCHSTONE_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW ) { - df_cur <- df %>% - select(all_of(key_cols), !!outcome) %>% - filter(year >= 2021, year <= 2024, disease != "COVID") %>% - group_by(disease, year) %>% - summarise( - yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), - .groups = "drop" - ) %>% - mutate(dataset = as.character(new)) - - df_prev <- prev_dat %>% - select(all_of(key_cols), !!outcome) %>% - filter(year >= 2021, year <= 2024, disease != "COVID") %>% - group_by(disease, year) %>% - summarise( - yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), - .groups = "drop" - ) %>% - mutate(dataset = as.character(old)) - - df_combined <- bind_rows(df_cur, df_prev) - - df_diff <- df_cur %>% - left_join( - df_prev, - by = c("disease", "year"), - suffix = c("_curr", "_prev") - ) %>% - mutate( - yearly_outcome = yearly_outcome_curr - yearly_outcome_prev, - dataset = "Difference" - ) %>% - select(disease, year, yearly_outcome, dataset) - - df_combined <- bind_rows(df_combined, df_diff) + checkmate::assert_tibble(data) + checkmate::assert_tibble(prev_data) + outcome <- rlang::arg_match(outcome, IMPACT_OUTCOMES) + touchstone_old <- validate_ts_year(touchstone_old) + touchstone_new <- validate_ts_year(touchstone_new) + + df_list <- Map( + list(data, prev_data), + list(touchstone_new, touchstone_old), + f = function(df, ts_id) { + df <- dplyr::select( + df, + dplyr::all_of(COLNAMES_KEY_PRESSURE_TEST), + {{ outcome }} + ) + + df <- dplyr::filter( + df, + dplyr::between(.data$year, 2021, 2024), + Negate(grepl("COVID", .data$disease, ignore.case = TRUE)) + ) + + df <- dplyr::group_by(df, .data$disease, .data$year) + + df <- dplyr::summarise( + df, + yearly_outcome = sum({{ outcome }}, na.rm = TRUE), + .groups = "drop" + ) + + df <- dplyr::mutate( + df, + dataset = as.character(ts_id) + ) + } + ) + + df_combined <- dplyr::bind_rows(df_list) + + df_diff <- Reduce( + df_list, + f = function(x, y) { + dplyr::left_join( + x, + y, + by = c("disease", "year"), + suffix = c("_curr", "_prev") + ) + } + ) + + df_diff <- dplyr::mutate( + df_diff, + yearly_outcome = .data$yearly_outcome_curr - .data$yearly_outcome_prev, + dataset = "Difference" + ) + cols_to_select <- c("disease", "year", "yearly_outcome", "dataset") + df_diff <- dplyr::select(df_diff, {{ cols_to_select }}) + + df_combined <- dplyr::bind_rows(df_combined, df_diff) df_combined$dataset <- factor( df_combined$dataset, - levels = c(as.character(old), "Difference", as.character(new)) + levels = c( + as.character(touchstone_old), + "Difference", + as.character(touchstone_new) + ) ) df_combined @@ -79,99 +146,142 @@ prep_plot_vax_gavi <- function( #' @name plot_prep_impact_diagnostics #' -#' @param df description +#' @param data description +#' +#' @param outcome +#' +#' @param disease +#' +#' @param touchstone_old +#' +#' @param touchstone_new #' #' @export -prep_plot_cumul <- function(df, outcome, disease_filter) { - outcome_cols <- names(df)[str_detect(names(df), paste0("^", outcome, "_"))] - - outcome_sym <- sym(outcome) - cum_col <- paste0("cum_", outcome) - avg_col <- paste0("avg_", outcome) - - col_old <- paste0(outcome, "_old") - col_new <- paste0(outcome, "_new") - - combined2 <- df %>% - select( - country, - country_name, - disease, - vaccine, - activity_type, - year, - modelling_group, - all_of(outcome_cols) - ) %>% - pivot_longer( - cols = all_of(outcome_cols), - names_to = "touchstone", - values_to = "value" - ) %>% - mutate( - touchstone = str_remove(touchstone, paste0("^", outcome, "_")), - touchstone = recode( - touchstone, - "old" = as.character(old), - "new" = as.character(new), - .default = touchstone - ), - touchstone = factor( - touchstone, - levels = c(as.character(old), as.character(new)) - ) +prep_plot_cumul <- function( + data, + outcome, + disease, + touchstone_old = DEF_TOUCHSTONE_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW +) { + outcome_cols <- colnames(data)[stringr::str_detect( + colnames(data), + glue::glue("^{outcome}_") + )] + + cum_col <- glue::glue("cum_{outcome}") + avg_col <- glue::glue("avg_{outcome}") + + combined2 <- dplyr::select( + data, + {{ COLNAMES_KEY_PRESSURE_TEST }}, + {{ outcome_cols }} + ) + + combined2 <- tidyr::pivot_longer( + combined2, + cols = dplyr::all_of(outcome_cols), + names_to = "touchstone", + values_to = "value" + ) + + combined2 <- dplyr::mutate( + combined2, + touchstone = stringr::str_remove( + .data$touchstone, + glue::glue("^{outcome}_") + ), + touchstone = dplyr::replace_values( + .data$touchstone, + c("old", "new"), + as.character(c(touchstone_old, touchstone_new)), + .default = .data$touchstone + ), + touchstone = factor( + .data$touchstone, + levels = as.character(c(touchstone_old, touchstone_new)) ) + ) + # Cumulative values by modelling group - df_cum <- combined2 %>% - filter(disease == disease_filter) %>% - group_by(modelling_group, touchstone) %>% - complete(year = full_seq(year, 1)) %>% - arrange(year) %>% - mutate( - first_valid = min(year[!is.na(value)]), - !!cum_col := ifelse( - year < first_valid, - NA, - cumsum(replace_na(value, 0)) - ) - ) %>% - select(-first_valid) %>% - ungroup() %>% - mutate(modelling_group = paste(modelling_group, touchstone, sep = "-")) + df_cum <- dplyr::filter(combined2, .data$disease == disease) + df_cum <- dplyr::group_by( + df_cum, + .data$modelling_group, + .data$touchstone + ) + df_cum <- tidyr::complete( + df_cum, + year = tidyr::full_seq(.data$year, 1) + ) + df_cum <- dplyr::arrange(df_cum, .data$year) + df_cum <- dplyr::mutate( + df_cum, + first_valid = min(.data$year[!is.na(data$value)]), + {{ cum_col }} := dplyr::if_else( + .data$year < .data$first_valid, + NA_real_, + cumsum(tidyr::replace_na(.data$value, 0.0)) + ) + ) + + df_cum$first_valid <- NULL + df_cum <- dplyr::ungroup(df_cum) + df_cum <- dplyr::mutate( + df_cum, + modelling_group = glue::glue("{.data$modelling_group}-{.data$touchstone}") + ) # Model average - df_avg <- df_cum %>% - group_by(year, touchstone) %>% - summarise( - !!avg_col := mean(!!sym(cum_col), na.rm = TRUE), - n_models = sum(!is.na(!!sym(cum_col))), - .groups = "drop" - ) %>% - filter(n_models >= 1) %>% - mutate(modelling_group = paste("Model Average", touchstone, sep = "-")) + df_avg <- dplyr::summarise( + df_cum, + {{ avg_col }} := mean({{ cum_col }}, na.rm = TRUE), + n_models = sum(!is.na({{ cum_col }})), + .groups = c("year", "touchstone") + ) + df_avg <- dplyr::filter( + df_avg, + .data$n_models >= 1 + ) + df_avg <- dplyr::mutate( + df_avg, + modelling_group = glue::glue( + "Model Average-{.data$touchstone}" + ) + ) # Combine for plot - df_plot <- bind_rows( - df_cum %>% - select(year, modelling_group, touchstone, value = !!sym(cum_col)), - df_avg %>% - select(year, modelling_group, touchstone, value = !!sym(avg_col)) - ) - - df_plot <- df_plot %>% - group_by(modelling_group) %>% - filter(sum(value, na.rm = TRUE) > 0) %>% - ungroup() %>% - mutate( - line_type = ifelse( - grepl("Model Average", modelling_group), - "dashed", - "solid" - ) + cols_to_select <- c("year", "modelling_group", "touchstone") + df_plot <- dplyr::bind_rows( + dplyr::select( + df_cum, + {{ cols_to_select }}, + value = {{ cum_col }} + ), + dplyr::select( + df_avg, + {{ cols_to_select }}, + value = {{ avg_col }} + ) + ) + + df_plot <- dplyr::group_by(df_plot, .data$modelling_group) + df_plot <- dplyr::filter( + df_plot, + sum(.data$value, na.rm = TRUE) > 0 + ) + df_plot <- dplyr::ungroup(df_plot) + df_plot <- dplyr::mutate( + df_plot, + line_type = dplyr::if_else( + grepl("Model Average", .data$modelling_group, fixed = TRUE), + "dashed", + "solid" ) + ) if (nrow(df_plot) == 0 || all(df_plot$value == 0)) { - message("No non-zero data to plot for ", disease_filter, ". Skipping plot.") + message("No non-zero data to plot for ", disease, ". Skipping plot.") return(NULL) } From 0424f171c438e63ae256283c71e455e004259b56 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 22 Apr 2026 15:55:43 +0100 Subject: [PATCH 15/29] Fixes from initial test run --- R/constants.R | 97 +++++++++++++ R/fn_helpers.R | 11 +- R/fn_plotting_burden_diagnostics.R | 2 +- R/fn_plotting_impact_diagnostics.R | 133 ++++++++++++------ R/fn_plotting_prep_impact_diagnostics.R | 128 +++++++++++------ R/fn_pressure_testing.R | 87 ++++++++---- inst/WORDLIST | 5 +- man/basic_burden_sanity.Rd | 2 +- man/check_demography_alignment.Rd | 2 +- man/compare_natl_subreg.Rd | 2 +- man/constants.Rd | 53 ++++++- man/flag_large_diffs.Rd | 4 +- man/gen_combined_df.Rd | 2 +- man/gen_national_iqr.Rd | 2 +- man/generate_diffs.Rd | 2 +- ...plotting.Rd => plot_burden_diagnostics.Rd} | 8 +- man/plot_impact_diagnostics.Rd | 66 +++++++++ ...rep.Rd => plot_prep_burden_diagnostics.Rd} | 10 +- man/plot_prep_impact_diagnostics.Rd | 82 +++++++++++ man/plotting_theme.Rd | 2 +- man/pres_test_filter_data.Rd | 9 +- man/save_outputs.Rd | 4 +- man/significant_diff_plot.Rd | 12 -- man/validate_complete_incoming_files.Rd | 2 +- man/validate_file_dict_template.Rd | 2 +- man/validate_template_alignment.Rd | 2 +- 26 files changed, 578 insertions(+), 153 deletions(-) rename man/{plotting.Rd => plot_burden_diagnostics.Rd} (91%) create mode 100644 man/plot_impact_diagnostics.Rd rename man/{plotting_prep.Rd => plot_prep_burden_diagnostics.Rd} (87%) create mode 100644 man/plot_prep_impact_diagnostics.Rd delete mode 100644 man/significant_diff_plot.Rd diff --git a/R/constants.R b/R/constants.R index 0dc3a3f..e4c3532 100644 --- a/R/constants.R +++ b/R/constants.R @@ -1,10 +1,17 @@ #' Package constants #' +#' @description +#' Constant values used in _vimcheck_. See the **Examples** section for the +#' constant values. +#' #' @name constants #' @rdname constants #' #' @keywords constants #' +#' @examples +#' file_dict_colnames +#' #' @export file_dict_colnames <- c( "scenario_type", @@ -15,6 +22,11 @@ file_dict_colnames <- c( ) #' @name constants +#' +#' @examples +#' scenario_data_colnames +#' +#' @export scenario_data_colnames <- c( "scenario_type", "scenario_type_description", @@ -23,6 +35,11 @@ scenario_data_colnames <- c( ) #' @name constants +#' +#' @examples +#' burden_outcome_names +#' +#' @export burden_outcome_names <- c( "cases", "deaths", @@ -37,6 +54,11 @@ burden_outcome_names <- c( ) #' @name constants +#' +#' @examples +#' colnames_plot_demog_compare +#' +#' @export colnames_plot_demog_compare <- c( "variable", "scenario", @@ -48,6 +70,11 @@ colnames_plot_demog_compare <- c( ) #' @name constants +#' +#' @examples +#' colnames_df_missing_cols +#' +#' @export colnames_df_missing_cols <- c( "country_name", "vaccine", @@ -57,6 +84,11 @@ colnames_df_missing_cols <- c( ) #' @name constants +#' +#' @examples +#' COLNAMES_KEY_PRESSURE_TEST +#' +#' @export COLNAMES_KEY_PRESSURE_TEST <- c( "country", "country_name", @@ -68,6 +100,11 @@ COLNAMES_KEY_PRESSURE_TEST <- c( ) #' @name constants +#' +#' @examples +#' COLNAMES_INTEREST_PRESSURE_TEST +#' +#' @export COLNAMES_INTEREST_PRESSURE_TEST <- union( COLNAMES_KEY_PRESSURE_TEST, c( @@ -82,39 +119,99 @@ COLNAMES_INTEREST_PRESSURE_TEST <- union( ) #' @name constants +#' +#' @examples +#' IMPACT_OUTCOMES +#' +#' @export IMPACT_OUTCOMES <- c("deaths_averted", "dalys_averted") IMPACT_GROUP_VARS <- c("activity_type", "vaccine") #' @name constants +#' +#' @examples +#' EXCLUDED_DISEASES +#' +#' @export EXCLUDED_DISEASES <- c("Hib", "PCV", "Rota", "JE") #' @name constants +#' +#' @examples +#' N_TS_MIN_CHARS +#' +#' @export N_TS_MIN_CHARS <- 6L #' @name constants +#' +#' @examples +#' N_TS_YEAR_CHARS +#' +#' @export N_TS_YEAR_CHARS <- 4L #' @name constants +#' +#' @examples +#' MIN_TS_YEAR +#' +#' @export MIN_TS_YEAR <- 2000 #' @name constants +#' +#' @examples +#' MAX_TS_YEAR +#' +#' @export MAX_TS_YEAR <- 2100 #' @name constants +#' +#' @examples +#' MIN_TS_MONTH +#' +#' @export MIN_TS_MONTH <- 1 #' @name constants +#' +#' @examples +#' MAX_TS_MONTH +#' +#' @export MAX_TS_MONTH <- 12 #' @name constants +#' +#' @examples +#' DEF_TOUCHSTONE_OLD +#' +#' @export DEF_TOUCHSTONE_OLD <- "201910" #' @name constants +#' +#' @examples +#' DEF_TOUCHSTONE_NEW +#' +#' @export DEF_TOUCHSTONE_NEW <- "202310" #' @name constants +#' +#' @examples +#' DEF_TOUCHSTONE_OLD_OLD +#' +#' @export DEF_TOUCHSTONE_OLD_OLD <- "202110" #' @name constants +#' +#' @examples +#' COLOUR_VIMC +#' +#' @export COLOUR_VIMC <- "#008080" diff --git a/R/fn_helpers.R b/R/fn_helpers.R index 5159361..d3997f8 100644 --- a/R/fn_helpers.R +++ b/R/fn_helpers.R @@ -86,7 +86,8 @@ round_numeric <- function(df) { dplyr::mutate( df, dplyr::across( - .cols = dplyr::where(is.numeric) & !matches("year", ignore.case = TRUE), + .cols = dplyr::where(is.numeric) & + !dplyr::matches("year", ignore.case = TRUE), .fns = adaptive_round ) ) @@ -106,10 +107,10 @@ validate_ts_year <- function(x) { min.chars = N_TS_MIN_CHARS ) if (!has_n_chars) { - n_chars <- nchars(x) + n_chars <- nchar(x) # nolint used in cli cli::cli_abort( - "Touchstone year string should have at least {N_TS_MIN_CHARS}, but got \ - {n_chars} characters." + "Touchstone year should be a string with at least {N_TS_MIN_CHARS} \ + characters, but got class {.cls {class(x)}} with {n_chars} characters." ) } @@ -170,7 +171,7 @@ add_campaign_id <- function(df, key_cols) { must.include = key_cols ) if (!has_cols) { - missing_cols <- setdiff(colnames(df), key_cols) + missing_cols <- setdiff(colnames(df), key_cols) # nolint used in cli cli::cli_abort( "Expected {.code df} to have columns {.str {key_cols}} but columns \ {.str {missing_cols}} are missing." diff --git a/R/fn_plotting_burden_diagnostics.R b/R/fn_plotting_burden_diagnostics.R index 71b7d54..b9a30a6 100644 --- a/R/fn_plotting_burden_diagnostics.R +++ b/R/fn_plotting_burden_diagnostics.R @@ -10,7 +10,7 @@ #' @importFrom rlang .data #' #' @description -#' Plotting functions for burden and impact diagnostics. All functions operate +#' Plotting functions for burden diagnostics. All functions operate #' on data prepared for plotting by a corresponding #' [plotting-preparation function][plot_prep_burden_diagnostics]. #' diff --git a/R/fn_plotting_impact_diagnostics.R b/R/fn_plotting_impact_diagnostics.R index bc07b25..dfb1e8f 100644 --- a/R/fn_plotting_impact_diagnostics.R +++ b/R/fn_plotting_impact_diagnostics.R @@ -1,5 +1,11 @@ #' Create impact diagnostics plots #' +#' @description +#' Functions that create impact diagnostics plots (or plotting objects). All +#' functions are associated with one other upstream data processing function, +#' and can be used in a pipe with that function. Where appropriate, outcome +#' selection and label preparation is automated to reduce function arguments. +#' #' @name plot_impact_diagnostics #' @rdname plot_impact_diagnostics #' @@ -14,9 +20,26 @@ #' [plotting-preparation functions][plot_prep_impact_diagnostics] for a set of #' helper functions that prepare impact diagnostics for plotting. #' -#' @param data A data.frame that gives the +#' @param data A data.frame suitable for plotting. +#' +#' - `plot_sig_diff()`: Output of +#' [`flag_large_diff()`][plot_prep_impact_diagnostics]. +#' +#' - `plot_diff()`: Output of +#' [`gen_combined_df()`][plot_prep_impact_diagnostics]. +#' +#' - `plot_modelling_group_variation()`: Output of +#' [`plot_prep_mod_grp_varn()`][plot_prep_impact_diagnostics]. +#' +#' - `plot_vaccine_gavi()`: Output of +#' [`plot_prep_vax_gavi()`][plot_prep_impact_diagnostics] +#' +#' - `plot_cumul()`: Output of +#' [`plot_prep_cumul()`][plot_prep_impact_diagnostics] #' -#' @param outcome +#' @param outcome A string for the impact outcome. One of [IMPACT_OUTCOMES]. +#' +#' @return A `` object that can be viewed or saved. #' #' @export plot_sig_diff <- function(data, outcome = IMPACT_OUTCOMES) { @@ -25,14 +48,14 @@ plot_sig_diff <- function(data, outcome = IMPACT_OUTCOMES) { # retained here as this is a small df and a small operation data$label <- glue::glue( - "{df$country_name} | {df$vaccine} | {df$activity_type} | {df$year}" + "{data$country_name} | {data$vaccine} | {data$activity_type} | {data$year}" ) ggplot( - df, + data, aes( .data$diff, - reorder(.data$label, .data$diff), + stats::reorder(.data$label, .data$diff), color = .data$modelling_group ) ) + @@ -55,13 +78,13 @@ plot_sig_diff <- function(data, outcome = IMPACT_OUTCOMES) { #' @name plot_impact_diagnostics #' #' @param group_vars A single string for the grouping variables. May be any of -#' `"activity_type"` and `"vaccine"`. +#' [IMPACT_OUTCOMES], which are `"activity_type"` and `"vaccine"`. #' #' @param touchstone_old A string for the previous touchstone in -#' format `"YYYYMM"`. +#' format `"YYYYMM"`. Defaults to [DEF_TOUCHSTONE_OLD]. #' #' @param touchstone_new A string for the current or new touchstone in -#' format `"YYYYMM"`. +#' format `"YYYYMM"`. Defaults to [DEF_TOUCHSTONE_NEW]. #' #' @export plot_diff <- function( @@ -73,7 +96,10 @@ plot_diff <- function( ) { checkmate::assert_tibble(data) outcome <- rlang::arg_match(outcome, IMPACT_OUTCOMES) - group_vars <- rlang::arg_match(group_vars, IMPACT_GROUP_VARS, multiple = TRUE) + checkmate::assert_subset( + group_vars, + IMPACT_GROUP_VARS + ) touchstone_old <- validate_ts_year(touchstone_old) touchstone_new <- validate_ts_year(touchstone_new) @@ -82,18 +108,24 @@ plot_diff <- function( y_var <- glue::glue("{outcome}_old") # small operations retained - combined <- dplyr::filter( - combined, - dplyr::filter( - !is.na({{ x_var }}), - !is.na({{ y_var }}) + # NOTE: data masking using `{{` does not appear to work + # see last example in https://dplyr.tidyverse.org/reference/filter.html + # + # NOTE: exclude values < 1 to prevent log transform errors + data <- dplyr::filter_out( + data, + dplyr::when_any( + is.na(.data[[x_var]]), + is.na(.data[[y_var]]), + .data[[x_var]] < 1, + .data[[y_var]] < 1 ) ) # nolint start n_facets <- nrow( dplyr::distinct( - combined, + data, .data$activity_type, .data$vaccine ) @@ -109,29 +141,28 @@ plot_diff <- function( ) p <- ggplot( - combined, - aes({{ x_var }}, {{ y_var }}) + data, + aes(.data[[x_var]], .data[[y_var]]) ) + ggplot2::geom_point(alpha = 0.5, colour = COLOUR_VIMC) + ggplot2::geom_abline(slope = 1, intercept = 0, linetype = "dashed") + facet_wrap( - facets = c("activity_type", "vaccine,"), + facets = c("activity_type", "vaccine"), scales = "free", ncol = ncol_dynamic ) + ggplot2::scale_x_log10() + ggplot2::scale_y_log10() + - # TODO: check if VIMC theme okay here - theme_vimc() + + theme_vimc(0) + theme( strip.text = ggplot2::element_text(size = 7), panel.spacing = ggplot2::unit(0.05, "lines"), axis.text = ggplot2::element_text(size = 6.5) ) + labs( - title = glue::glue("{variable}: Current vs Previous Report"), - x = glue::glue("{new} - {variable}"), - y = glue::glue("{old} - {variable}") + title = glue::glue("{outcome}: Current vs Previous Report"), + x = glue::glue("{touchstone_new} - {outcome}"), + y = glue::glue("{touchstone_old} - {outcome}") ) p @@ -140,12 +171,29 @@ plot_diff <- function( #' @name plot_impact_diagnostics #' #' @export -plot_modelling_group_variation <- function(data, outcome) { +plot_modelling_group_variation <- function(data) { + checkmate::assert_tibble(data, min.rows = 1L, min.cols = 1L) + + outcome <- unique(data[["outcome_name"]]) + checkmate::assert_string(outcome) + + outcome_short <- stringr::word(outcome, sep = "_") + outcome_short <- dplyr::if_else( + outcome_short == "dalys", + stringr::str_to_upper(outcome_short), + outcome_short + ) + x_lab <- glue::glue("Burden averted ({outcome_short})") + + # for scales formatting + .x <- NULL + + # TODO: should NA-producing values (< 1) be removed? ggplot(data) + aes( fill = as.character(.data$mod_num), x = .data$adj_outc, - y = reorder(.data$vaccine, .data$mean_outc) + y = stats::reorder(.data$vaccine, .data$mean_outc) ) + ggridges::geom_density_ridges( alpha = 0.5, @@ -154,22 +202,18 @@ plot_modelling_group_variation <- function(data, outcome) { draw_baseline = FALSE ) + facet_grid(cols = ggplot2::vars("activity_type"), scales = "fixed") + - theme_vimc + - theme( - legend.position = "none", - axis.text.x = ggplot2::element_text(angle = 90, hjust = 1) - ) + ggplot2::scale_x_log10( breaks = scales::trans_breaks("log10", function(x) 10^x), labels = scales::trans_format("log10", scales::math_format(10^.x)) ) + ggplot2::scale_fill_viridis_d() + + theme_vimc() + + theme( + legend.position = "none", + axis.text.x = ggplot2::element_text(angle = 90, hjust = 1) + ) + labs( - x = paste0( - "Burden averted (", - ifelse(outcome == "dalys", "DALYs", outcome), - ")" - ), + x = x_lab, y = "Vaccine" ) } @@ -179,11 +223,14 @@ plot_modelling_group_variation <- function(data, outcome) { #' @name plot_impact_diagnostics #' #' @export -plot_vaccine_gavi <- function(df, outcome = "deaths_averted") { +plot_vaccine_gavi <- function(data) { + checkmate::assert_tibble(data) + outcome <- unique(data[["outcome_name"]]) + ggplot( - df, + data, aes( - x = reorder(.data$disease, .data$yearly_outcome), + x = stats::reorder(.data$disease, .data$yearly_outcome), y = .data$yearly_outcome, fill = factor(.data$year) ) @@ -208,9 +255,13 @@ plot_vaccine_gavi <- function(df, outcome = "deaths_averted") { #' @name plot_impact_diagnostics #' #' @export -plot_cumul <- function(df, outcome, disease_filter) { +plot_cumul <- function(data) { + checkmate::assert_tibble(data) + outcome <- unique(data[["outcome_name"]]) + disease <- unique(data[["disease"]]) + p <- ggplot( - df, + data, aes( x = .data$year, y = .data$value, @@ -229,7 +280,7 @@ plot_cumul <- function(df, outcome, disease_filter) { x = "Year", y = paste("Cumulative", outcome), color = "Modelling Group", - title = paste("Cumulative", outcome, "Over Time –", disease_filter) + title = paste("Cumulative", outcome, "Over Time -", disease) ) + theme(legend.position = "bottom") diff --git a/R/fn_plotting_prep_impact_diagnostics.R b/R/fn_plotting_prep_impact_diagnostics.R index b999d33..d529d7d 100644 --- a/R/fn_plotting_prep_impact_diagnostics.R +++ b/R/fn_plotting_prep_impact_diagnostics.R @@ -5,24 +5,69 @@ #' #' @description #' A suite of helper functions that sit between impact diagnostics functions and -#' plotting functions. These functions have some basic checks on the input data, -#' but otherwise assume that users will not modify inputs. +#' plotting functions. These functions transform and aggregate impact estimates +#' to prepare them for visualisation. Functions have basic checks on input data +#' but otherwise assume users will not modify inputs. #' -#' @param data A data.frame of impact estimates. +#' @param df2 A `` of impact estimates with at least columns +#' `modelling_group`, `vaccine`, outcome variable, and `fvps` (doses +#' delivered). Used as the primary data source for calculations in +#' [prep_plot_mod_grp_varn()]. #' -#' @param comparison A data.frame of impact estimates used as a comparator for -#' `comparison`. +#' @param df3 A `` of modelling group and vaccine combinations, +#' typically with one row per modelling group per vaccine. Joined with `df2` +#' to ensure complete group coverage in [prep_plot_mod_grp_varn()]. #' -#' @param outcome A string for the impact outcome; may be one of -#' "deaths_averted" or "dalys_averted". +#' @param data A `` of impact estimates with columns including at least +#' those in [COLNAMES_KEY_PRESSURE_TEST], the outcome variable, and +#' potentially outcome-specific columns (for [prep_plot_cumul()]). Used in +#' [prep_plot_vax_gavi()] and [prep_plot_cumul()]. +#' +#' @param prev_data A `` of impact estimates from a previous touchstone, +#' used as a comparison baseline in [prep_plot_vax_gavi()]. Should have the +#' same structure as `data`. +#' +#' @param outcome A character string for the impact outcome. Must be one of +#' `"deaths_averted"` or `"dalys_averted"`. For [prep_plot_cumul()], +#' `data` must include columns named `{outcome}_old` and `{outcome}_new`. +#' +#' @param disease A character string specifying a single disease for filtering +#' in [prep_plot_cumul()]. +#' +#' @param touchstone_old A six-character touchstone identifier (YYYYMM format) +#' for the previous dataset. Defaults to [DEF_TOUCHSTONE_OLD]. Used in +#' [prep_plot_vax_gavi()] and [prep_plot_cumul()]. +#' +#' @param touchstone_new A six-character touchstone identifier (YYYYMM format) +#' for the current dataset. Defaults to [DEF_TOUCHSTONE_NEW]. Used in +#' [prep_plot_vax_gavi()] and [prep_plot_cumul()]. +#' +#' @importFrom rlang := #' #' @return #' -#' - [prep_plot_mod_grp_varn()] returns a `` TODO add +#' - [prep_plot_mod_grp_varn()] returns a grouped `` (grouped by +#' `vaccine`) with all columns from `df2` and `df3` plus derived columns: +#' `adj_outc` (adjusted outcome with small offset), `outcome_name` (input +#' outcome), and `mean_outc` (vaccine-level weighted mean outcome). +#' +#' - [prep_plot_vax_gavi()] returns a `` with columns `disease`, +#' `year`, `yearly_outcome`, `dataset` (factor with levels for old touchstone, +#' "Difference", and new touchstone), and `outcome_name`. Summarizes outcomes +#' by disease and year across two touchstones. +#' +#' - [prep_plot_cumul()] returns a `` with columns `year`, +#' `modelling_group`, `touchstone`, `value` (cumulative or average outcome), +#' `line_type` ("solid" for individual models, "dashed" for model average), +#' and `outcome_name`. Returns `NULL` if the specified disease has no non-zero +#' data to plot. #' #' @export prep_plot_mod_grp_varn <- function(df2, df3, outcome = IMPACT_OUTCOMES) { - # TODO: df2 and df3 need informative names + checkmate::assert_tibble(df2, min.rows = 1L, min.cols = 1L) + checkmate::assert_tibble(df3, min.rows = 1L, min.cols = 1L) + + outcome <- rlang::arg_match(outcome, IMPACT_OUTCOMES) offset_manual <- 1e-6 df_combined <- dplyr::left_join( @@ -33,7 +78,8 @@ prep_plot_mod_grp_varn <- function(df2, df3, outcome = IMPACT_OUTCOMES) { df_combined <- dplyr::mutate( df_combined, - adj_outc = {{ outcome }} + offset_manual + adj_outc = .data[[outcome]] + offset_manual, + outcome_name = outcome ) df_combined <- dplyr::group_by( @@ -51,17 +97,12 @@ prep_plot_mod_grp_varn <- function(df2, df3, outcome = IMPACT_OUTCOMES) { #' @name plot_prep_impact_diagnostics #' -#' @param data description -#' -#' @param outcome -#' -#' @param disease -#' -#' @param touchstone_old -#' -#' @param touchstone_new +#' @param data A `` of impact estimates with columns including at least +#' those in [COLNAMES_KEY_PRESSURE_TEST], the outcome variable, and +#' potentially other columns for analysis. #' -#' @return [prep_plot_vax_gavi()] returns a ... TODO add +#' @param prev_data A `` of impact estimates from a previous touchstone, +#' used as a comparison baseline. Should have the same structure as `data`. #' #' @export prep_plot_vax_gavi <- function( @@ -89,15 +130,19 @@ prep_plot_vax_gavi <- function( df <- dplyr::filter( df, - dplyr::between(.data$year, 2021, 2024), - Negate(grepl("COVID", .data$disease, ignore.case = TRUE)) + dplyr::between(.data$year, 2021, 2024) + ) + + df <- dplyr::filter_out( + df, + grepl("COVID", .data$disease, ignore.case = TRUE) ) df <- dplyr::group_by(df, .data$disease, .data$year) df <- dplyr::summarise( df, - yearly_outcome = sum({{ outcome }}, na.rm = TRUE), + yearly_outcome = sum(.data[[outcome]], na.rm = TRUE), .groups = "drop" ) @@ -141,20 +186,15 @@ prep_plot_vax_gavi <- function( ) ) + df_combined$outcome_name <- outcome + df_combined } #' @name plot_prep_impact_diagnostics #' -#' @param data description -#' -#' @param outcome -#' -#' @param disease -#' -#' @param touchstone_old -#' -#' @param touchstone_new +#' @param disease A character string specifying a single disease for filtering +#' and analysis. #' #' @export prep_plot_cumul <- function( @@ -164,6 +204,12 @@ prep_plot_cumul <- function( touchstone_old = DEF_TOUCHSTONE_OLD, touchstone_new = DEF_TOUCHSTONE_NEW ) { + checkmate::assert_tibble(data) + checkmate::assert_subset( + outcome, + IMPACT_OUTCOMES + ) + outcome_cols <- colnames(data)[stringr::str_detect( colnames(data), glue::glue("^{outcome}_") @@ -177,6 +223,7 @@ prep_plot_cumul <- function( {{ COLNAMES_KEY_PRESSURE_TEST }}, {{ outcome_cols }} ) + combined2 <- combined2[combined2$disease == disease, ] combined2 <- tidyr::pivot_longer( combined2, @@ -193,9 +240,8 @@ prep_plot_cumul <- function( ), touchstone = dplyr::replace_values( .data$touchstone, - c("old", "new"), - as.character(c(touchstone_old, touchstone_new)), - .default = .data$touchstone + from = c("old", "new"), + to = as.character(c(touchstone_old, touchstone_new)) ), touchstone = factor( .data$touchstone, @@ -204,9 +250,8 @@ prep_plot_cumul <- function( ) # Cumulative values by modelling group - df_cum <- dplyr::filter(combined2, .data$disease == disease) df_cum <- dplyr::group_by( - df_cum, + combined2, .data$modelling_group, .data$touchstone ) @@ -217,7 +262,7 @@ prep_plot_cumul <- function( df_cum <- dplyr::arrange(df_cum, .data$year) df_cum <- dplyr::mutate( df_cum, - first_valid = min(.data$year[!is.na(data$value)]), + first_valid = min(.data$year[!is.na(.data$value)]), {{ cum_col }} := dplyr::if_else( .data$year < .data$first_valid, NA_real_, @@ -237,7 +282,7 @@ prep_plot_cumul <- function( df_cum, {{ avg_col }} := mean({{ cum_col }}, na.rm = TRUE), n_models = sum(!is.na({{ cum_col }})), - .groups = c("year", "touchstone") + .by = c("year", "touchstone") ) df_avg <- dplyr::filter( df_avg, @@ -280,10 +325,13 @@ prep_plot_cumul <- function( ) ) + # add outcome name + df_plot$outcome_name <- outcome + if (nrow(df_plot) == 0 || all(df_plot$value == 0)) { message("No non-zero data to plot for ", disease, ". Skipping plot.") return(NULL) } - df_plot + tibble::as_tibble(df_plot) } diff --git a/R/fn_pressure_testing.R b/R/fn_pressure_testing.R index fbcc3fb..c5c9a1f 100644 --- a/R/fn_pressure_testing.R +++ b/R/fn_pressure_testing.R @@ -11,7 +11,8 @@ #' checked for contents #' #' @param threshold A six-digit number that is checked as a valid touchstone -#' identifier (YYYYMM format) using [validate_ts_year()]. +#' identifier (YYYYMM format) using [validate_ts_year()]. Defaults to +#' [DEF_TOUCHSTONE_NEW] (`"202310"`). #' #' @keywords impact_diagnostics #' @@ -31,7 +32,7 @@ #' (`NA` to non-`NA`) removed. #' #' @export -filter_recent_ts <- function(df, threshold = 202310) { +filter_recent_ts <- function(df, threshold = DEF_TOUCHSTONE_NEW) { checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 1L) checkmate::assert_names( names(df), @@ -58,7 +59,10 @@ filter_recent_ts <- function(df, threshold = 202310) { #' @name pres_test_filter_data #' #' @export -filter_excluded_diseases_ts <- function(df, threshold = 202110) { +filter_excluded_diseases_ts <- function( + df, + threshold = DEF_TOUCHSTONE_OLD_OLD +) { checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 1L) checkmate::assert_names( names(df), @@ -123,10 +127,9 @@ filter_invalid_trajectories <- function( ) { checkmate::assert_data_frame(df, min.cols = 1L, min.rows = 1L) - # TODO: can we assume prev_data is at least the size of df? + # TODO: can we find checks for prev_data size in reln to df? rows? cols? checkmate::assert_data_frame( prev_data, - min.cols = ncol(df), min.rows = nrow(df) ) @@ -226,11 +229,11 @@ generate_diffs <- function( # check interest cols in dfs. key cols are check in `add_campaign_id` checkmate::assert_names( colnames(prev_df), - interest_cols + must.include = interest_cols ) checkmate::assert_names( colnames(curr_df), - interest_cols + must.include = interest_cols ) touchstone <- validate_ts_year(touchstone) @@ -267,7 +270,7 @@ generate_diffs <- function( interest_cols ) - changes + tibble::as_tibble(changes) } #' Generate IQR for key outcomes @@ -300,10 +303,9 @@ gen_national_iqr <- function( checkmate::assert_character(group_cols, min.len = 1L, any.missing = FALSE) # NOTE: restricting value columns to deaths and dalys averted - value_cols <- rlang::arg_match( + checkmate::assert_subset( value_cols, - c("deaths_averted", "dalys_averted"), - multiple = TRUE + c("deaths_averted", "dalys_averted") ) checkmate::assert_string(prefix) @@ -325,6 +327,8 @@ gen_national_iqr <- function( ), .groups = "drop" ) + + tibble::as_tibble(df) } #' Flag significant changes in impact estimates @@ -341,7 +345,7 @@ gen_national_iqr <- function( #' [gen_national_iqr()]. #' #' @param variable A string specifying the variable of interest. Must be one of -#' "deaths_averted" and "dalys_averted", and must be present as a name and +#' "deaths_averted" or "dalys_averted", and must be present as a name and #' element of `changes_list`. #' #' @inheritParams gen_national_iqr @@ -370,7 +374,7 @@ flag_large_diffs <- function( touchstone_old = DEF_TOUCHSTONE_OLD_OLD, touchstone_new = DEF_TOUCHSTONE_NEW ) { - checkmate::assert_list(changes_list, "data.frame") + checkmate::assert_list(changes_list, c("data.frame", "NULL")) checkmate::assert_data_frame(iqr_df, min.rows = 1L, min.cols = 1L) variable <- rlang::arg_match(variable) @@ -454,7 +458,9 @@ flag_large_diffs <- function( rename_lookup ) - dplyr::arrange(df_compare, dplyr::desc(diff)) + df_compare <- dplyr::arrange(df_compare, dplyr::desc(diff)) + + tibble::as_tibble(df_compare) } #' Combine and align data from two touchstones @@ -492,15 +498,13 @@ gen_combined_df <- function( min.rows = 1L ) - # TODO: df2 needs a better name - prev_df <- dplyr::select(prev_dat, {{ interest_cols }}) - cur_df <- dplyr::select(df2, {{ interest_cols }}) - - combined <- dplyr::full_join( - prev_df, - cur_df, - by = key_cols, - suffix = c("_old", "_new") + checkmate::assert_subset( + interest_cols, + COLNAMES_INTEREST_PRESSURE_TEST + ) + checkmate::assert_subset( + key_cols, + COLNAMES_KEY_PRESSURE_TEST ) cols_to_select <- c( @@ -517,10 +521,37 @@ gen_combined_df <- function( "dalys_averted_new" ) - dplyr::select( + checkmate::assert_names( + colnames(prev_dat), + must.include = c(interest_cols, key_cols) + ) + checkmate::assert_names( + colnames(df2), + must.include = c(interest_cols, key_cols) + ) + + # TODO: df2 needs a better name + prev_df <- dplyr::select(prev_dat, {{ interest_cols }}) + cur_df <- dplyr::select(df2, {{ interest_cols }}) + + combined <- dplyr::full_join( + prev_df, + cur_df, + by = key_cols, + suffix = c("_old", "_new") + ) + + checkmate::assert_names( + colnames(combined), + must.include = cols_to_select + ) + + combined <- dplyr::select( combined, - {{ cols_to_select }} + dplyr::all_of(cols_to_select) ) + + tibble::as_tibble(combined) } #' Compare sub-regional and national estimates @@ -572,7 +603,7 @@ compare_natl_subreg <- function( subregional_summary <- dplyr::summarise( subregional_summary, subregional_mean = mean(.data[[outcome]], na.rm = TRUE), - subregional_iqr = IQR(.data[[outcome]], na.rm = TRUE), + subregional_iqr = stats::IQR(.data[[outcome]], na.rm = TRUE), .groups = "drop" ) @@ -614,7 +645,7 @@ compare_natl_subreg <- function( comparison <- dplyr::select(comparison, {{ cols_to_select }}) comparison <- dplyr::arrange(comparison, dplyr::desc(.data$iqr_score)) - comparison + tibble::as_tibble(comparison) } #' Save pressure-testing diagnostics to local file @@ -654,6 +685,8 @@ compare_natl_subreg <- function( #' [compare_natl_subreg()] with the outcome `"dalys_averted_rate"` for the #' `"campaign"` activity type. #' +#' @param output_dir A writeable directory. Defaults to "./outputs". +#' #' @return None. Called for the convenience side-effect of saving data.frames as #' `.Rds` format. #' diff --git a/inst/WORDLIST b/inst/WORDLIST index 69da54f..e9a14dc 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -19,9 +19,12 @@ VIMC WIP WPP YLLs +YYYYMM autogenerated +dalys +erroring facetted ggplot +iqr tibble tibbles -timeseries diff --git a/man/basic_burden_sanity.Rd b/man/basic_burden_sanity.Rd index 004cffd..035018f 100644 --- a/man/basic_burden_sanity.Rd +++ b/man/basic_burden_sanity.Rd @@ -18,4 +18,4 @@ estimates, with the length of the vector depending on how many checks fail. Helper function for sanity checks on burden estimate values. Checks whether any burden estimates are non-numeric, missing, or negative. } -\keyword{diagnostics} +\keyword{burden_diagnostics} diff --git a/man/check_demography_alignment.Rd b/man/check_demography_alignment.Rd index 5afb1f0..d5fecd9 100644 --- a/man/check_demography_alignment.Rd +++ b/man/check_demography_alignment.Rd @@ -27,4 +27,4 @@ modelled population size from the WPP-derived population estimates. Check the modelled disease burden data has similar population sizes as the provided population data. } -\keyword{diagnostics} +\keyword{burden_diagnostics} diff --git a/man/compare_natl_subreg.Rd b/man/compare_natl_subreg.Rd index ecf5cea..7f4c60e 100644 --- a/man/compare_natl_subreg.Rd +++ b/man/compare_natl_subreg.Rd @@ -27,4 +27,4 @@ impact is considered to be outside the tolerance limit. \description{ Compare sub-regional and national estimates } -\keyword{pressure_testing} +\keyword{impact_diagnostics} diff --git a/man/constants.Rd b/man/constants.Rd index 8faa19a..1d93a1f 100644 --- a/man/constants.Rd +++ b/man/constants.Rd @@ -10,6 +10,7 @@ \alias{colnames_df_missing_cols} \alias{COLNAMES_KEY_PRESSURE_TEST} \alias{COLNAMES_INTEREST_PRESSURE_TEST} +\alias{IMPACT_OUTCOMES} \alias{EXCLUDED_DISEASES} \alias{N_TS_MIN_CHARS} \alias{N_TS_YEAR_CHARS} @@ -20,6 +21,7 @@ \alias{DEF_TOUCHSTONE_OLD} \alias{DEF_TOUCHSTONE_NEW} \alias{DEF_TOUCHSTONE_OLD_OLD} +\alias{COLOUR_VIMC} \title{Package constants} \format{ An object of class \code{character} of length 5. @@ -36,6 +38,8 @@ An object of class \code{character} of length 7. An object of class \code{character} of length 14. +An object of class \code{character} of length 2. + An object of class \code{character} of length 4. An object of class \code{integer} of length 1. @@ -54,6 +58,8 @@ An object of class \code{character} of length 1. An object of class \code{character} of length 1. +An object of class \code{character} of length 1. + An object of class \code{character} of length 1. } \usage{ @@ -71,6 +77,8 @@ COLNAMES_KEY_PRESSURE_TEST COLNAMES_INTEREST_PRESSURE_TEST +IMPACT_OUTCOMES + EXCLUDED_DISEASES N_TS_MIN_CHARS @@ -90,9 +98,52 @@ DEF_TOUCHSTONE_OLD DEF_TOUCHSTONE_NEW DEF_TOUCHSTONE_OLD_OLD + +COLOUR_VIMC } \description{ -Package constants +Constant values used in \emph{vimcheck}. See the \strong{Examples} section for the +constant values. +} +\examples{ +file_dict_colnames + +scenario_data_colnames + +burden_outcome_names + +colnames_plot_demog_compare + +colnames_df_missing_cols + +COLNAMES_KEY_PRESSURE_TEST + +COLNAMES_INTEREST_PRESSURE_TEST + +IMPACT_OUTCOMES + +EXCLUDED_DISEASES + +N_TS_MIN_CHARS + +N_TS_YEAR_CHARS + +MIN_TS_YEAR + +MAX_TS_YEAR + +MIN_TS_MONTH + +MAX_TS_MONTH + +DEF_TOUCHSTONE_OLD + +DEF_TOUCHSTONE_NEW + +DEF_TOUCHSTONE_OLD_OLD + +COLOUR_VIMC + } \keyword{constants} \keyword{datasets} diff --git a/man/flag_large_diffs.Rd b/man/flag_large_diffs.Rd index e0379b1..fcc5039 100644 --- a/man/flag_large_diffs.Rd +++ b/man/flag_large_diffs.Rd @@ -22,7 +22,7 @@ interest (see \code{variable}). Usually generated using \code{\link[=generate_di \code{\link[=gen_national_iqr]{gen_national_iqr()}}.} \item{variable}{A string specifying the variable of interest. Must be one of -"deaths_averted" and "dalys_averted", and must be present as a name and +"deaths_averted" or "dalys_averted", and must be present as a name and element of \code{changes_list}.} \item{group_cols}{A character vector of grouping columns. Defaults to @@ -47,4 +47,4 @@ between touchstones is greater than expected. A row is flagged if the difference is greater than \code{threshold} \eqn{\times} the inter-quartile range for cases where the IQR is greater than zero. } -\keyword{pressure_testing} +\keyword{impact_diagnostics} diff --git a/man/gen_combined_df.Rd b/man/gen_combined_df.Rd index 9a329d3..b3f53f0 100644 --- a/man/gen_combined_df.Rd +++ b/man/gen_combined_df.Rd @@ -31,4 +31,4 @@ are disambiguated with the suffixes \code{"_old"} and \code{"_new"}. \description{ Generates a full join of two data.frames, selecting for columns of interest. } -\keyword{pressure_testing} +\keyword{impact_diagnostics} diff --git a/man/gen_national_iqr.Rd b/man/gen_national_iqr.Rd index c722e66..4257953 100644 --- a/man/gen_national_iqr.Rd +++ b/man/gen_national_iqr.Rd @@ -31,4 +31,4 @@ using string interpolation. \description{ Generate IQR for key outcomes } -\keyword{pressure_testing} +\keyword{impact_diagnostics} diff --git a/man/generate_diffs.Rd b/man/generate_diffs.Rd index 17fcf32..4e4607e 100644 --- a/man/generate_diffs.Rd +++ b/man/generate_diffs.Rd @@ -36,4 +36,4 @@ with one list element per element of \code{interest_cols}. \description{ Explore significant changes in deaths and DALYs } -\keyword{pressure_testing} +\keyword{impact_diagnostics} diff --git a/man/plotting.Rd b/man/plot_burden_diagnostics.Rd similarity index 91% rename from man/plotting.Rd rename to man/plot_burden_diagnostics.Rd index 7f915a3..8431edd 100644 --- a/man/plotting.Rd +++ b/man/plot_burden_diagnostics.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn_plotting_burden_diagnostics.R -\name{plotting} -\alias{plotting} +\name{plot_burden_diagnostics} +\alias{plot_burden_diagnostics} \alias{plot_compare_demography} \alias{plot_age_patterns} \alias{plot_global_burden_decades} @@ -55,8 +55,8 @@ A \verb{} object that can be printed to screen in the plot frame or saved to an output device (i.e., saved as an image file). } \description{ -Plotting functions for burden and impact diagnostics. All functions operate +Plotting functions for burden diagnostics. All functions operate on data prepared for plotting by a corresponding -\link[=plotting_prep]{plotting-preparation function}. +\link[=plot_prep_burden_diagnostics]{plotting-preparation function}. } \keyword{plotting} diff --git a/man/plot_impact_diagnostics.Rd b/man/plot_impact_diagnostics.Rd new file mode 100644 index 0000000..c195f97 --- /dev/null +++ b/man/plot_impact_diagnostics.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_plotting_impact_diagnostics.R +\name{plot_impact_diagnostics} +\alias{plot_impact_diagnostics} +\alias{plot_sig_diff} +\alias{plot_diff} +\alias{plot_modelling_group_variation} +\alias{plot_vaccine_gavi} +\alias{plot_cumul} +\title{Create impact diagnostics plots} +\usage{ +plot_sig_diff(data, outcome = IMPACT_OUTCOMES) + +plot_diff( + data, + outcome = IMPACT_OUTCOMES, + group_vars = IMPACT_GROUP_VARS, + touchstone_old = DEF_TOUCHSTONE_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW +) + +plot_modelling_group_variation(data) + +plot_vaccine_gavi(data) + +plot_cumul(data) +} +\arguments{ +\item{data}{A data.frame suitable for plotting. +\itemize{ +\item \code{plot_sig_diff()}: Output of +\code{\link[=plot_prep_impact_diagnostics]{flag_large_diff()}}. +\item \code{plot_diff()}: Output of +\code{\link[=plot_prep_impact_diagnostics]{gen_combined_df()}}. +\item \code{plot_modelling_group_variation()}: Output of +\code{\link[=plot_prep_impact_diagnostics]{plot_prep_mod_grp_varn()}}. +\item \code{plot_vaccine_gavi()}: Output of +\code{\link[=plot_prep_impact_diagnostics]{plot_prep_vax_gavi()}} +\item \code{plot_cumul()}: Output of +\code{\link[=plot_prep_impact_diagnostics]{plot_prep_cumul()}} +}} + +\item{outcome}{A string for the impact outcome. One of \link{IMPACT_OUTCOMES}.} + +\item{group_vars}{A single string for the grouping variables. May be any of +\link{IMPACT_OUTCOMES}, which are \code{"activity_type"} and \code{"vaccine"}.} + +\item{touchstone_old}{A string for the previous touchstone in +format \code{"YYYYMM"}. Defaults to \link{DEF_TOUCHSTONE_OLD}.} + +\item{touchstone_new}{A string for the current or new touchstone in +format \code{"YYYYMM"}. Defaults to \link{DEF_TOUCHSTONE_NEW}.} +} +\value{ +A \verb{} object that can be viewed or saved. +} +\description{ +Functions that create impact diagnostics plots (or plotting objects). All +functions are associated with one other upstream data processing function, +and can be used in a pipe with that function. Where appropriate, outcome +selection and label preparation is automated to reduce function arguments. + +Plotting functions for impact diagnostics. See +\link[=plot_prep_impact_diagnostics]{plotting-preparation functions} for a set of +helper functions that prepare impact diagnostics for plotting. +} diff --git a/man/plotting_prep.Rd b/man/plot_prep_burden_diagnostics.Rd similarity index 87% rename from man/plotting_prep.Rd rename to man/plot_prep_burden_diagnostics.Rd index f8124bc..3afa707 100644 --- a/man/plotting_prep.Rd +++ b/man/plot_prep_burden_diagnostics.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fn_plotting_prep_bur_diag.R -\name{plotting_prep} -\alias{plotting_prep} +\name{plot_prep_burden_diagnostics} +\alias{plot_prep_burden_diagnostics} \alias{prep_plot_demography} \alias{prep_plot_age} \alias{prep_plot_burden_decades} @@ -53,6 +53,8 @@ column "burden_outcome", and a list column of tibbles "burden_data". } \description{ Transform burden estimate data from modelling groups to make them suitable -for plotting using an appropriate \link[=plotting]{plotting function}. Each -preparation function corresponds to a plotting function. +for plotting using an appropriate +\link[=plot_prep_burden_diagnostics]{plotting function}. Each preparation function +corresponds to a plotting function. } +\keyword{plot_prep_burden_diagnostics} diff --git a/man/plot_prep_impact_diagnostics.Rd b/man/plot_prep_impact_diagnostics.Rd new file mode 100644 index 0000000..7afc4f1 --- /dev/null +++ b/man/plot_prep_impact_diagnostics.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fn_plotting_prep_impact_diagnostics.R +\name{plot_prep_impact_diagnostics} +\alias{plot_prep_impact_diagnostics} +\alias{prep_plot_mod_grp_varn} +\alias{prep_plot_vax_gavi} +\alias{prep_plot_cumul} +\title{Prepare impact diagnostics for plotting} +\usage{ +prep_plot_mod_grp_varn(df2, df3, outcome = IMPACT_OUTCOMES) + +prep_plot_vax_gavi( + data, + prev_data, + outcome = IMPACT_OUTCOMES, + touchstone_old = DEF_TOUCHSTONE_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW +) + +prep_plot_cumul( + data, + outcome, + disease, + touchstone_old = DEF_TOUCHSTONE_OLD, + touchstone_new = DEF_TOUCHSTONE_NEW +) +} +\arguments{ +\item{df2}{A \verb{} of impact estimates with at least columns +\code{modelling_group}, \code{vaccine}, outcome variable, and \code{fvps} (doses +delivered). Used as the primary data source for calculations in +\code{\link[=prep_plot_mod_grp_varn]{prep_plot_mod_grp_varn()}}.} + +\item{df3}{A \verb{} of modelling group and vaccine combinations, +typically with one row per modelling group per vaccine. Joined with \code{df2} +to ensure complete group coverage in \code{\link[=prep_plot_mod_grp_varn]{prep_plot_mod_grp_varn()}}.} + +\item{outcome}{A character string for the impact outcome. Must be one of +\code{"deaths_averted"} or \code{"dalys_averted"}. For \code{\link[=prep_plot_cumul]{prep_plot_cumul()}}, +\code{data} must include columns named \verb{\{outcome\}_old} and \verb{\{outcome\}_new}.} + +\item{data}{A \verb{} of impact estimates with columns including at least +those in \link{COLNAMES_KEY_PRESSURE_TEST}, the outcome variable, and +potentially other columns for analysis.} + +\item{prev_data}{A \verb{} of impact estimates from a previous touchstone, +used as a comparison baseline. Should have the same structure as \code{data}.} + +\item{touchstone_old}{A six-character touchstone identifier (YYYYMM format) +for the previous dataset. Defaults to \link{DEF_TOUCHSTONE_OLD}. Used in +\code{\link[=prep_plot_vax_gavi]{prep_plot_vax_gavi()}} and \code{\link[=prep_plot_cumul]{prep_plot_cumul()}}.} + +\item{touchstone_new}{A six-character touchstone identifier (YYYYMM format) +for the current dataset. Defaults to \link{DEF_TOUCHSTONE_NEW}. Used in +\code{\link[=prep_plot_vax_gavi]{prep_plot_vax_gavi()}} and \code{\link[=prep_plot_cumul]{prep_plot_cumul()}}.} + +\item{disease}{A character string specifying a single disease for filtering +and analysis.} +} +\value{ +\itemize{ +\item \code{\link[=prep_plot_mod_grp_varn]{prep_plot_mod_grp_varn()}} returns a grouped \verb{} (grouped by +\code{vaccine}) with all columns from \code{df2} and \code{df3} plus derived columns: +\code{adj_outc} (adjusted outcome with small offset), \code{outcome_name} (input +outcome), and \code{mean_outc} (vaccine-level weighted mean outcome). +\item \code{\link[=prep_plot_vax_gavi]{prep_plot_vax_gavi()}} returns a \verb{} with columns \code{disease}, +\code{year}, \code{yearly_outcome}, \code{dataset} (factor with levels for old touchstone, +"Difference", and new touchstone), and \code{outcome_name}. Summarizes outcomes +by disease and year across two touchstones. +\item \code{\link[=prep_plot_cumul]{prep_plot_cumul()}} returns a \verb{} with columns \code{year}, +\code{modelling_group}, \code{touchstone}, \code{value} (cumulative or average outcome), +\code{line_type} ("solid" for individual models, "dashed" for model average), +and \code{outcome_name}. Returns \code{NULL} if the specified disease has no non-zero +data to plot. +} +} +\description{ +A suite of helper functions that sit between impact diagnostics functions and +plotting functions. These functions transform and aggregate impact estimates +to prepare them for visualisation. Functions have basic checks on input data +but otherwise assume users will not modify inputs. +} diff --git a/man/plotting_theme.Rd b/man/plotting_theme.Rd index fe46d78..0e95add 100644 --- a/man/plotting_theme.Rd +++ b/man/plotting_theme.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_plotting_burden_diagnostics.R +% Please edit documentation in R/fn_plotting_helpers.R \name{plotting_theme} \alias{plotting_theme} \alias{theme_vimc} diff --git a/man/pres_test_filter_data.Rd b/man/pres_test_filter_data.Rd index 003617a..27b1d43 100644 --- a/man/pres_test_filter_data.Rd +++ b/man/pres_test_filter_data.Rd @@ -8,9 +8,9 @@ \alias{filter_invalid_trajectories} \title{Filter data for touchstones or diseases} \usage{ -filter_recent_ts(df, threshold = 202310) +filter_recent_ts(df, threshold = DEF_TOUCHSTONE_NEW) -filter_excluded_diseases_ts(df, threshold = 202110) +filter_excluded_diseases_ts(df, threshold = DEF_TOUCHSTONE_OLD_OLD) filter_duplicates(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) @@ -25,7 +25,8 @@ filter_invalid_trajectories( checked for contents} \item{threshold}{A six-digit number that is checked as a valid touchstone -identifier (YYYYMM format) using \code{\link[=validate_ts_year]{validate_ts_year()}}.} +identifier (YYYYMM format) using \code{\link[=validate_ts_year]{validate_ts_year()}}. Defaults to +\link{DEF_TOUCHSTONE_NEW} (\code{"202310"}).} \item{key_cols}{Key columns in \code{df} to check for duplicates.} @@ -53,4 +54,4 @@ to the \link{EXCLUDED_DISEASES}, when the touchstone year in \code{df} is less t A pair of helper functions allowing filtering out of recent touchstone values and excluded diseases. } -\keyword{pressure_testing} +\keyword{impact_diagnostics} diff --git a/man/save_outputs.Rd b/man/save_outputs.Rd index db41a66..27e513d 100644 --- a/man/save_outputs.Rd +++ b/man/save_outputs.Rd @@ -47,6 +47,8 @@ with the outcome \code{"dalys_averted"}.} \item{subregional_flags_dalys_rout}{A data.frame that is the output of \code{\link[=compare_natl_subreg]{compare_natl_subreg()}} with the outcome \code{"dalys_averted_rate"} for the \code{"campaign"} activity type.} + +\item{output_dir}{A writeable directory. Defaults to "./outputs".} } \value{ None. Called for the convenience side-effect of saving data.frames as @@ -57,4 +59,4 @@ Save pressure-testing diagnostics data.frames to local compressed files in the \code{.Rds} format. Input data.frames are generated by other package functions and are not checked here. } -\keyword{pressure_testing} +\keyword{impact_diagnostics} diff --git a/man/significant_diff_plot.Rd b/man/significant_diff_plot.Rd deleted file mode 100644 index 11b7cb4..0000000 --- a/man/significant_diff_plot.Rd +++ /dev/null @@ -1,12 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_plotting_pressure_testing.R -\name{significant_diff_plot} -\alias{significant_diff_plot} -\title{Plot significant changes} -\usage{ -significant_diff_plot(df, outcome) -} -\description{ -Plot significant changes -} -\keyword{internal} diff --git a/man/validate_complete_incoming_files.Rd b/man/validate_complete_incoming_files.Rd index 75d3cd9..dcdfb7b 100644 --- a/man/validate_complete_incoming_files.Rd +++ b/man/validate_complete_incoming_files.Rd @@ -20,4 +20,4 @@ This function expects that incoming burden files are in the directory given by \code{path_burden}, which holds a file dictionary which maps each data file to a specific scenario. } -\keyword{diagnostics} +\keyword{burden_diagnostics} diff --git a/man/validate_file_dict_template.Rd b/man/validate_file_dict_template.Rd index af2d770..e84f3f7 100644 --- a/man/validate_file_dict_template.Rd +++ b/man/validate_file_dict_template.Rd @@ -25,4 +25,4 @@ scenarios i.e. the number of files that we expect from a model. Users should populate the file column to match the scenario-file. This function will run if a \code{file_dictionary.csv} file does not exist } -\keyword{diagnostics} +\keyword{burden_diagnostics} diff --git a/man/validate_template_alignment.Rd b/man/validate_template_alignment.Rd index 7bbccc6..c6c9e36 100644 --- a/man/validate_template_alignment.Rd +++ b/man/validate_template_alignment.Rd @@ -19,4 +19,4 @@ against \code{template}, with information on missing and extra data. \description{ Identify extra and missing columns and rows in burden data. } -\keyword{diagnostics} +\keyword{burden_diagnostics} From 386be9b6a1aa618626cf0f0a1eee5adc76a6ddb8 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 22 Apr 2026 15:58:57 +0100 Subject: [PATCH 16/29] Update infra, bump to v0.0.4 --- DESCRIPTION | 6 +++++- NAMESPACE | 31 ++++++++++++++++++++++++++++++- NEWS.md | 8 ++++++++ inst/WORDLIST | 1 + 4 files changed, 44 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 93969a5..d96f7e7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: vimcheck Title: Diagnostics for Vaccine Impact Modelling Consortium Burden and Impact Estimates -Version: 0.0.3 +Version: 0.0.4 Authors@R: c( person("Pratik", "Gupte", , "p.gupte24@imperial.ac.uk", role = c("aut", "cre"), comment = c(ORCID = "0000-0001-5294-7819")), @@ -24,13 +24,17 @@ Depends: Imports: checkmate, cli, + diffdf, dplyr, forcats, ggplot2, + ggridges, glue, + here, readr, rlang, scales, + stats, stringr, tidyr Suggests: diff --git a/NAMESPACE b/NAMESPACE index 6a9f7c8..7caa5f0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,24 @@ # Generated by roxygen2: do not edit by hand +export(COLNAMES_INTEREST_PRESSURE_TEST) +export(COLNAMES_KEY_PRESSURE_TEST) +export(COLOUR_VIMC) +export(DEF_TOUCHSTONE_NEW) +export(DEF_TOUCHSTONE_OLD) +export(DEF_TOUCHSTONE_OLD_OLD) +export(EXCLUDED_DISEASES) +export(IMPACT_OUTCOMES) +export(MAX_TS_MONTH) +export(MAX_TS_YEAR) +export(MIN_TS_MONTH) +export(MIN_TS_YEAR) +export(N_TS_MIN_CHARS) +export(N_TS_YEAR_CHARS) export(basic_burden_sanity) +export(burden_outcome_names) export(check_demography_alignment) +export(colnames_df_missing_cols) +export(colnames_plot_demog_compare) export(compare_natl_subreg) export(file_dict_colnames) export(filter_duplicates) @@ -15,17 +32,25 @@ export(generate_diffs) export(plot_age_patterns) export(plot_compare_demography) export(plot_coverage_set) +export(plot_cumul) +export(plot_diff) export(plot_fvp) export(plot_global_burden) export(plot_global_burden_decades) +export(plot_modelling_group_variation) +export(plot_sig_diff) +export(plot_vaccine_gavi) export(prep_plot_age) export(prep_plot_burden_decades) export(prep_plot_coverage_set) +export(prep_plot_cumul) export(prep_plot_demography) export(prep_plot_fvp) export(prep_plot_global_burden) +export(prep_plot_mod_grp_varn) +export(prep_plot_vax_gavi) export(save_outputs) -export(significant_diff_plot) +export(scenario_data_colnames) export(theme_vimc) export(theme_vimc_noxaxis) export(validate_complete_incoming_files) @@ -37,6 +62,8 @@ importFrom(ggplot2,facet_grid) importFrom(ggplot2,facet_wrap) importFrom(ggplot2,geom_col) importFrom(ggplot2,geom_hline) +importFrom(ggplot2,geom_point) +importFrom(ggplot2,geom_segment) importFrom(ggplot2,ggplot) importFrom(ggplot2,label_wrap_gen) importFrom(ggplot2,labeller) @@ -44,5 +71,7 @@ importFrom(ggplot2,labs) importFrom(ggplot2,scale_fill_distiller) importFrom(ggplot2,scale_x_continuous) importFrom(ggplot2,scale_y_continuous) +importFrom(ggplot2,theme) importFrom(ggplot2,vars) +importFrom(rlang,":=") importFrom(rlang,.data) diff --git a/NEWS.md b/NEWS.md index 81b8136..b7f6fc8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# vimcheck 0.0.4 + +- Added impact diagnostics functions in `R/fn_impact_diagnostics.R`. + +- Added plotting preparation functions and plotting functions in `R/fn_plotting_prep_impact_diagnostics.R` and `R/fn_plotting_impact_diagnostics.R`. + +- Added dependencies _diffdf_ and _here_. + # vimcheck 0.0.3 - Separated data-prep for plotting from plotting functions. diff --git a/inst/WORDLIST b/inst/WORDLIST index e9a14dc..bc3ac78 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -22,6 +22,7 @@ YLLs YYYYMM autogenerated dalys +diffdf erroring facetted ggplot From 43753fb05464dd0b45026651af99ba470f89e237 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 22 Apr 2026 16:10:24 +0100 Subject: [PATCH 17/29] Rename fn file, fix arg name --- ...sure_testing.R => fn_impact_diagnostics.R} | 21 +++++++++---------- man/compare_natl_subreg.Rd | 2 +- ...t_filter_data.Rd => filter_impact_data.Rd} | 6 +++--- man/flag_large_diffs.Rd | 2 +- man/gen_combined_df.Rd | 8 +++---- man/gen_national_iqr.Rd | 2 +- man/generate_diffs.Rd | 2 +- man/save_outputs.Rd | 2 +- 8 files changed, 22 insertions(+), 23 deletions(-) rename R/{fn_pressure_testing.R => fn_impact_diagnostics.R} (98%) rename man/{pres_test_filter_data.Rd => filter_impact_data.Rd} (94%) diff --git a/R/fn_pressure_testing.R b/R/fn_impact_diagnostics.R similarity index 98% rename from R/fn_pressure_testing.R rename to R/fn_impact_diagnostics.R index c5c9a1f..a79a22d 100644 --- a/R/fn_pressure_testing.R +++ b/R/fn_impact_diagnostics.R @@ -1,7 +1,7 @@ #' Filter data for touchstones or diseases #' -#' @name pres_test_filter_data -#' @rdname pres_test_filter_data +#' @name filter_impact_data +#' @rdname filter_impact_data #' #' @description #' A pair of helper functions allowing filtering out of recent touchstone values @@ -56,7 +56,7 @@ filter_recent_ts <- function(df, threshold = DEF_TOUCHSTONE_NEW) { } } -#' @name pres_test_filter_data +#' @name filter_impact_data #' #' @export filter_excluded_diseases_ts <- function( @@ -81,7 +81,7 @@ filter_excluded_diseases_ts <- function( } } -#' @name pres_test_filter_data +#' @name filter_impact_data #' #' @param key_cols Key columns in `df` to check for duplicates. #' @@ -111,7 +111,7 @@ filter_duplicates <- function(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) { dplyr::filter(df, .data$n_key > 1) } -#' @name pres_test_filter_data +#' @name filter_impact_data #' #' @param prev_data A `` holding data from a previous touchstone for #' the same scenarios as `df`. @@ -471,7 +471,7 @@ flag_large_diffs <- function( #' @param prev_dat A data.frame of impact estimates corresponding to an earlier #' touchstone. #' -#' @param df2 A data.frame of impact estimates corresponding to a more recent +#' @param df_clean A data.frame of impact estimates corresponding to a more recent #' touchstone. #' #' @param interest_cols A character vector of columns of interest. Defaults to @@ -480,7 +480,7 @@ flag_large_diffs <- function( #' @param key_cols A character vector of columns of interest. Defaults to #' [COLNAMES_KEY_PRESSURE_TEST]. #' -#' @return A data.frame which is a full join of `prev_dat` and `df2`. Columns +#' @return A data.frame which is a full join of `prev_dat` and `df_clean`. Columns #' are disambiguated with the suffixes `"_old"` and `"_new"`. #' #' @keywords impact_diagnostics @@ -488,7 +488,7 @@ flag_large_diffs <- function( #' @export gen_combined_df <- function( prev_dat, - df2, + df_clean, interest_cols = COLNAMES_INTEREST_PRESSURE_TEST, key_cols = COLNAMES_KEY_PRESSURE_TEST ) { @@ -526,13 +526,12 @@ gen_combined_df <- function( must.include = c(interest_cols, key_cols) ) checkmate::assert_names( - colnames(df2), + colnames(df_clean), must.include = c(interest_cols, key_cols) ) - # TODO: df2 needs a better name prev_df <- dplyr::select(prev_dat, {{ interest_cols }}) - cur_df <- dplyr::select(df2, {{ interest_cols }}) + cur_df <- dplyr::select(df_clean, {{ interest_cols }}) combined <- dplyr::full_join( prev_df, diff --git a/man/compare_natl_subreg.Rd b/man/compare_natl_subreg.Rd index 7f4c60e..395d116 100644 --- a/man/compare_natl_subreg.Rd +++ b/man/compare_natl_subreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_pressure_testing.R +% Please edit documentation in R/fn_impact_diagnostics.R \name{compare_natl_subreg} \alias{compare_natl_subreg} \title{Compare sub-regional and national estimates} diff --git a/man/pres_test_filter_data.Rd b/man/filter_impact_data.Rd similarity index 94% rename from man/pres_test_filter_data.Rd rename to man/filter_impact_data.Rd index 27b1d43..da36793 100644 --- a/man/pres_test_filter_data.Rd +++ b/man/filter_impact_data.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_pressure_testing.R -\name{pres_test_filter_data} -\alias{pres_test_filter_data} +% Please edit documentation in R/fn_impact_diagnostics.R +\name{filter_impact_data} +\alias{filter_impact_data} \alias{filter_recent_ts} \alias{filter_excluded_diseases_ts} \alias{filter_duplicates} diff --git a/man/flag_large_diffs.Rd b/man/flag_large_diffs.Rd index fcc5039..f54488d 100644 --- a/man/flag_large_diffs.Rd +++ b/man/flag_large_diffs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_pressure_testing.R +% Please edit documentation in R/fn_impact_diagnostics.R \name{flag_large_diffs} \alias{flag_large_diffs} \title{Flag significant changes in impact estimates} diff --git a/man/gen_combined_df.Rd b/man/gen_combined_df.Rd index b3f53f0..13dd05d 100644 --- a/man/gen_combined_df.Rd +++ b/man/gen_combined_df.Rd @@ -1,12 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_pressure_testing.R +% Please edit documentation in R/fn_impact_diagnostics.R \name{gen_combined_df} \alias{gen_combined_df} \title{Combine and align data from two touchstones} \usage{ gen_combined_df( prev_dat, - df2, + df_clean, interest_cols = COLNAMES_INTEREST_PRESSURE_TEST, key_cols = COLNAMES_KEY_PRESSURE_TEST ) @@ -15,7 +15,7 @@ gen_combined_df( \item{prev_dat}{A data.frame of impact estimates corresponding to an earlier touchstone.} -\item{df2}{A data.frame of impact estimates corresponding to a more recent +\item{df_clean}{A data.frame of impact estimates corresponding to a more recent touchstone.} \item{interest_cols}{A character vector of columns of interest. Defaults to @@ -25,7 +25,7 @@ touchstone.} \link{COLNAMES_KEY_PRESSURE_TEST}.} } \value{ -A data.frame which is a full join of \code{prev_dat} and \code{df2}. Columns +A data.frame which is a full join of \code{prev_dat} and \code{df_clean}. Columns are disambiguated with the suffixes \code{"_old"} and \code{"_new"}. } \description{ diff --git a/man/gen_national_iqr.Rd b/man/gen_national_iqr.Rd index 4257953..853a8b0 100644 --- a/man/gen_national_iqr.Rd +++ b/man/gen_national_iqr.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_pressure_testing.R +% Please edit documentation in R/fn_impact_diagnostics.R \name{gen_national_iqr} \alias{gen_national_iqr} \title{Generate IQR for key outcomes} diff --git a/man/generate_diffs.Rd b/man/generate_diffs.Rd index 4e4607e..03a8500 100644 --- a/man/generate_diffs.Rd +++ b/man/generate_diffs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_pressure_testing.R +% Please edit documentation in R/fn_impact_diagnostics.R \name{generate_diffs} \alias{generate_diffs} \title{Explore significant changes in deaths and DALYs} diff --git a/man/save_outputs.Rd b/man/save_outputs.Rd index 27e513d..0b2afbe 100644 --- a/man/save_outputs.Rd +++ b/man/save_outputs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fn_pressure_testing.R +% Please edit documentation in R/fn_impact_diagnostics.R \name{save_outputs} \alias{save_outputs} \title{Save pressure-testing diagnostics to local file} From 474fdc3f5caf992402021c4dedc7d5a4ed089824 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Thu, 4 Jun 2026 17:23:02 +0100 Subject: [PATCH 18/29] Fn filter dups only flags instead --- R/fn_impact_diagnostics.R | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/R/fn_impact_diagnostics.R b/R/fn_impact_diagnostics.R index a79a22d..5aae0be 100644 --- a/R/fn_impact_diagnostics.R +++ b/R/fn_impact_diagnostics.R @@ -25,15 +25,16 @@ #' to the [EXCLUDED_DISEASES], when the touchstone year in `df` is less than the #' `threshold`, excluded. #' -#' - `filter_duplicates()` returns `df` with duplicated combinations of -#' `key_cols` removed. +#' - `flag_duplicates()` returns `df` with duplicated combinations of +#' `key_cols` flagged using the column `n_key` (or a user-defined name). #' #' - `filter_invalid_trajectories()` returns `df` with bad outcome trajectories #' (`NA` to non-`NA`) removed. #' #' @export filter_recent_ts <- function(df, threshold = DEF_TOUCHSTONE_NEW) { - checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 1L) + # NOTE: exact min cols to be updated - fn implies at least 2 + checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 2L) checkmate::assert_names( names(df), must.include = "touchstone" @@ -86,8 +87,8 @@ filter_excluded_diseases_ts <- function( #' @param key_cols Key columns in `df` to check for duplicates. #' #' @export -filter_duplicates <- function(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) { - checkmate::assert_data_frame(df, min.cols = 1L, min.rows = 1L) +flag_duplicates <- function(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) { + checkmate::assert_data_frame(df, min.cols = length(key_cols), min.rows = 1L) checkmate::assert_character(key_cols) has_cols <- checkmate::test_names( @@ -102,13 +103,23 @@ filter_duplicates <- function(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) { ) } + # data may have a `burden_outcome` column which should not be counted as + # a duplicate df <- dplyr::add_count( df, - dplyr::across(dplyr::all_of(key_cols)), + dplyr::across(dplyr::all_of(c(key_cols, "burden_outcome"))), name = "n_key" ) - dplyr::filter(df, .data$n_key > 1) + # dplyr::filter(df, .data$n_key == 1L) + if (any(df$n_key > 1)) { + n_duplicates <- sum(df$n_key > 1) + cli::cli_warn( + "{n_duplicates} duplicates found in data; please check for plausibility!" + ) + } + + return(df) } #' @name filter_impact_data From 4873b450f0077e5c1e499a43b5bf4a58bbefd36b Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Thu, 4 Jun 2026 17:23:16 +0100 Subject: [PATCH 19/29] More sensible checks on fns --- R/fn_impact_diagnostics.R | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/R/fn_impact_diagnostics.R b/R/fn_impact_diagnostics.R index 5aae0be..8280845 100644 --- a/R/fn_impact_diagnostics.R +++ b/R/fn_impact_diagnostics.R @@ -231,8 +231,16 @@ generate_diffs <- function( key_cols = COLNAMES_KEY_PRESSURE_TEST, touchstone = DEF_TOUCHSTONE_OLD ) { - checkmate::assert_data_frame(prev_df, min.rows = 1L, min.cols = 1L) - checkmate::assert_data_frame(curr_df, min.rows = 1L, min.cols = 1L) + checkmate::assert_data_frame( + prev_df, + min.rows = 1L, + min.cols = length(interest_cols) + ) + checkmate::assert_data_frame( + curr_df, + min.rows = 1L, + min.cols = length(interest_cols) + ) checkmate::assert_character(interest_cols, min.len = 1L) checkmate::assert_character(key_cols, min.len = 1L) @@ -240,11 +248,11 @@ generate_diffs <- function( # check interest cols in dfs. key cols are check in `add_campaign_id` checkmate::assert_names( colnames(prev_df), - must.include = interest_cols + must.include = c(interest_cols, "support_type", "coverage") ) checkmate::assert_names( colnames(curr_df), - must.include = interest_cols + must.include = c(interest_cols, "support_type", "coverage") ) touchstone <- validate_ts_year(touchstone) @@ -310,7 +318,11 @@ gen_national_iqr <- function( value_cols = c("deaths_averted", "dalys_averted"), prefix = "national_iqr" ) { - checkmate::assert_data_frame(df, min.rows = 1L, min.cols = 1L) + checkmate::assert_data_frame( + df, + min.rows = 1L, + min.cols = length(c(group_cols, value_cols)) + ) checkmate::assert_character(group_cols, min.len = 1L, any.missing = FALSE) # NOTE: restricting value columns to deaths and dalys averted @@ -326,6 +338,7 @@ gen_national_iqr <- function( must.include = union(group_cols, value_cols) ) + # long-winded syntax to pass grouping variables as char vec df <- dplyr::group_by(df, dplyr::across(dplyr::all_of(group_cols))) df <- dplyr::summarise( df, From 50b5389a30db2e477b64b9c4cba3bd063d42cf02 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Fri, 5 Jun 2026 15:17:14 +0100 Subject: [PATCH 20/29] Add test data from vimpact --- R/data_who_subregions.R | 23 +++ R/example_data.R | 25 ++++ data-raw/eg_impact.R | 28 ++++ data-raw/who_subregions.R | 8 + data/eg_impact.rda | Bin 0 -> 23631 bytes data/who_subregions.rda | Bin 0 -> 3847 bytes inst/extdata/impact_method2a.rds | Bin 0 -> 14813 bytes inst/extdata/impact_method2b.rds | Bin 0 -> 8382 bytes inst/extdata/who_sub_regions.csv | 250 +++++++++++++++++++++++++++++++ 9 files changed, 334 insertions(+) create mode 100644 R/data_who_subregions.R create mode 100644 data-raw/eg_impact.R create mode 100644 data-raw/who_subregions.R create mode 100644 data/eg_impact.rda create mode 100644 data/who_subregions.rda create mode 100644 inst/extdata/impact_method2a.rds create mode 100644 inst/extdata/impact_method2b.rds create mode 100644 inst/extdata/who_sub_regions.csv diff --git a/R/data_who_subregions.R b/R/data_who_subregions.R new file mode 100644 index 0000000..2e435b6 --- /dev/null +++ b/R/data_who_subregions.R @@ -0,0 +1,23 @@ +#' Data on countries in WHO subregions +#' +#' Data that groups countries into WHO subregions. +#' +#' @format ## `who_subregions` +#' A data frame with 249 rows and 9 columns: +#' \describe{ +#' \item{choice_subregion}{Sub-region three character code with added letter +#' identifier.} +#' \item{country_name}{Country name in long form.} +#' \item{country}{ISO 3 character country code.} +#' \item{Global.Name}{A constant, 'World'.} +#' \item{Region.Name}{Continent-scale region identifier.} +#' \item{Sub.region}{Sub-continental scale region identifer.} +#' \item{Intermediate.Region.Name}{Alternative regional scale identifier.} +#' \item{subregion}{Sub-regional identifier.} +#' \item{vimc117}{Logical identifier.} +#' } +#' +#' @keywords data +#' +#' @source Prepared by the VIMC secretariat. +"who_subregions" diff --git a/R/example_data.R b/R/example_data.R index e2cf380..c6a1d7b 100644 --- a/R/example_data.R +++ b/R/example_data.R @@ -114,3 +114,28 @@ #' #' @source Prepared by the VIMC secretariat. "eg_fvps" + +#' Example of impact data +#' +#' Example of vaccine impact data taken from data used to test \pkg{vimpact}. +#' This data is primarily used for testing here too. +#' +#' @format ## `eg_impact` +#' A data frame with 5396 rows and 9 columns: +#' \describe{ +#' \item{disease}{Disease name.} +#' \item{vaccine}{Vaccine identifier.} +#' \item{modelling_group}{Modelling group name.} +#' \item{country}{Country ISO 3-character code.} +#' \item{country_name}{Country name.} +#' \item{year}{Year for which impacts are modelled.} +#' \item{activity_type}{Activity type: either "routine" or "campaign."} +#' \item{burden_outcome}{Name of the burden outcome; one of "deaths_averted" +#' or "dalys_averted".} +#' \item{impact}{Value of the impact}. +#' } +#' +#' @keywords data +#' +#' @source Prepared by the VIMC secretariat. +"eg_impact" diff --git a/data-raw/eg_impact.R b/data-raw/eg_impact.R new file mode 100644 index 0000000..29e5c27 --- /dev/null +++ b/data-raw/eg_impact.R @@ -0,0 +1,28 @@ +## code to prepare `eg_impact` dataset goes here + +library(dplyr) +library(countrycode) + +eg_impact <- rbind( + readRDS("inst/extdata/impact_method2a.rds"), + readRDS("inst/extdata/impact_method2b.rds") +) + +# assign disease inferred from vaccine names +# infer MCV to be for MenA from report +eg_impact <- mutate( + eg_impact, + disease = case_when( + vaccine %in% c("HepB", "HepB_BD") ~ "HepB", + vaccine %in% c("MCV1", "MCV2") ~ "MenA", + .default = vaccine + ) +) + +# infer country name from ISO code (only includes PINE but for future-proofing) +eg_impact <- mutate( + eg_impact, + country_name = countrycode::countrycode(country, "iso3c", "country.name") +) + +usethis::use_data(eg_impact, overwrite = TRUE) diff --git a/data-raw/who_subregions.R b/data-raw/who_subregions.R new file mode 100644 index 0000000..41e00f8 --- /dev/null +++ b/data-raw/who_subregions.R @@ -0,0 +1,8 @@ +## code to prepare `who_subregions` dataset goes here + +library(readr) +library(dplyr) + +who_subregions <- read_csv("inst/extdata/who_sub_regions.csv") + +usethis::use_data(who_subregions, overwrite = TRUE) diff --git a/data/eg_impact.rda b/data/eg_impact.rda new file mode 100644 index 0000000000000000000000000000000000000000..9afab65edfa6b48c55eba5b033938e73f8b81f7a GIT binary patch literal 23631 zcmaf(Q*_>4wDte-lQepw292G@wvEQN)!2T5wy~WCjh)7}ZQE{ao%j33xj$>{eYNlQ z8hg$?=K6{1Sn;rkXj7?bpHBR!fWc-B`1rqSOQI710D=EDp_^ZwJ}#a?`^M?Kw_l@y zj(zK?xr3kAN^6Uk^UYdjom+Ev5%zNV()`)Ky7kLv0Ov2(^Aw*E!(!#V^-2DVPkQ@9 z$IYgne$h9KmNUZpjV{aPCimU;>eI#1DZ;pQ_?CJB6qWjQ&ZM-!!X?7l=#H1xC0&l1 zaliJB^o@;|%+rDU4Udky{WH%OmW#~w)zyvr2mA2z_D1{G^D6tqyN%Usdr}d^P-yG0 zLXdR`vY4!o0=tsANxm9+Um#50glP^k;X@l6nO% zOsv_*G2y|5m||*g`0!Dz_^Qj`LSSwsLo!%ZwO6L39UndcDQhK7aX3!_-^Ls9#8{z_ zgH7gWm@_>_q>#3r+02?#?V5u>zoK43et!*9Fs$pQ6t8_vzsMOu>M4#Tz*m71o3SU! zZL|pbAEIY9cbxp!bF&SLU}r*Dpd1(b2K={PW!DAvS)H+AVcX-2&2jHNnI5CaRFDti zB$AWtlg%Z>R_SnRBk??O18|61BUV=Z5*CK+eFpKza_LFl{x(g>%xRUC>MYk%_zx-d zH+rcfX*&cGO&rp$CN3;q4k;B^6UPmYRac@=2LohuBEk|*99GbfuyjZ|I&=ndP z2_pM2hKCg~i&XXpBw^u9vGkb9K{P|cLGZ&Q`GH_uX%P){iT533qdZb*P$v=$g;4}F zNhdlCJWY)#s1r9B8uXVeqJxH261qBwX$aCI99m8i(E(vL`a~i+0jU}R^+C!*NWRv> znsfuP5-R{Rh-`?Jrjr$hLJNX{)XANP0l<<))C(Jv2?HU@{vq(v%m68r?p81&G|7Jl ztt8#y@gNKU1B4@59z<_uM6aBZqb~kAbyEoXKC|(2%at^nZ@I%)dP=sxDi*B$#bRH% z!lc8kJ9Y0|mfRcbkayLWJm%_p%jp>WMpCLYWTunV_6Ci(jPJi z22F7iIyxd4n?f0f>St>!6gGtt`gaoOPx{!jaFVg`;<&*i^d{&^)T}h&YT+`geX^_~ z6tQL@l0nL5wBmm#3TW{_l9I5o6nPXOlr$=^VPtB#rE2OBSaEC;dh9ZT;-IA5Q0e%u z7#J`l7=Sc-NO-&`DOo-u2pkd@NI^j&145EUjtrF^g2lrSFF=P$+U-||Dd9rt85aIJ z1uY#)CkLhexB8E{bX}r~urY3!l2QpA$xI@;gp5ibfbO98BVK?MOHD0KT{uoH7LGzx zL|VE>!c0^Ki$YpdSQ{ix0T)P$!5k8TNJ3B zbK^+>bW*3>Vkl{n5)$ZY5|DZb6a`!uNhz%gs8k92t6FYOi3k`>KNLz*_ZBCv))F4n z4_2WI>H@3O&*X-Oeim*Lhf_ttQiJmVfoMX%{G~$*0>eRJz8l8{L4PGf3U!{Mk-o!% zg@Z}BXgsZ2%zP>}Eyxbre#BX{FN6NTycmR+?*8ug4ESrmccNezf9y-XRz(Lv8wC^Lw}V1F7w1i~IHVoM)CBjzo?Y z0;iRi#D^r8IWKH&m)Y6WnEhR=d@?dAesKxJrJTPml%!^vtbufWei}^Jc-4`?P6RU; zPu!HgZ0p#gfc}0%Tc*l68-8Y#nB$M2Di;O#X^r28JD*PG8h!kODillknUYnjK7AAQ z)}fF)^$+_af~4pl4L}3XFunAmJE&jEM|%|584@|^9t&7wKetWhI4}6?& zlt)W82tk2TcFr{CvQ(`7n^Vf6$&kdObb7Tx-ha>REQxG*(mFtG~rk(oAeg z9gbB$e#Zh@!7`7vU-eynj#O7-2patcU9Fb&% z0^vc})O=!bGj5HF2JPsIt59GjbU6Kk)sSCcOBo#$QtZYvo|7)}Dcequ&P?RU&$Nl*1{0aI zE@q0OuF_%@cM!mxIgYk41q3^TQMq}3>(fik#+_x;d;$TYI1$3Cv5g=A6iBv^Y{apW za(>!?2maF;lK`j?_Kk;OEjNoQl72c~D4u}LNX2JaUT;6N<_vXKFCI^)sp{U`tAiJL zjS-I-O_Yqq!8|y*MDs9XepsIi@6zl*D>QWI4>Sr7iq4Z07;6*uo4)p7F0=#^`Oub$ ziBU#8d*oghUFB#G?&m--c8|zbpiq+5S2xLk-v-&@Phukdcl0F?5G3?YL;qYD3)Xu~ zGhqMFcI24yz!@6~7GPGbEnB(fCdiJ^-L3oc=D}w|_r1Qg5~K5-v?x9M&;;p63lfca z4y3~V7r7F;_$f(o+7S&Mw-r#54FM1nAaw3H{2d4=@0*j|wf);?hQnO6c_*&T?N#8@ z?{%&HAF3r=9||3pbm6}*KBC;zh^?of@9tAV<#GY`N@~B@l6K!EzrB84Zs4> z$h0O4ij=KVb4j!(U?MM_09?SqP<2>TMUVE5+HvAzBvr3@(E%~6JXTC#7Q1Sau?A1c zk%y%bEm$DCZs0>PHwR6Z<=y?BhNMNVKwg1x6J^M-oQp`VX6C56WxQxT@YQqjkcfjh zD<92`QlT(0tw8h4Z>0_Zcx{o3PlEu_O%J5biLL9VW!{V!Se~faKiL0j%~tQS>(YOT zA(eWgf`mom;pw1X?3LL!)MEh%Uz0ccHsXcIvhy?ejY2EDUG z2Yi2j(+8{g^8EJZ6itc8@9{Q|XuQI2Brf^% z>p6a$@4ipuM$UDg;=82-;$Un4~%4ZlRnwA4>%)W#G5 zPH-ciuIU}aL$~^WJhrm8Vh>rhYIHzj+4RHC#W81)(Z=j-;QBDt*mHi$=U?$-!p9J5 zELAmXupAApt8rJ~?kkYZei(vj`}#~c?)2eq&wro|PT2U$*-Jnxu>T1FpwyKvF%pPYpe<+Y^Z=Oef$K7oz1aM@G@>zOKbD$Et}Wv`1UX~q-3y=WUZj@SMO|@^pfS=k zQ8+Vpkqnwf^vft8Xf14|qHF(F=60Y>Vy0QKn4rJY7kp?Ij;?(BYfGA!O|r%KfCMjz z=?(`WcmJS7CV*n@bD}lPd_!!Dq^cUpa&!KbErJrg6;F)#FOIc)$nUdMy#8E=VS3&) ze2K}+pCAB=to)De4@G5}FK3^;PeOx!ld-$@8W-0(G<$8N3O%YDQ+(YfX`-mP3#S4mE_NNTEMl=4=_-!q;i*FC;d|k z{oNq27>v;8Z&(!4O8G8IU=*75gf(CHnbMp-xR#2DAe?ngc4t#Z34oEoh4=HACAwdER#rDTy`$^p6!?9l;)?f={yQZ5u3 zG>ytmuNuy9*nx2m0l%2$J$rRFWj+QD2+9p$o7)2-3~XnP@4nPRmIM z_27ZtE0u{qq48mJR!^e-usU~2QeFAgh>D`Q_G(kl#Lw0LZ1>f?2z&@W?)tzzIEhNe zL?7#j#&-^%ozVWw`H`O>`l=IRlAe>_=ipF$*)>k4=g!U$@m|IG!x1)s7t>BKI-7_^ zIV=jJA4pBl-2B6VU!pKpH=E-t4DlL*5;9x!>l5deUaa%)poiuvn$5=0&27dBCDV*? zN#b8m!#@HYSk8H{wf6;{Uty`QACfWlC%#s60RiQtD!(`Xu^JHS5O;<7q0L{DfviG5 z^#A}dmt5kzOd>ISB;^nayo!sE(!x)o6Aye{Rhlz5KLPsBUF(@)9fTTjJ4poXF^T() z`h{Y8w%gTe+s=i~hrCjERBcN5rNY3gK{vAx(_?#UXA|I&c7zHbI2lgWUYNe?*e}d> z=rU342nLZSS`wI}m%J14qIh?g?GmJ&*i6((_RD^c{JiMW`i+-&0wZd^BADKJ9{}JQ z0`O-S0J83=7g z0f-O;D{X}gR71<=850ibkK?e`au%aFkGcR@2V4EtpeJq&hRUxLgnqGU@`%3*PpTh; ztXmIgV8%Q?YHzF4OrjO)*j7!Zzc+iGCtY)vB1~IWeXnPfzUh~`bykD`&x(YTf8WNW za-)!3odzys3UnGLcI*gio4r$G7GTh-*Wy3sz=`EwD_rEx)93oOGdBSQk(N#tt*gOq zx%INgM=M1pwaJM2I=RmVmqx;`Up!;j!q2D=X9TdhtXv5OcmhN|@~n%umo?Y!Yg^kM zJlGzHf<9wh9*WEs2o4oRW|~7`eueyU(CKybeyfKuSZL_BO%=Wa@A#ufiIVNK5RFKjz+dA~>$-jRc22|#-Q9svb+4!a@k+X9i zRYw5@f%YM7SB3}E@A{{n;n$b4(v0*2*9-;Oy3SO93%B5nXR1*@%Hz?4v;NPh^1 zV7R(X1}Eq*04LJf`~oKPSshqQ=Udm7d3G9r04Yf`xt;tY;KwZhtyJ-O52@mgEk2j@ zdZvzvi;voHijzyMwT*-~BMuJLLB}}xce0-ln^zK&O(qcr1wfHin6gYUQ!&MN0slRd zXJh%`2i0l4B{R?!Uy|}mH6`QbG5)WgzVn|K7fO=Yw($rJy*cZL%{&S+MiKxZBmZ^L z`kl$sKMHFpf!V|cE7sE_ap!It0titx1T@of$xTKr-`pepy4c+|d`U@T&NoGB4udnX zV<|wvFuks>i!NULFSLY+xcTllhq~H1{wv%wq)7Jlqtb!-IkPYBgoKz?D0rbv_m^5t z*EbrhEBWuwz_5-TnPx<0bpHetR$$N{ft4>skFQc5h$zlh;$Jo+n&M{6|32~M!>&1OTneij)4yomWj+b1B zX`5MOL0n||PZ)61;AwdlYrfmPVWtr{qJQ#p)b~B)B42bVw>&WSI=m22eAG|)6#^aV z`TM-ft*XRJwsa|Vv^x%oUv?SZp5fHkT21TSB)whlW0a(_7=RiIbgYpx;x;`;hIiL# z_5A^t1H}@9eQ#fIyuDsRioBO(%EqYfP^75gA4nA`iqRm0J<6)lJ%Ny-BeQ3sMm*+R zcA?g@Je+vzCk&vtvTRPD&$b6~Ee&uS#Jm25#(BbM-q3H0(m+mXYlM>C#Jy#l($wkQ z&c_A8&ACfY{i0qQ8-{Qr(FtBh?p59N%i3dfyt0+U>&O2N3L+dbDUu`Bi~=3jxY@pY zMhTT;1#j?ufJP#TmXk*#X0qEHf;D3vmDz_k*Yg1YD+sql=Jn696PU0jgbd#5Ws2=- zTL11Fz0%8so2OD;#oqG+P9P!NvB~c_%3}HiSqa%2(z#!~_I^_Uz=?J18}?faji{7! zY_VZiE;UiY-a;TH%-TAp1?kyOItpzz+#}-`4ge$(-r+N)xQnL1r({nOYIvr`=g-Se zG~OZxMDPTt{%UFQ*Yq5krU?(mf;UuCxJ-?$vcvB_}%iFiHo08Swwt_?OSt5 zizFebMu5?0O7ri=Q+(wmA-$!3QwTS)P4(;J21t$4phOU}UtJ#Ae4|4n7!-c{_I_G- zc#y3%%^qe84Iv?9%t#`7F$|Z?D+)01YrmXoS`nP>P&&`sXHz{BJRq+W)Q@c9i3?F#`~!q82v`WLBmvwkq>mujLoRj9RUjadQG zzb3ip@(wSh2RQ95n$c5-0VvD5)EkLOYwM#`ef^Wd-wl0MX986hRV#fEC^TrgpP52y zMQejgb0>;};5SiMepZ3de=Kw8x4umis#@=mUV3thT1K_e);8ni!|3Ps z-nxOcv*Cjf#Sas&o_lwVDJw`uw>H(-K5-lNvo^g(JA)x{7ZU*gw-~3~iHg>SYIs?ISx}L(9utEDSoUlY!YuWfcD=UOL>)+g|wzS2DLtt|vZ? z=yC^l9P53n<*ULUvCb!)`$l#JIlf=*vvo!9)A$Gg1=*%x51&S%;;Hmh)Z zi>_h5i(@JYg2v|V7^IFtupcaFUog#q_M))&C~s=Z;#0dGSwHlzp|p!|aeY5oc zQ7OK?*FRkeAk!)=T@FG@^nV_*mq+*E(q9GXr{f#B{@nud9OFJ5YoAaUCY-XOFb*82 zL-gZTTpkX-2!iP6hgb%&%v9>AX-@ovba#h(fURjbC!@RSa3O1knC9Fw^KU&_%a(66 zt|m}1{jOV#>>sS{=$MZDhu-vi-{n%>=}~Y&9z#|3PG)Mw``@v&Odk;5>W^>ndI!Ws z$7}WOi)s&s`1MEh1lX6~xFg4E7>~99?g6bLdL?EBMAZbFheaRU_wfy~D2zd!e$qv@ zmb>GkMztb;c~UqXCfEq3w)iV;t)FiO(wudnzJ&3lFx{e1;=%yC4YSZ!|5-9JGC`zO)F1XAESO5d$cF>Bhh{9rmHgp2!Mgs^ke~lVMI5fobyab%EB4yPqm9jlAPPklYV%~f zcKS2p>>M(ajig^Dh?5;lRXLR_=jQlPf8z*be`>@Yj1AvBycb6HOy^JS0>qqE?~Rw=%sV8$-pQV}=G zGhk3bs>q@_X)V{=Yc&_}@^pgvBPgey#(f-xot*;*O%y4uw6gUxYE3-~0 zbn>u{)@7glWO_2?v!_S@**l#Jf3z^OpU`CCsG02r>dA>q-uRtZLnFb{q?^NWL7I?0Jsl1%{*eKhOecR}_iU?r5#n zI9A)gTjaG^6R(^rE=P(c=!YXsnYZP+rTo=tHcOSK7kvFfji zZHlLm9Q%e};Od%u**Dv4Nx?Zxd{*C4oOHB4knv?!I#M3=gj~M5tIr2jTV_vz|=GUXOg3pD58!=UJ7#u(Nejj^n@3Lt>MA#)7nXrCw-QP686011z z6Uebt{#hlnbg8qi!aO2?q_yah6ceSt5uZwYd2>VOK7aY_O|`V$VV>BAq}YK088<__ z@nuRD7Ozv3fH8hdh>llOFRK5yqEgA{$I0q2q0&Rr7ILUThyA=s)T2#>c3daDcSHVQ zZ7jaJ>llNe>Gjt*CMi>(tfmC5h318(j4FUBO)18uH2Ie%rk2Q5^)4%9IEMDZX65JZ zntP8AKlNRII?jZ%;l{Y#-=zAMigLX4#?pi$*|LwY+Ot^b$#0D3vfQX7!wAV+>?3ek z6PgQex6QIO=cZy_J2t1b;d=D8Jq#HK~)3ZW?L` z|G~&&3TsU)cG%ES#zmLM^vfWFALg!XE$_5Ls14yYj5*>bo$xVXi5I}#w5{2U0LVSDqbtCJKE~fQ8w7= z?J#*Ekb+$P-$-R(FQk}djJjx5yOVO2J60mRT#vSYv!gBi1j_0+cs47+ykI`a|HpBa z_A6U>c9jb>?Pn8|keIZXo7q%NwFiq&XiCeCLL14}QS~lT&+KP^pe+iAaQOpY5(=h5 zcW4uT;+|#kdk;OT)-_@^#H}9@OkUu~drTO>((Jo8;QonQ=@g;MDDB$6A=b7*YbAP_&zt zsd~S~-qfnsqxI%bN2D_PTT9BMkbh!}2yoj0QAzpc01BMcXzqx8B;U3%nXsZzY!Tcg#XTzi_mrauuUsgUtS$Z!K-Qmwzt*M&)bGj)s4C zllvj7ng)(t1nW~S*thXg#iV?xwQv&;tdOGQDhxz6Er3_@#^{OQsmW3H3U)eOV2@Pg zR=ul?ESs<3dmY1DcV0a)wynC3w4^iGB-kK${}YUKTpt{A`AbE4CBW-XiiXz@KF7F7 zNei>+hh*&(u#n=aqaW`%@67S&Teo7z^6M7is``4l-B-rc{+w&u0QX7EmY8LjZ^b6t zUo_);{whyGDK%xO;-b!sHOuC&8znmw4#@l}r~RSY(6zl^{Ylg@(meK{!h&?RCAaM+ zt-eKf>x}ZDE4MunS?4EFievi`>u#VPd5&en>2D_Hg~unvfh?BKSe~%r=v)WIl`hD? z$x4SfreyStRX4uxB+&WVq8$P_2I7=Q4mcVzB+J(Xxrnx$zGWxLDFLcT)++>=Jbnq+ zmq-skk=!27f1>LWc1D4O(Gk)9vU~%#iT;yT_7bu?*|F;xRb%&vV6Twtm7s__HBa3o zqmkl(rO#1EcJB5lAgV8T{?hJ8kV5NH^S5Ks3;z;Z`1J4HW?o~fjj=HI>uMOF*k%B?^9iAE#(*2W%4FSm2f z{q;Va-`F3%Clr|5WLkKvf+(|E&{uh=hGb5vjsnqP(F#en&4}MMuK$HPOl#-+MK<%t zb$%t!7rr?U_;KaHZuj6qmv55z?I@2*CqR_4sE{*g*^;uGzyBLjKiVy-BGoY5oW(`J zWNwt{;l4n?n$zh1OSrE5Kmuh9w`1{V)P2LyhjB&!IHC_Br~_`rA?=&kJU6&cb$3{G zDbw#vg0<#9Y$^v^3sgjP#7OQEOXYMMnhXgmJHx`zR%kb&;d~@MtbZSgeYF(n^(7CM zV@5ksv0kgqnW(9x&XTWXuVB@E59K-Hq-QRmnWx^kU-&lc^#xi{0LNwN{rI#ft1w!r zPm~NA#)AwD#u)f=vnOUkMFIr|3mLkCN(Ap@)TW~bL|Lt3@fNhGg@#_`FMi6_lJ>cTG} zBv1ed$B{(^1G}bAbsl|#MU%SrKQeDXZs>TZY&orLwf6w)Co#f+o^fTXE6H?RO|$py z;t$)8X<@#iw*a*a8>-di#HNh)N}B95;phqXe&EZvhLowxJO9R2&~{zcfrm`|?3Pe{ z_sT6!c0T5S6`FcOp| z^&9&4A%R%Ty7Q)+rqu6Mjf>jlk?RgCzO3Mm`@fu*fJoJt*lK!M_OZ{Fu+&D`yn^Je znEMOuS-?&O?;CNLN{1Qguj!NPtb6j>`HOo&u4gqL%Ocs1ZSHa#YxkX>TNlxYU${Gk zPBu}8IUjMHaTGZ$aW#NgnaKgT$p-Tj6Buc5o5aItytReU` zfIUW$Q>9U{!T)y^>@9yXHy7-dvd`*ESV<;Jq-9!2?-6g=c11Qko?W?_=yusuT+Pgl zWl4GrbvGD{d1d~Ns?r&J`cAKj=+j~9w4t6%qAp^Ypw*yz5f?C61^{3SwK}?gcg>ovOHJL9 zWxa)uw3mTm!C)o+Plg}>-G7a8l>F8RfP%j$?6Vc9_?dvH|NX&R_aJw_`}=Dp{F~Yi z8O6gpMHNRzb-HyH$8OdAap*|**&H$SteyV0C;gg-WfQ*IH#^M2Z>*<;$T5|rx?2mr zOPh;tWrA7xR=+2p;6MZ#}ddK}-qk@4-Wte~%V7DR&vfgmVGWP5(K$@Ov(n!IL`qF@B>*AD&V<+t9r;fAu%2}Te4>a9fiW;3*1`!^?dfbK+RBv`czHLVwAKHiM0*>vJEDVBt*P) zsItr;qhmus@C*zlEz*<5f|Og_!?cPJYxh-^`8$f@aOP_8jv`ZDh>J^`kSTpPTXVl| zq%CrNcmv_pDvcQdut-ZLC$q7rWjUlah*(mhd7%8ly`TN`;v4pJXpLTL?Yi=7;sXyG z_GO=^EE$%ww*GsZ3}R0`EqW}Q14VB%$>ji?O5Yw80A-f^V2Lw!2?RMx@AYQ)VLx8p zx_6rLO5_)JAJx29I^I+MB2~QD^?v&?X{+CEbnf$!aK|reIAxq7DiyiwPo{fDHfWj3PL8Ht7WnW;#3LT5Wt>TD0PN{$7`P zh&H8X+q5Z_|K7d?l=%e}$5izkdFy-lHSg2;Qiq5;fqnR#z{Dj=jh_mjel4HY%nrTY zyreF@*t>Y$cbduPu8h5cqrby(4m0dX8h>9Qc9B;;q--X;k?yXIF75X?L)d|t8=jKd zJJGnWAOG^YqQMJamn)4JHU5Vae3b*B^%GdC`&-J>^F&rgc>Kzoa6JTRWGqQpCR0hY z7>5y;K>IL7*7LZEpksXt_wrwG$N1f{H?(;>Qk1q_$CIk1a^K)WcTBselb^wXcN^~& zJ=E?c=7mZ{0zz`5CCaormpOTGSV3xV{RdyT2DWriZVt-U3r}wih0SD z$+IIo78r8stCqTZO4EwB=6m_gOj-`$gOUhQUfz!oBNiU9(Ip@1zT-?o*#N%Cp(^;7&Tj- zUMjN^5MKG$Sj3GxIsT@*OFN*PM_5W8$FjU{H%?W*bC-lJ;`=niwtry|-C}NcKD2%^ zW<WNEaeKgq0};Ha;GLb){*TZjusPI7kO7kDQAfPAJc|fv{9Ly@hUdV@58Xt}{Z~xkR4NBP z8F}fRug?I0|CT@fdtItTc<{m>JdPE=86(gUazag$ro0)i(J=%7A;}^9ujVXkbYb6g z?zI9Ldzw6W57b&xI*3NCvx_ZX^*!l8aAHtVPh0|q1P8{h$q1*trAOYnPRbhIL?U7B zulnXna7vZkkWz%=|9o=}3j2i>?JrRJSqWSC>dyC~90WQ))*}gzg~PJH*N~+nQ4Wd{3h0RpjYB<+X=w~u3YDy9ft zNAkpKT(wIwU(Bu5BZ^5t?MWX{lChb!&mJ%Iqw|3_mvBn^N)oa|WCaV2n9*lXKKduC zVM75Y71h(@*SIN4L&Z}7D%`~4{N%2;0>2f{wH`eRreTO-dv4kJa~A$41OcbKZ&@eT zR%bNS4IK&{9l*k9%s?A~uUwV}0Pz0$6N1NZ+rapVWUu;I-qwHVLvl-m!RCdhw&22C z+s2%l@R^e^9cj1-HhYV}9GtiS7Ff0Wr0IMUatfyo{iYvYqn?~Te&~L8!`rUzb0k%y zKDJ-;fO@iO*z_o9-x@!<6`g(|okId80Z3&OB8p)1JVMj?SNds6JpDsz=ekyNdK@$lSNFc`W2lAtti_*Vpx0|mkuvh5Ug+N6PQ@W}L$EfTQ ze%|&`F9a?uo%r9N)6$&hJ%KrE6bXQpCWH-*{^^_#^J}tndq1^9dDa+!*w^V7-jtkN z8kzE5-iY;P1OTBx=$D_tlsEUXKkZzvi~|EmkBeNv;F*O{6RU}!t3iyQe=5~V9UPsg zKg-1>56;s*o-h@}=c7mVDmdSA%jRv2M{UY>q+Og9L7|J^M$D@u0SE{n?YA3t{LiZ) z(0k!BH3J76!fhqP-~XC4B(tzTc}M^2;gc@<6PK{<&7cSu_k2g-&o+GX?B82>VJAd% zG3D#|p{cNUMPz96`{;j>b#dVWnnX%yn&P2Sico+73amnEcP%&th>Sq!e(`v3iNFHf zDE98t>W1bK&QqLrhoFlC14uQ8GI_)pAJp@9^l^G38h#!f)N$=l>f($@YI2 z9SZQb=$8j944gFeojiI(d9sR5vP?h=vbXnbe{D{IIW#H}BsYBm`J6t}@cW*+50H9Ea+8?*W-(Hk^ zMV~K@=)NGl*j+vRdl}!X+0b-xAM_z&VsIMQ<3ccl{tUquhLDkllpRkVXBBlb8XUTp zJv1_9wN^hpM+ob*9&TeR>36cJT^*n{CJimS1(gPNB7p$!fb2_$#-QHLb$h&k(HGWq zrgpdT?XEaK{`G4}`IhD1w$BG9lQnr)>KiF#nj)Q!AAe6>hin{nWFCjv;HUN{P=7eE&80>*M!Q$ z_XYn^zS9yF+A_Vn)ZB{=+67oEyB_6}z>>i2@*7_K+zP=K`&?3Su)${ zm%C<%dozzi=x|u>Jl;)X)U9^vFY11of-u9Yx_ow-&x?j>J#^Q2s6OaU;W-URIj!NK z5_Ab!5LtdM=s$szP1f7Q6oFNnaxtK`2Z83HB#8IFLeyaz_BuBv?@ZvGX<$`**(BmICj>f4%-w2v=MtbRFP^%+@yR%?nCqc> zU>w_#!>f}e3l%^grXR(rYNJVz8z)S-`=u@J3qGAxglpGR|6H0r3d{oNYQNT9Ym$jjicQ!Yrw zY^j71gZLf75lbvt<8au@s0<)59dS|4ZBBt-&=ZGY(cxivQY+qqR-<_9qoB08=j;XA z>d?|UOKxb2_jdm1mu(oIcD;XDFSgIJdX((Aqy5UQt6804kn)1fl!^Ok8c|YVn|%)e zlKYOv+{r$silvTv`A3=Q$Qqeo{V2MTiO=jKJ|-h6Ro!##OD6eDE*_fnW3Tx=Q!6WP zI=*Y|{5KE)!Q2yo=?dD}?3$bq1Ax-iNH5H<^pd-?cuD};1!8)ZT{h>-MP1-{|DQ>{ zlTZL!oty}3?56|qKK~fV9fkU{AS?La{6|$ZGrfY?I6CrJ<6?fp(ySUPiJP_;t+uI zKbZxa6S&tCueZx|=6&QP5>@BaeKFWdpypA(R_p@C8H@$j?*VAJjPk&J1us76av$nf z!;m122h~4U(m~X0wHt!^5)A*?Bw`nm+~}i=0l0;J(o8f|gC6wakhA@KRij{f$G>wnN*Cj{b!N79i-@SW+j0Q4LP!;1!@$yYsUC3uJD5Uu%(^ z(q!V3(fz%e4nrh+{;gg$#r>)n48HL=N!Gyf#~g|%jmAHd2Z`Iy%HQL`Ju>1Qr-Qwk z~L^wTD%UegY6f!FP#FhlyA8uOL`@{Wx z=Sm{$O|q0^%N0d;m)`$4EQO&B^O|guQhe@sm)_bqHweAu(KJZjPuqg0`egcMtQ}_G zX}_$z9*&H?$bXjBLS*zjyjf+h4L8EVrg_j(l%C1t4jCY_D*yQltV1 z0?&apI$##A3dL*;|Np2V4vF_y*bU9{cg)j%qfLFAF=hqDc?a7%n&O;T!4ghArVRTY zsMc(zh3q!T)JL}?!PH75HyWP(Mz5q9)-nYznW1HlD}x5B81|Z4On9MqTWvs1s@D>( z+PFt5O7B44S(CYri6w3~gP!1BR^{S)GuV3tp|}eOoVzA|x>y@p3wKrR0`&L<^C1BC z&nLf<1zyAsd!bXZ!a;5>mjzVe|%A^=?w!>$dmfK=#hUd9=F#KO2tE)Vk9OvprP?! z&eUcgSKq5jcTD{EiP>`;6TG8O6S1bF8!dQgiIo;J{=OsN`~!XFJ_K%h1+WC2)sPk{1+^G6LkfsZxI zMh_sx5Rhg*z*iT3dQ|6zY)WmC(tg5u=BX%FiW@wVtI%Mn{n(Afeh^aG4n8EJzHr}({4H9j%!-{w^qacC?}G!qOzIPlV607+q172p2# zj%^Vh+XjBy|4?*Xq_lluqic8h+ybsevbVM%u+kx|3=DP(F}C>rv}{!IE;C;?E;z=` zIj|Y{iK=r3n$AiTJ;ZH9#F~R;)G)DrfJvw!NY=zH-lgEd_NBMSkVZIEbUikm#v((* zTNEtQA$_F`AZ?i&xG$K9)Cnp)=#uSR8u*n3zEL5#k6_=iF}C!;8)Tcja;WO3TP*?$pHfLZ%4x8OK*!ur zf@%395Wo=ZHE}D;AwA74Z)|HtKB;m;zS7FW^5G$v@pXb&aWCmKf7NLO01(m@8X1?w zC3WS_HpIEh)h;j9kBi@4)Ait2+7H}%)BaV5ZfbG^0=`N>qZ)u_zinx)AhU5!Na-4F zgDnxBR_4lfmOazyD(+-yzcMWtKJLv%UZ!m3Wb@3|`R`0GWx$8O$uI{1TH&O^J&?Nq zm_AZ}Sva+Y%naVbV!;KBJ)!90emJM>zLm1n8S6s9$rt~X1-F#{3F;daTku#67o7$EDby?`~dD{_3#R@D2_P6!0bUpQQS!++1@?Rd5pB9OD$9 zr+FBPoF2RC=GSzyw#MReE?4J30yF?69Jk$v3Vk0dq~wnl#@pmmyiDa(YGF#!;=WB35z$*55@$ z(44ks?< zH#_HucxGW$)=L zS(zcp@k{#QQWk!pCrZN;VPIGFXYJ!?;0I4m-=RSur2e}g_*vQ3O@nlB*OneX7vt$C z;ZVvM-zSjx#jR?Er=lr(PjR~d z537cQf!#m=I7h6sAfcr+_?IcNsAF+B@oUupfC4dfcF8Ir0ac~|M;ki&Y4;Ib`U=7^ zBVEd(IJ>6W{o-X)cx!1gdq#q1WfUs@G#Z1w3SaZ}55MyJ>GWUCJ_7B~<5o?SlpdFOnq1(Ow~O3G}pk4xhsjQd;u*6x{!vYQ!6YCU^) z!&ZAWnf@OVL-DVxRx;^@g($w2Syvp@m!UDeJ<=Hzbr8|{xYxUS(nKDpY_2CHK+-Z1U3Y!~hlBHqHwxQm(0T&NE#Zu!Eb9*0MCs zr8h{@9kl=lo4^3xYME#@5f7E$PCwQMz6c3$nw2S&9iH*3PGEy<;pt``Y8R1+3G8`a zzwV|P&D##TDFlL^4whB5f5F)AK^*;A+==6Hm%i^)7U@?}0gnteOG!qUUhB!7G=+*1 z&qL6~bd<+fi2l(Ab$9zjuxj=kMWD9W;bA_Sbf{UfwRDH&*u=c6!?_lNRL>79+SbW< zpc~uI`VgDg&=9XI00Qc@B^9dNt*MNl00Fpc002Bty>caa$dw*2008tc8|#1o8H!!M zY| z^+S^koX@MIXMS%$@w~RP7e6#95(Z*oX66w*`rDT0C>IK9wf-0m{YZBBjwPT z2zY*YvWf<@+nCNXF6VP`lOwiu`e&BPg&wV9$#O3KdVRA9XF1Y(#k6wIdA*;4V%c(gaQ-|S4Td@!kz3S7^*KKDV{AoC=p|`KvR7l?v zp6o{*6mo(a+QEOI;cV+zhR(PEFc5))CO*mwyEMs+V?2lCl@y6o4d81gJGKIX#6%<$Wo&ap56 z45lC52)XE8r0C+m51N6L5i?j$`2ONx034eXyIE=LByL~;2v`())y6M4P!n;VluWhk zAJ6&!S@O!$VV}3=Jk=J$$ih`qw)dD^-yJ}aUu3Gm#h+f=`YHec!beV;nCNZT@6o%a zz~AdW`WZ@?In02djJ2cJ}A=1rzFp zZevfJX_V_^3V|!MP1>(EYCr?$)HPCub(X{c8#{o4bfN+g4I<~zf%fWdtsnpaIZUWe zjkTI*$m9QFzWL=S>y`9JjwgZ9L3&N~K-ygzRcJ6>@Blv&Y1w&{f zu<^7Ke_rv-0S6As*JPug+W-LQc~kuxlGd&#w8ZJmHD;d>2v>c3mpMa3TdT41EaZ@? zv8MRUH%*!3q}zM`ir=7!O$}|_`iX04aNY@gC!b%ThA&KUlZ)|)V|G!%0Vb*Pi|{r? zKi|J%Y9Li1bZH`AcLkVZF{za5pVs{BGIlee?mQp>I(u=RF?NOd8h$iO%6f9|Qo0fZuhmrY?^uCI zgcQ^EUpJKr*%W6$AUtz6nrPG8l_ZmM!Onq zo=R%|umBWj7ZY!B(M{6kRMa2#^@rZs0~mUD7Q00vj@l-TAWa+#vQ04elI+x`2;9+LtX%P9BuhU46O zlj14NAOs+iyFb@mFp-;%@KG(c)0+#GV~W?q(cA6pUbjd@-0!%VC7P$kzmG=?g)8(e zT<4~3?!s0^>%Of0Ht*Ov009LX0-tij`Er~*UjFYo6u*$8vNMlk8oU2Tb6pA76h;_Y z4TOy&XHf8mR|`%_Y|Fbt=ooD_02&6~3gu7z|EJnW8OxWcCxi(!qphwVn5&m>$3Kw@ z01nCsQiV>OX)95~ZImLHbX$F${T% zz-$06*mq40Y#$o6L{bopN^tuliqfh#Dw{8&PEV0ryxXWuNf8m!%th$+a5etBe{Re5 zI)8VE|3ZEle!obV(Ge8t)CSUb^u%Vl&&xb#yt5nswLQhG)P~lgsc}l#0<&+~*5r8Z zUT@QQCTplu^iELrGpl9t+;{NNWtDTi$4&e5T%T8?+*NLuBFbMU|4;L&_r5)Da=QGN zs3nX-H53Oi!es{EqJ1x1ScWN`aq6VaIsgP}#yN*uQqAAR4hr#=q&oun7BAN7zyJ|4 z)vy$V`zr%g-iC=NY)1)-o%*HsfZ0hCLP}K`p%xuX(QS&X!W73oY3f5ACVumP0A_JW z06oV~OMnL2X;(WC_}lI@&#i~?r8c&4-QE9rb4B-<&(KYq_TJ7SZgDI?1N$L3hb&V5 zn|C>K&Tex^T&u7EUm*xW7bN_)H0S}udbd0JtQ)ih{+K=D+thxI)1#}s&%5y6^!J{w zyNtSU7q1Gpj;jrD02O@ae5TPY00xhAR!bJgY*HGrrRZjq z0t^Cy2u&M~N3X>o@_^g5`J@<`W5;1?=AxUyIjuflYmDbXfCX`cAE6NA7J*GMB5E}h zNVH=WdIg#EzsqjMZJYBl>%-Wlj5@LHoQbuQ;=O#2d-I((`9wSPAX$2EcGHVMt!U(j zC#5f%B$$$^%Jq|BA$YO6rvrMN-C~k&G(uV}o#y*M$~noQ5f|e7&*awc=U0^up)T4& zH8W>MbEFW%1ryh+^wYwyWSesT8%mBh4pIf|ZSthMnPG|Dk3k=ei&Eq_-Jj(;wTJppQUl9R$Xr#b^Kv z(=}S8bvI{C>@riYI|!+WNcQ8$E31G2Jnxuh$nGFoImNV_cR$NFXiTywn??=8g1Fwp zQFe(-40LAz19)G7!~JSq{6?hy-~n68P>j;y5c39!@VN^WqEZh{IsQ99)Xl3n02d-l zny;?$9Zkk%1kY_%7ZGl>iXwiYi*x!aXxFxt@fLp=vl=enR8Afdq4(+2dok1ajzxXw{e2b2ae#yqk@{*B5)y0~JmN5>vOoYA z+1l0=kH^IzR2Sr0&)PpflSZ+p004|2T{k)iM$cTk*mG4 zde)xE`9}i0=}$bq7q3y200Fs;MH7fu+Bm?4zwIEkamm2!7{(>W^Vz}@?!wYYss`Y~K%|Re{hl?=|H1^>h{5e_3u&yav9r#S@4rm^ zQ=@Ur9Y-vc>fTQ&l4Av=l=VZs6ol4d)&bWPK!sO4sX=^2oB#n`dWEiVkB#1>bGFwn z8_4;oB!2h0f}qNveWY%;+q}NoPg-i-`k(i%5jWQ^tkzxKV>OOnW)m~=e;23XV^5)1 zEPx1z1@FxgV9i@Sbk=ognVoZfz_ntKF0bRnCWU zaL;C(x(PzCr$U>p_=Vc6>hN`bZ;T)SC$CJO`G0Y><|az+7p0XWZ zZki3?fVz!900wK~4R4rTPHR#8Jbrf0>tYIrugYtCI^*`j`3{a|di7q9y3%%88QA2k zdbJU`(zA$&(73z3bgTUO>;xeZAJil&Cn^Ob`ITlRjeBjzbhkUJ0003F=gkFKp!yya z;?L3Jb-jyw_WgD~7<%O3wQ}axe_Y(Qg%^7(kD!Q;FB?9YVhDiXak~wks?xgSukY$? zbGzCc0Hyp;Pae9`{Y#JAOn#5~bD7KTV!#kl-2ARC#cCW1 z%OGXwt{pws=kh-0_43wjf>2@{Z7oIiwqLft6;oNHkO2S?Oqc&@nlCc%$`Lp)Y_VZB;*Agczq*x3LLwgC428ugS|p-$)x4F0gLyqnok?N+^_-y0vH(0 z3p%gxL`7XLSM5P3Nx+V^O=WV7?@%((9&(b?w<>oHq@gXhGRe_VAM-4_ax>8g-FYW} zU+@)x1VBiS+B0J#)J4_N{F>rdt6+2+Yq(Mm;gC0G@t?J`2Yv+obh{#;GA=; z?76(U01NGYZ$FER39TR?ASRUy4$Ed(xqbHGw}s+V$-C>N<-m60JCPWw%uMVtb1J_N zT_Z-LP2Y=KbLPnLE?sJKRohtS%tqh5pp03scuVMpgD zPL@|Pd0($|{+Rlsbk2=wkey__000sWm$)&>Nn7GgU@oO{T{`A&Jt875Y5OQe>DujI zsX`Brp4I>gz#P%y{Rl!3-*umc!pe6X z_h+J2#`u1R0tzPu^>-g$4$q`j)vDw5cr#7sb^4DAx!>tz00QxG0zE}g007j!JL;s` zBeD|4>SGM_YupbPHBQP)AL?2xWXf>fGHuZ5isyL7Apih?Q$6XoZYta%OTYO3YS|&) z3+~BzSmi5RT7O5=CIA7M7B%pM$hr-#-DLOb&3^qASd5Y*NY-Cpl#Pqvt1U+vUo^IY zGP6nJGIb+Mo7w<~kP>S)GgfGw6gOhmrZa!L9oHDk=RW&Q+1?tNsHrY{n;g9qXJ(_% zE}^WY@>um+`1v~%znV?t{9g}&wEemazmsKU^(xc1?6oyHjXw|FczawRsGn|gOJrjq zM^V3^B_1u?_k$}3mYaT@S4|nw?euW4zilDkX!|Y12RJBSvm=%O@fSNM(xHJO&g*_% z-u-9Adlj}eLa@j}1>yn_0%S})N3V7DE_?08hyY!#sJ|{fy~a(&;W17y04$$$ykpT| zkf;Cy+C$*)>ey|%B}LWgcM0#}J#NZ04}dbRXvtAf0054}CIJA104TM3Spv;N(K7lk zbhFEn2R$C=Ci!)#;>O=r-Fmv!62yf04bpNhAb?*W0Ug1{BJMiG(dGFib(!ez&*Z0T z>c=Q6P0Ajx?(V2qeJhaJp9CHZ0ZZ>~U}&RluB%fo_FVWp?@#gPFuJQ~d6SRg?CKd9 zCCYPZ0pEOCx>cEq&;ZiG#Y&zu7O#FVEg4G^Yyct)EcGAst7dq8nxFvBt=e~4nqZDY zkj6%&1VBV8iRMacrZlTYLE!c8yDY)IyNXpR`eGQ{}ICt)TE(1;%W zv#ZE66DC~D9PTWf{rQ7o&aC0in`@mp@!dtRQMHntZ|Fd^cEWH*K7KI zFJr&uJBuGroF@^Aewi4)ip0iZB5I{lfwIx<&En)mnK8AlZTr` z03aev#poNQfB?De{4Lx)SbqkTHNPxuLfUZ>*z-UEti60F1`9gu*ViHA)|j@ zau2CgWwaR-t*xN#o~o(PFSY5c((8so78swqxjMe1_x=F^5d^<(?!%u2_B#d0CYFDS zvRl78oX>#x&BvyH_sfEol8n_a?PJgzNWAKrlJ=OT<}dQsH0HC4pKUDgQnk1IT=W1r z&E_uv0MDs- z1=>4Lb;{+#DCk|MrI7x}v)Oy&wtxUrvR*5f+L{wyf)JB~MKD4(h3tZWlt2Oi71DA= z6gdXWc-BUZ%kg8SFCN||{xzd0KyZ{VqTYj3kXYziEUSV55CEGa2omv-wI5WmDfUH^F!2y5 zT~raPKZl*ffyfrd5CHM>6b%3c;Yv%4okaH&N8%zc*#58Q0uS97sIrTnDCmXaM0);0 zZL>`#H(wQ#tN;NK3sR+YRjn)k3Zqi{g|cxL8I4ZNQQg0pO(o~NqWPSO(vZoo0033A zp3%x&T05(O)wCPJA8PN(dY}LmurEz9D`-9;Rb>DM(Bc_4jo2{pvmLuNmh_|fi$|??*wfp9KX-#HcqimjxVz>YbC;19=v|nGc`H0AUv96- zn+w#U5TE*=z1YQt`jvcG>dAttkGUG2?TU?~J zYi;wX?IyOLW|=`wJAVFvje!6F0+IT;+Fbf|W38Tz!Jsr(KY!1cS=xE9Ws%*nAa#$w znG_zF8*1iSQ=saV&L|X~dLkk%h1s1_!%s2qUnLZZH^gWH&k+eA&&n@;`PVBnfe*PE zla*-(y&N-4d-slA#Dll_R}lXy@hWcev39l zYrXo8K9ai3lx_AG1gb+G7xG`?t&@wnRQl!@u2&`T*RWQ%)=K(G^r3e!*JT8QOm&S6 z?!$BP{2Zs5ZtyTa8Jaq~MAaeO%Aoz*n2K8f01+G2xVdgrQJ4K$+h{-l4D_T*;gz}= zNPGOBpkU{#Sm_6I<0sqYtmKSxiTN4`)>+pA(>esjrzVv8-b>UZM8t2h zl$c9}Ox=v<>W^UIGwA>enXEk&I+MKq=sl!wN^!GuC6E2?zpHf?AA#F1}lDH1--x2i1-1W7`Dpy%eTr{ z%*Bn0Vb*0J3qmg$@qhp(kO@4IxX$lS!{TVj_z_5fLvFNSIDB{P&ek S4}$^!#oUoj6eK$Hp=&^<KT3O400x1O&>92O8Z-cC0MH^xnoShgfi*obG-;(g3VJ}=fsH`WXbq$fP|yaM zaf$xX0^dpqG@~LX9&C>V36Q8)4tL#j6>BO0RzML#<%&=buXS(B>GM|NwZC%RHj_o7 zbDUx`hZAv8NwOy<{!64?bA$eKgQpN+q>GKowY+V$cWY}908giImxRB&=Et+{Wu?R* z#01U=&@faP8MF?n{@uCy?1#5;|8qs@h#|7*WsY$bZ3J+j*7{@W&rqwuQUO6=ghfQq zfJDavfE+IGZ!W)&4EOitM~6PdOJY<}<=L|)FF>Tc4Bb?f^oll2)r$1JaOjRv!D&(U zuS_qbmHML@Y}bms#VyA$&z#~u{+u>tuFD%#HQ`rGp+>6XW7^B2BQvJ0QEOfT7{veRnWKG`(S^6(wHGXL-Lp(Ex*DYnYf9&p zlBV2gWO8UEu#ma2YzC?{?8*u;m*daeMC3xfkffp_sa{5AK?VrI5RrQCo%BL4Tdl85 z=8T=?*=orVuKl~LOD&kYh26qdF9~;dEs<8E5Mw&}ZR};1Y|_i4fiT;$WZnouNF-#9 z;}Y??!Z%1R64a7Q^LRKbx#*vq{_)bC+cM_fC%a&b!-sRNn~>4F)cy;j5; z*>y)Lc;RFgNOz%<3lRdSG>rhYhC)$^xV&$sc@8cyl@_4U5THV;LIfZM-v7!%7FI

wM~j+9hcuJkz_iIYZXZ?jE6&wVo4mFJ3xNetIzjp^TGQRNdV)7)hm zyIaX;Ldfcpu&p&J87cySBtZ!!iF@+1$Rr}}NR zqk{++h)ZC?L|D?skr6~x5o1$ZF0MgkZH1*>ND&*HM&-HAE;%wuw-YOFS2)FIB)Ygj zgdr7?W3zeAgQ}H5R96ZDibyI66hKZ0ssl<96+aX~00PjoDF})ewJHi91W{E3QUM*P z6jY!ZW)v2}$mXaM8_S?R zAPFLwpe6LAH6S3MAQc$uXu*;Bu13l z8;yoH;OL*R%Ac>-%ki{!+iAHAve6M*MC&0EKoU{N=F>y83 zCX%5L&f>)Pr#G>$OO1Nf>Uw$P`kx?4x?+e1s+Fpx6Q@#vl+n8?nHUxTf&w80Hoib< zCSh>OV&7;=m;G%y52}qHb_*M7yLHn70cC0FP|(_gA5(wI3923Cy5{aME1qdo=^#2t zh)J&SNL3AKstr##fO47eNHub}0#7=40x^P6pFoGuqtUD1<@8+YvEc!LIkg5#uXqOw83n%g<2N6IW0qiw?`BT;Tmk) zBOGZ{A|RG5^1of9Y9x9$Sv~Q!BC%;g{K^H&C8FL#uO_tEaCg}VvTCnjb@yKJ>z=wH zvik3CJQIo;!VQVhH5nnGGi?u~^3=^->TRs4ksVMKt6pYUn)Rh?X#BhfWhXwbIY(|zpEs?&aTM1(?scOg(2XM#W>L}ZIIKt(i>o4)jw=JR`x zcYF}Lco!z#E~Nr)D-(c zqT$7X5F3`vJOs2rID!-a9Rvf6H&srHn!!f|tt)Pp_Ft;_?x+w=TVUHXFT_G4Q7CXE z6e3jDeimNL1i0~Sz(Z}vOt8Z?nk(OC74ziZQ!cI?@1L3KG#(2^8f2)EQ9=m5l>OP2{kjbzr@ zX!_Bw>y9zJj@k~yBWHsrV4YSa^r}k|SBVNOAfXOwwk`B+8>vBPLFz<*&v%gP^xxOb zzV`9>&rUDu0NJoZp-c%^AtcKsb0}(SGA-x%+}-u9<-2tIP(AJ2b=?+QZ!pDsT~-$b zEfsoXfMvIta%8B`3v9FVt$b4bx^U8zS0vTjg^oF1V2NYZqhOF&g;9|_a^T}l0-#8GDrJy(v3RmpX+|;EF=`^W?(=NXb5D?Y_!c>kc_Nb!&civj%oa_ zUwer(&m(eF=v=}m=+6#YrqLA6Mbg2PB;E7?JpnIL=cj(Z!?v&6qai{;>VFw5pA!<{2C}N1rFO7M3OtaS8mkiw-=uN4Z7={mqO<* zQQ+pFEg@ozNM$r^Xo(9L8!(#)Mi^LC9M=`*CefcR>zh{L zdk_Wa#gOmqQ)v8_|N z1Poi`$G(8~Mg(IcA^>#!{5?j_^s&$6v+n?m?7?p5kG=hQPTY?UqP=@B?s5TnueL)z zUL-&`K>+blrlV9i-Fo6S%3{fj+d?2@RRVz90xeSA$ms~Rb|<534o1n6ja)3n(eVl1 z0=)hWbJ%gZ(AEbCCvQgb@_i1O~3k8E7d)x&jsY zf*xFDkyBPIo(c9I{8IgNi_r%xiUWO7iaVQcV-}*w1|W;z)kCO5)S@+wWyoY_p(LLI z_<;bpi}I=G*70y`1lXJXCevQt9m)r^1bt#m)H>e+I)mv}2tff5Ll!97OBtGqN}E)TMv62=K^A4A$&&_| zVKE{!h(wzZB@GIdD545!HMAfWZi~jTjZRp#2^2sx;GS|x1-LT;G4fLL<9Q=r!S*2p zl6Xf5d`)_DBye=^G>H!Z8&uK(=8f3x)4ibswhH$Achj%4Ff54Xf;g6l0%zANDd@<) zo;-d(YnKL$A&dC`)8sbWQ+3 za!ig&!))bQ+nsUFQd+uhmm2C=)h5+OuMMdZq_rDSn^6{umcWu~*J`!7a@$sPu3J^W zmMY9!Cy-;x^X3ttDywg3*27GN4Tf;K?N&@AM1vs*CmA_en+2fBssbZXPHdZE_1+4+ zwN@#$Xlk-9VS=Y;M@JoS&2g!q;AY16;1m{c_lXTQA({9u;;rF;5z(Pdf;BIqYq^5Y zi$nub3^k}2r+0Pw5H7Sy`R30O2_Q6t0S$+g2=i~?8)tlgNj&hn_jHg5ts-65LnzR; zuL7&VR$H9YJ$rNF>*qmvqJY+IcVTP%elppkJlSDO+<;1`ro*%@2Do;4`cx0KU2*RlImIp zk!5yRJ0h)HJuQmj%M&l0*<(?aczG45DXX5FT^43-7LAgisEv|}Ra&ZZ<_%3TJkHO_ zo_X+U>Cb1T)<$ZgAt+HsgqkF!7-B{=Xre_MA*5-N#ime1Wh#SBZ9Tt@UXADPUF>$# zK|~LgxGA*&lkh$M{n6DEAP`%|06_pqB(d`Cweu}&dcJxplxtH~5iBhNNeK`nLLl+$ z)?YNz0F2U$*04i31hFoP2B|zKitHF=!&+IVH;%9wl0oIZgc%6z-q?-#uY!Li5`nSj zSUcP118PTGp{J722_P+RK7+4d0@w&7m%3_}2BJ(MQc#_tdDB{e3U2vk&3b&Xsmd@* z`qM6fZ=}1km?MWCb*m;d?A<%}=P~JD^LV_Z5K0LCghA62wG#p}K&q^?#Z~`{xgwk> JNLj8v4S-li`91&u literal 0 HcmV?d00001 diff --git a/inst/extdata/impact_method2a.rds b/inst/extdata/impact_method2a.rds new file mode 100644 index 0000000000000000000000000000000000000000..6bb4befd1a7f3973454bcdd8661825c372d8da58 GIT binary patch literal 14813 zcmeIYcT`i~w=a79VnqQfsFa`xC@u63vD3teh)7FNnn;O<4(nRz##F(joaO3IakD z1O!5&B25BOdQC(^LXRYnut`WR@BGfY@BQ({JLkPI?ki*5&)8$_Ird&_&b`*yYtFgm zoS>AQ|Mu^YTAbKrJh(wNL;JP)pFCIgbi0f3j}uj0d-IBK?>9UVbv78Qk#)TH-BS(c zv&P9+_nqba^XSUSBm0jsF$9T(5761;6+xA3F{HFKk)J?}UR*_E_#r;RMQ&HHa>AmG z`-`NcBtjBJ4kSnU1+52mj8RrBtxjW-u|V(wY}Zuv!ntH&_n-J-S{=Y9Wzr1DkPE`@*5%M2~CEJo_g`G1EfYdLmJap&=W$8X|u zN(b*xSu>aw0whaLu8NqX8_E4rZWFi zVET0YXP2tS+Y>Fc{>zx-xFO?CAmd)26a3(q(zi@hiqhZlKd=9}0{`PzfK5U4fL!A?w|1OZ zWOt(rBdWQw-*OY{l$arSSbSveOaZh%mhWMc(6Zz`_gJomDY!HHxkVybE|gEZ2k*>I zY{qw4@iK6YUWr8Z+;o7s=Yq+)k3fRJG%vPT6Y7I*{~XeuSyT_w*b9XdU!K46`6nx! zJF$(ohfC_odOwrVbk2QgbD33L)Is2-`q4Df$p~&c7A@L37EGcekvr z1biTwHah*9oWy`=4xN`qY}p&RFj|8thu=yfO2ymcq;t-Ed#4c9Nw6XRd4&FD&$W1Y ze>EyZfK|xg&U%++ToR+Ye}$!{IxrDyrVGl8N_H^)kzgiQL7wRvE2o%G;5`I>hcSA( z9ZoQUI)LV*X1bm5!}(nQnlvy_pq4eIXaY5$&;r-ufxWB^3*q)K#V?|{1cc!UFiv5P z*FnKNQ{;IJiW&}-8p40EGBbX(l7@ZopvVY{*28Ioy|8GRaW5jz@K(*3hhnir?$N zqn|}fWzsRE@6;sggim1|B@`P-#OxCV%y{F4jYprk54EDITo5m!P>UmW?WCs4vjU4rbz<8C|}_HimD=9t~R z_^Wc4T&H4@jrMr-EgN3W9oe)*P7CVgy}SePBS^ozr$K+Q9_DhMO0#+Msx-}*jqwyuHONHvCJj3OCNgz4XuFZ*YuPD()g+|Q z;farhBeh<~YJp@`U@iIE{PE1NBTLRM-BO8WORHN>SmIfN1JGwGsO$CyEHBR;I=jvM z(P0ENA<^6j6F9tw@M@ar{7yP&dEr-(_!H2FdcAJBEu!hrEM!~o0&oq( zUOshOfwy$D(_L`1hV5EZEGpw!@W$Gbb=k8mA|IlkZPN}z!rIke0aXWi(cuvVRTkB3 z%*y)NE*FJPnv!Zz9-`qnN_fp}wcY(*F5`vaBz@!(tHsvyTX(3h?e`k3jo!!__(y{9ZY*V*eg}UM07N2{87O;iU-Gck0@>* z%iw_GCiCa9dN3*8Byzjdfq3 zc6Sstq>6kBE_iVED`bH4!XqZkyRf1RQv(~CQ+=nxqKMocaZd@TW*z$wr6`x_9a3-JRhr4z#2;V6;I1YP|0W$6l=kh(7DWzJ@F)}C`3CC>B%bL%vx4L4hs#k=1 zIa4ItyhoY)=Ha<~ER)wES6PUhn7XgTyPwT_tR9&M`O%TZ% zI(`KWp~r;r0eZ>LQXJmX+M9^*rhX7F5kNYw|IaHL$}n%B18_H7#oR_202VGUo)`P~b*rATR#{ge9i$Jc z`C&_@MYCv1`ST%&7Lk$3Hs$sZs=KDy&XaRku<~zrdA~P~;+MbA8x7e_byPg>i5&7Q zYA1Q(uQSi7vE0_6c_oZn=yBnI?NoIhBg|84AMX*+s{MQ^{+>QaXM?-4C7PAM9aH<7 zrcWr`mxC(L1S%d*(d7yS^#u20oCU-5J<3jr(fzCVs-kmcjF9Eqxcs`cO$}M#T6EoZ zY^8Q6DjYs>YBhq_38N|BwKDz5VV>p!&JSU-iMEeX%lMV`Yf(1bXGM7}C;TZj0+6nJ zq9s=&L2`ie{W^l<%OQ-GgH3;J;kER)p)4|cL^lz;o3J}s>6k^^Zw2Scrn9$dX1k%x zc~C`KoZDKm=-TXqxCCbdZmQZtO_}d>2QspiowQrNVsUzP@(P~O`pd7&t5HLRpESg}RqH(NILN;)?-F1rRUk>XjxoTB4Y zj3i9&FQ49ZQfaycYJu3Vq7#%iy`0O2lDpsDZfz~4j+MglODeiZ{6~xRZY{Z#@`#9D zF_BtubbZ-brA@Rm*`@Q=c8n0n3w)jMlA0g>AuJP9m^@2NLZBx0Jpyka&#oWw;do= zWq-sfSm8(24>jUMBq6RXa%H}A_rkm?WS1At{}lf`4U1db+tA6Q zeXxOes^>8I8E{qQ8oN&!Ii$CFV^up$)S1H8Hft-hL^));TNex2xD-J47Zr#f*mXF4 zw<)j6@;Z%nVVp^){9$D(D8^!=9HE)ONDEs5_A>|_mKHImTW9BereDK1!i<+CRdRGV zOr3MEs-Y_M;VvG;k$yDTE+fZND|_a|r;J3(Cnr()tJY4zMx33fZ|xKnbHtRiZnvMe zt=n~JJj#!D&I|Q7zRQSjy>MhCceLaTJ%Il59KCgcmw9kljAhj1lb%=kp#{=t76h)` zp_cz$^yNfT?>i{9{u^6{W`BaR_Vn}DU)Fq-qpAFbd|@k&gK#|pLfU2lJ)@7D>21t6 zC35j3^k-R?Q58Oe@ah6Rnr|*{coRUit293-`gIuCA|?86qj%4MF!zSZuuBFMwhJvo z>I^xw5m&E42YM=|trOfLkIlJm(Q9GXys0v*+|&2(380IaZ)x&msxbSJ-c$!J$L(@m z?#-xl;6;0%P%$|pXI8Iq5WX~%-V?jQ^Z7G4dx`JU%ES8wj@r026N@=<9=E!L!#LJw}*j_Y;plOlWW zIi}AAXQSFqcImhAGKMOYJdBAiWm<%BAC4nVJf<6~VrU`kzh>Q5n7Nzyw2wyof64P` zH>x(_^RIViRQJ^A1rH__1$cj%GMUfAC?QWp$L!|Oa^7wQUg%5i3g(8Y@KgnzJnf8b zTY^v^McnhfK9D>!^RO+;wKK;WL9OEX!#U?V`L7-r)h_T3b}t+dE*SCZ)$0&V`+7*9 zLnXmE!$NJzmA#pGA!3lp2L60VE-ZhYyO(35|4JJLHrqU0@`l*%r zSxZD7VpnzfQ??%(db7W0F+Go1uj{kF9Su80amgl_LUV!oS1s3@Dee3Yit^C@#>a~} zmu)$b>uN$?$lE!=ib$Om6tT2>_@p6X@W!2HRtp17Z#=v`%#D4Zc*#@P@y;ye3g zV!{@gV}A6otGdsQ6XL%9xE`Jh0sOmp?iEjVVmUL(HkrEf&bFP!bECz6`wV2Z zGx}UOsllb*H3thRDP;bZ|3MISE)#cj$p))RDpvp-!Y4y+J7JZ!3T&Q$lU!k82R=MUeSfhy5Y0Z@LBL5X{g%Wj zB4Hc^V@K||CT6|(^o97(QQWex>;W#m-$^=Dx`C_)~dU^!@=Vi;posVMw}TAJY3zf{BlT{`|!A~W{EajLt<#H zZO|y(C$z4mVUFCfevpW7b9J}A13yO&>{H*?TDqOdkcC@w?MP<8Ddzwcd|@Ax5h<<0 zIB9)>dMXaK)B)D7$!r{^ zBbbms*Pk4Dqn*kA>52}yIKVBcueU?=md3L`7MV+DFDtJmMwC34W zaVYMnbfBO`#aQSQfKL2Uy|(Fr74+r!hY?y)PLCd^j0Licc5BZ$Ms=E%L7IkrSCg&X zS(Xf?r0Gp}2KQbyT1+-jnse~WPbv)Wdrc4gY(?o^(icfaqb`F6Tp%Wia3Z^q==mqH z3Fbg#ul(6IShf>(97AbeJa?MW&IARFGLv!wR^qE1KTtDn9r5B0qzo!q9c5l5UspFJ zdq!yi$*zvz!`6p17SA zoE?raUXGgs-Fyx+=u%P6e9fjwPfwmNXf|hB9b(Jm?T>p%N{)H_>~gY>P>jCfYIMq~ zoeYnH^P)nst2sI8s*II*ICs&VA+x?<`T~{H@n|`y?_Ebhxj)=fQ~UzeK9vp*femCx zj%r;S9GcZe)--Q7OnWuTY-&`zWWlJ%O2pBH%{?FWx!F=CLxrC#b4B$AqUA&CN0h((Jlq0=6HlFOs`1=ZTlJi}mWz?e%%D>idbsCJXUUp1>*eAmTP7e6 zT@I^00;QY!*Cf1;^CPmk(uhN2wZ8I5@%XxcH9y)hX4APYLRL#5$y>s6AaRc}6lSdP zn6oGFBBkWtpn({ggwOj<4^0{fNt)_sPxNBQoQ_j->^Mqyui3S~laeGutA($Nm!M|k z{LKhidwm+yA6&k$TBz6jYd1rgj)Sa5{Ak&6tC2~gE8K`4=U>|VhD-F9C)V%T0)4_u zd>QQS;}~(i-9QSjnu*jkacbA(Xke}*#&fati5>9wS*drYG4^;G^8Sd!>PsfA`RMva zzGM$Kcs$S5>BXx~p0LExR3`QWVXnq3(>-zru;OwgYW@jS6TJ5=V%#77K=e2(AeNM# zra?GX{ZfC({sHM9N*}LW$$}e<1D`*6f)*q$`q28B3}Xs)vX17LqEZ3Gy7<_nB@;|{ zYos_HODAO{k&)b6=eV=62W!fixXz#w0KL0F-T^jTI?}v0YR7e3F9$&$g$_XG8d2Zs z$z<|rT4bYb$)!Up3K-e&sK&IF0dm~WqQ*RT-k_>@JT3gR$q zK8GcbNU>Vz|u*JW7$>T-?n>GFOFoJ@Zd+JP@@bzA!w;fD?T?p*LxsN~1TO zSs?53pk(ingkO7jjZ2kfOGl`?(G4H`7O%5hOYF(-nSSW8*QZ8dPPvTuxqN7@6pxVh ziMsDkfY@Oyj1!&G8MReT2kRqvN?Ke=Z@0Z`(~0RlJbZJIpNXt66Lurs(-@|0r*!nH z9s)kc#NoDXRM6DUWUD{=4Ea7y(c*b7K|4QMA;kGO;;!liJBQQ_WS)^mN7L7)LR5R9 zebvZ&Z&rf!QNg#Gji|JIxg(W82JmX6Y00S!Yvzq=){1>}0GSXh$UnZU#4Q>n_UaA_ z^$EqzhzElTEcdXXD|)_g1Y4y*-i|QMOkLOgU@QKS3Y0P~m{oFv#2aoqQuoNP*n_-h zJ$|%;mYJGc(|x*m2+9o`dRC(NVozqVE_ToWa`WepV7YZ1$B>H3bhjt~n1!Li?7OU% za`#e-zCSws$1hFymOLUt2^FNA1N6Q=RH0bDsgH<>>{lSi%j*RP=4Hq4fxbs8;~?U( z+T!(S#K%yi`<}^0EndD&mrO4);odjb?r7~C#+TTE%w~CN`#4w{dOHa1I{Ey1*H7y1 z^ND1v$1s6t|SrX2E%@f+e* zC!fxy`qoke%gce@T*7`_zl!FbwH~^r!F9vJ4bL@qU1wVX>Xz(p+2Q;k`YZoNJl&NQ zTj9TW&ou}=RlNx3D+iz{QK(0ry1cBUl5IO)7{RkmZb5IDBX3rY^Jh*ca`7(#7bp4- zoWQ$rZdugi!MyPJ;UzQbVF!BGnU#U3KYN+Y&s!9tTProe8hI$+M3Nqo(<&Pr%h$>j z)VcI8?ontG@dS!hxtnC@6#vq`*1v z(%|pDpd_I$yY5&lY#@u|LkZJVk(;Fa(eE0nQ<+5|!o`on@X=@vbCBgZWMbi3HN(8V z)d}_;S2bSrtm`3L#L{Y^{0C0GdCQJ@kYxDJZSKpMDtb3QAi~o(Q!phqU81J$ zZ-4CEYe5pj+!;i2XRz4wey@TXLKU}|avJA3`P zRzRBF&dYfs#AhHDsi$HN#i~I(tPM}|(3;2;A2;bHo(c|;6Vhvg=KmW|R?BI;Q(S_p z4?j?rZgO3n;Sz4>(Mo$M=kTt+C00=$TaZoZ z$H%0u)po{Sr|#EI%yNWL+|I}7BFqycdJHSig0r21N5Vp)_7zoxwJ#>+!AKaF_sv`H zgpTZHqCx!kF~md=^f*Gp*Ca9a(pKOC$2=>!59s7IVwNpy5J!->JTbAAqJf2H81`$` zaL&{PonO8xAK7;iy`(FQhSkb5Dc$oeG9InA7%8Wz@iS9J9khmUf0dC= zQM!=_XK`_2M2HwkbaDKxoq)-Ce<>M=52d8kb@>LX)iJL8_Q^dC9>W+LBI_5GS>U2X z(e#`xtL9nT&aKfn_}d;3GICmqMfn~+&@poyG0G9W?W>0yfnt3*j}O~&Q9n(&)qP9) zlF+jC1++3#xrNZhxoh=>4A;6mpQ_n&0>b;F(mGdeu^^nTXlnN@(&Sl4Coo_;{TXmV zREl08U7f?U9EiO$qsRSg37Rqp{sg6uUk$l8I^e=AiXJ_50bWCNzcM*m#7g_X)GdiM zrMwShz}Z%d$riL7h7#_V$aMBCrf$O!Bb@Qmk>2W2PpW3`0Bld~Hae~ngsac@39k`6 zR|Q%{cCA}Ov#|=EiZ%uk{6XaW-$Q3Q1M;YZ+QEBOwQ6ANgz6C=A6u?zNu>NX=j}|N z#W6m5_Q!Fs;duAAhcyJC-SAcG(VSck{y6>KJ!Kx;+Ho848jdi{&0|L$6N)C%7z<6> z2}a1DLLp_Q4RwoLJ1?%?oynXCQ&|g-Pkccd&dayE={HP+jybz;xY0}v8O6VA;LL5v zH)b&KFz6>tpPON^Nv)P6gtR4u57q zVLdhH@=#HN5uw6tE<&)#jo)}8n(B(a4EuErPyQL(y+fO;lx*wJ)1XJiL=SjmFwT)3 z0etIpCz=W#X72SMo`XRe(YUXw`?y4>t{36EnyPL3E|8wI)x8(E=b5@_B_2$W1l^xc z_f|QB*N%#q{v0a9E&Opn-QyOY$v6+%1*?e9AbmOa(xcl|x&Tudg4@iLkT<=5=@+GmgpnHp^$`$mt!46!*y?MY!oli?^38; zL447sGuNGODj5jo4*1Ci)oL5iRc=oRqcD6NpbfK#XXymWqh%Fynsr6{Z;9OQob3fMcz7 z>jKSrKNkZJjVb10dIN8U7Ic%O5zGf&LAi|ZE8+0^Y(RK4#I9AvAN?NVQ8&4R)zTmz zQv5v^ytlhI$Fc<_IS=k`9m<2BnpC~^4R6*m?*WC#;R0Yf%MaS9mCX5Q*+FM!h#I2N zwf>E+_y7{uUvSkHd4Vbi?XG=6X&2>h*)H@>%!TH@9lZ+bB8~UUY-z8^6|5R4Sak6V zzOC?ztOQED#B?9pfdzm1>hFF~)&;8F>u2%VNF3r_!KX1N-F#BR2g!-n21G}JM}nIr z8Qp>6t!%CQXBXA0J^eD~Fim9bb4(#kn#X`7g)?$!q$$?@a?4C=LZP>fK|`KMXsc}G zbN!GJ<;3)Fr9OR@)L;C!J-tD&nX8jswTsk*b|l~F!*9zQ}wy-Z(d#u_x^ z(eU5gh^W@4a@!PYlj+oaw>@92#S{uZ_9 zg?v!hHq-%S>ewq)g`P%#y`HDJZQmAVS2t*3ju`!fRCRA9zN|!=+vk5!0aG)3LSo5k z9{ZFn#k8oo1fR=W%@~rid26{Ax)r!XYuO@bgQ_9kv+qf=&NMO`Krzo!>L?l#R;w|j zQijeddKo0SN4bE=qd)}b2bb@#cDzo1=NX>?TmbovH5_GzTz^y=H_)Vy ziH(b%(z?mLc@O6M+tXE0E*19e;REZgt()?Ld_aT~|#In(}I-4Z|zz0?4{JN-=sTZ?~0nJ8bEeZD8w2e`XeQ zz8}k|B!9pHiAmU@^P7HZe`y;rP@VV0wzw)FU!U-@P;vP+m{wJE@6Kz4V7s8vi7NU4keLtwGzS;Qg&v;CQifpUfuilb9R|( zweT}xpUqPMF_q6F|1pqU?45l6Z4V1tAf2tPok=W!ks{A`UEz9aIjFFf({nLK6pfGU z9lXkf==`AyLrl#2`o~X+OqsL9GV_D+SWLn1qc!W*$AAdjodfc-Y^>P=Wqmyrl|!+S z>q)$5O|%KO+bDUJKsh|7*&ii0VEHC(LPmlaio%9CTh-h8jLbJY=ySE|*)z|WZxGp; zj<$wJs}TZou6Z20aS0Zmcw?y<9n$I4N%rJf(w?B=Z~kmc4^QY2E4$!A z;IPxSen~CgMzm%1;U52-$f(1Uo;#4AIwe{1cxx?lRnE7>*K(c=_@P-lp5MJhx|abI zOeVQo>O)SW?O4T~fmGtprIWj^sbW50?CsxwRN!?z*+q}Rx1!2^;QAU6dG!%+WFJ?R z7yR9wyWJAY0l&)s9Ca)m_)(mVqsJP;U)D9hJN5*K2#~Y&dQW5Davf;@xo?yiz|Mo` zdB<%UPwn2K@Do^CA@L*2LqUk{q$l*v@ZJ`P{zmu3c$6v!*_yQ>T(=~V#t(+^R{k_l z!Dh}@-uy>4aw^iw$%NDq-d?j{^-}hM1eN~RPLP3dUo>l6F6b-807P;ba1GJq{q{%> z>E6=`XP;WJ!XnP1?Q@dE|2TUv56L-D8*r@CwoNYLNKtYs)x8YC27b4TN}?=l#x{5F z-7XL0#BQp>pW7h)!Zs3-(XDM^NuQlOXZ6~1Dhg;cd&D60D-`bUZA z86e}y{r=c_f!7cEsA_-92zco_rUSj*?JEXYed?%uX2=1pHuX@)ezE~FILpnvT6b}n=ddv3r%u!A zGNac8K`r=8l-qKT$n%7(#bCO{&-d5e;&r|`14>Nn2iJ73&Fv@e%a5h zOnP)7zeNLUc9J{3FFMWu8B(t`-@kf{Ner3*e_#b9tOwY{uHh#yqJLR-N67EnEW23x zjws?9r;##m#5e&}i_EY{tp{dWF&UKLCaqsj4nvT$CO+;eu%-)W`|kKR15Sn=W}4TQ zOD-+i;azKu`xBfjkSWWqp05l+ID{zvHNRxDAfvIhK>7rBJ=1K_t8_vubZ~xFLKn@J zNoLCgWK7f7R}0t|i7Vo^F7Ps4&o3dcnW5}eWWpqnC6X$(^il)Y(4*}E-~4G|wDn2t za|zz7y_idj1YQOIu5A(>>#;BAbV48r^J020C51mMLkTO)@#l5%@2!j(pJ|;wv}llg zDWY@g&Ig;Iz{WYIvN$^7cX%P{M)8@1ONX=~t(l3pX$vp&k2&bNBNC#Hdp4;x}^7Uc%SE7djT>40L?oZXRnL&BA!u+^44;8YcKJ3?}r zL5#tFD9Qna9)oDk>%f&K;YQ3o&9L{(cqVki;s`P5k zb;l3KSO$_g{8%hJxmLBlVknAz2{7a_wWnb;AH!BrxI@1O_g2ghF&z0Pmo#yIeMD+I zN0p;845y98gb~@+UV(8=5iu}5ywC7sx&SCfVW7Jdjz(Ze5UoP@GE{%rx8SHf!-QuUQhRoTW*RO@Gh6-xS*R!8v#V zsqfj#`i$(t??_c+wAR`9if>iQ*E6knLJb*f#rkC6X(!0j2Pat;IQdfg*UBd4M%YKn z?p_`I{45cFC#4jzY1nOPf_$&|IlD}=xf` z(+=%wXl2cY($tDv`Yh@~(>om|WFBJl31s)1rv$bYKSks>9k9``*hAC=D5xq zOYP35{F%6B%3{19Xff~b(NE;`HhtDM&1VZJzcvweC~DE)CRffPT5>o1J9td8<`6Mw z)1@AoUf29;{9H&~yD=#&JnIne0@4n8dE_g}bD^RP8bhNaz%#4krj;!pxC_xlgPBwB?u-MG^m{a_dBnH=< z|7*kj`C`$aAYFm64iT4?vZwfxM#eyU0Fr|i(*=7x7p9o3<)A4^@y3x06W$NJ+v2y1 Vm)kHOK@vIt(+_*DIBfs7{{~7hUhe<^ literal 0 HcmV?d00001 diff --git a/inst/extdata/impact_method2b.rds b/inst/extdata/impact_method2b.rds new file mode 100644 index 0000000000000000000000000000000000000000..f3650a96978cf68f7c2341e23065a5c75b2cf323 GIT binary patch literal 8382 zcmchOWlS6Zw{5W*T#CCCcPs7%N^vL-#cgnR_u>>SKKS5Hi#rr|2KT|GP@KZN@80D7 zdM~;E?#{{1%E{U^@n{JD9psB39}OLY`?~<~CZxDfh*e4{%QrM^HrurCc{0-OsVs`T zs45UnmN>-W$aer401AUrdY+s+Fcv@KQKJ0#*&b53#J?aRc#$XNy<~V+6Li_my!EmZ z#wrmeP5bWiA|VPs5g9%t0ZV7d>h~H3UlH9XA776um|^xiZ+A!WkDSEZ+=zN^-G*?Y z8Z!X9em}bTOqla+1EmmqUEH)YJQDD^f4syKDX zlyCaXXm5vF@S&e4wij%j?OaAw5FQ z@YDZVyeL4g3I(P^JWXF+>aVV*lHr~O|8)MsO!JxHC(rP1zng9kJM#dNHiz9i5|g8u zV3TK`!rb87zel|*-0<5(J|zKEZa@N@PlZ3GmN5OzC9XL*i9_3EQyIV8d9%Atix;HFU;<_9np{zWozX$L8V2C3q>5L-@7aIPLKWg>*W9^U5TUw4# z5Gq{k4c?^_GO`qsw9FNK_vq6fa*6hKwb-`uFTTA#__AR1jphjca-I?|bvBw$2oH9O z-(4lOeXY+Yd^8De3wV0TBZ>D*gsXVqLhmgP5u7=Dd;+gRN(C|ai4u4QKy%=bw+kn7 z7j-F95?oXj-eE$m|F>>KvgX%Te+8`m67~y>*>}u)<+p-+dF``v7qG*xTAyvZDuz3g z{{`M&b)3B!pS_9A_d1yFyA2U84EIR=3u-1g+qw<#;@*-VvE^=iXHav7y3OBnG`wCn z?5`g0ll3eTfCcUTar#DfbTs3u{;QW*ee+i@&#>q9%*pVYectPSGu-61uopUF=CV(` zV`;sAwR3T1CdJLSCbse@%B|f&xW!qJHGF%VT^r7V*G_$ml&%4k=E` zmyAiRONCP3&w+@`pQiUvtqRPI4&E9aF&nmHTkGim);Kh-O=@nNC0c8L#>}?0)m%Mp zq6DaEvObA~aP@k8p;biub!vBOJ0?E!bZ*djq!4N=`(QP#i8L-%{KRr{Xuk7g7}A_>;OgFdw{C$qi6k*~|2lfOqbVYV9jX#vwS+Hf}BH3DCe zr1q+*3`~cmEX;I-`osmL=yvxPle2IrMc9MipPdYmw{%M%OD0^`4ID`;=lbX->lrTx zxvZiShVC1_n<(|sO}D$>Snf=gM_~nk+c*+KTditFs~sPjwiqEX5e=*>9xa# z5q!po!eX1e4joV61xG>IXL`gFEMCv;K)|DgM2C;WK8v}&BJ&iIPIZxMfj;V92kn>P)I7j4AG%qi&;)sWObvo<1djv z{N1>#0{c{9qRSXnBW0)Z!Ob9j_ZFBt4DYv`lg?*zx+1};PqktD$PI%gJW^teREY)b z*9UjT=xO)_>JN$8FukzgIGb5pt964OQo|&r$MUS+Se_Ja!H!heGvsH zgnX@Bzkw*o$*Ude-$gY0=9yNJ+dO;34&&9ad;)vC0(55XAC7a~^o&{KlLZM5HLu`nPTED&wyybj2{=(n$2KJ!}YEJ9+ z$;rS4H;9@o7o*)N8Em09|3YVy^!j&#AtAjxGwrJ2Pt=eL3O->K_?Z2^YaZZDZRQH; z)^MgJn2OYO?AqDIC=Mo%$w_Jj$9X1?YI0;rYr#?hFd6?3Bcn5U!i&J(Qc+g!iW6C< zk0c*so07mXgVIF**iaI&YS-PpjwnJuC{R;j<1TvamBns2(aok4b6pCz(j;z))m{Jg zL`g@MJhKC)j5=H)Z{|@m%^D8tX4<2kpVImVs8g zF2Y3g%2`t#H-OhtdZy%BBFLB3rFn2`3Y_8AS^1AbjC_3=_QNF;a9ZmJ(5&c~ZOHC+ zB2=XS5seb4Xb6)V)r$V&m_hJ%4EiOjxJ8ZqqTR@T2a8xw1$bry*3O! z>4YN-p<{PO(L%*ZW<@RD;^ic%$g$5C?r~_ssYrfeYzMv)VH-^_mL{$Zo|Z6Fqud0} z2puTio~cDR#oVSOf5+I&H4X))P$J6F=ka zcS$R!yJ6mO%6}lE7s)j0B3^z;Amm5EE-_3s5%9>6IBp9Ny*ETJT1~1b*cB@bOTVgJ z{zq^R!4~X@GA2ZN70ptpGt`z247SANw5EoTvQSg`kjm0`XGCqpVDyK&kLAaljfDMR z$0@bmJ@@8)3T_|mRx+p!@> zGo?N>MZFJuuded}dX50HC+>kH`z10xLN^8dZ^;t8dR2JpLeSDHT8NfZ4x}BNzCYZ` zy8CHnmTg9||3DE$rqB}60Id3tPV^vNpcL~r+A-(s{XN6(GDI)`v}-T6ii_0x*iT-v z#4tP7E!NQXgIHCy!*M;cfqW8Dk814QjU*|6$qQ27gG*@EHgw2-ddOGZzH~c_r1sP?bcwW*SG2k?pYV&<2{d4k8dr{@hZOBcU6 z>oS`*5F4HttQFuYlPf%Ef>gt^dnBQWQxF&vHveo&Egy&XH-S7Y4Q-?~oh+iMv7 z7etO&ww=f82qZJ}Vae~moco@lwdUfwwr<3^U)nw$Atet^-~_t|(SYj8`9Jd`)a(D! zec5;_rC2%$&OsB;5MfU}94{0zUKD%>EI70TZhDA|mPzE)68UCr!sS6pAvoK@ykn?c zXKjrxx%8c7r{>*hr?;9wWEUS zpSB2vq4>=wl%_F}Txg7lh2=@DSnaR!Y_S3qkNDd^ zPGT(1Xj)>ZRxzvZ@2JrZlI0DqR+*bcTf(jb3k6*URMTg>54BU{_*_|@&bN5zL!07t z9hftR5dPwaT*?lKrVo(46Jg@Rq%;*J%R`f8QE;>f8n$8AcdPxq6qt!vw$>=XSf7Qg z<`3VH@Va1$c`Zhq3d1uSqc12uG>w{9tKbvL7st*^NT2W!uPZs{t}EbFs0?dG&BV*> z1bbdkSIk|??ffWuNSMO>wCb|?t;~t4Pq2C4t1nZ6CE_`S`eJpaZ;n{Y#!xS&30K7g zr?3d-hd$v+^+3*0J%D)?MfB->{&(b}Fp?MqdCE1;Y+hF+fuk`06#e z{;@`8r?lC#sabq{CQzs2@;lBS%B3!Mfp0X{RCx^Nr7Fm)J`MuxXStfq*|>a7y@*{| zHHLl?sB;19>A{$z1mM6>mlhQ*)H?=JGLd8K(7v^{uo_mubmc^9C~jgX%j-LtiW`4z zeE&VacRr+Oq6M9q*7o5yP@`u*PCGzzWrQ^8CN@eV!|JhWIPJhh*Z2)k;8~+#L^ef< z@=@VC<*UC?di7lQaMKNbO}t3oqX-uz5vK9NoW^gIh1~Ewv3mI;yVvsUA1?vsB{E6$ z84x};f$?tY+i3hqP}1_HhOWX>cYlm0&QZkeyr$nBJ&6W(h;HyP1wQH6=v~ujY)O4_ zE-V?hHFN{Ua++pbq4_$Y7J>cs;3(>%V6p|#5fnHWWqUJnPwQj(@wu{)qsphW>(|y8 zrS_LXS0MFUf~c(!A1hZqDn(XLmhO$XH1E7Kw*)?pJ=yN6jbE0A&(TuuHn7_)muz2p{f3&QOoSvG+5+~@V#et-bqJd|3im8fHVsQ${dj3PDzDM;@W-+8zON36SO4OB)!TN!pxriQ|jziY$gOhFRZ(F&I1FafPX+Kl^o{I zhP-R8!)1R3+MZjKK{wLF;Echf(WFYQmo&~62A??BuV-C?%c-k;-j1sKSDBA%eRDZx zM>MIY{(w+tzf4+T{85++bhoXpQ|aU80xtAv#Mpx{Q=gqr`tB)wY=R0LWw2kIJ1&m@ zA|0j#z&XYAmMq77im5CZ1brx=W+bQ{BnknqM808H@NqTlYGC9(;EvDai2iu zOI8vLe2tr>s_!V?&*DlN4AA^Q+|+rw(=KE-(r~nbW(0VWkYBW@YI-+m>j<;h&nm8b zqZ_d_UNu`v)z$X-LX0L>(OIYG7UA`>9#DdDa71U&socw_6t<6j=wZKvE&VF5FsbN_ zd~7&DV#7;b%>4{z;Ao(rluC$P0X`yN+hN9Mr*K1V)L~9ov!C+KgO(ZfK>d||u+AyQ z^)PQ*=?NWmU>?qoN{#>EQ--v#^X2Gov zdM7Z%294Q}{M$dYIcw$f41%2mleOx1pUWpo#yT~tRI8c#IE8KxtAh=0{5tt}qo;*Q zn<`vP&FvziE0lgMEq(0sFTKc*i>1S>G?w>g8JF&L^wl8~6C?LeX^Z!@#8PRZSx8i? zm)|GjLIPa<3^z%2T`P5Ccy|9?BJvMW=r}&Upq4SNi0;O1cAXZzd@{XTgjW~zZ;ogW z3u->A8oclM>kWszE3p30kS{e#O{3Q>mK(}F-CyXLlx}Fy)*U2Qo?hB6dv(!|FXx}+ zmm6>4G-~V(lN+wLQ~DK$vYt|r5Rsa%M3hFyDF|vTb1R9QR1nk636u6S0#d(*ghqC5 znGzNMG{@DK{*{)h_N^((M78mB>}Tc(0_$g1m>Ct=Tcwi-#tUqFpFKkw9~GwWnxq8J zpb$oZwZ=fw>bLLb?#v4rR;qhjgK~9|O7}`kRDGiQy?@ReV3UV5guYr6N@`?YmYEED;yNa?mh1agA-J);4RcRMnbD9{R@J@-l(N;2 z9;ID|35=N|z?zG)=`IjMx{=Lpdq=Zq#ww_Cmj) zr2~6@BoQ9PeYFJa2tXqiE$5|2W42tufm6snV{Ppxgr_>)yF}Ghq<&LA3UX|7Ijj^*fL!*LR_VP@tN`q`kXlSG)*rp z>uk%VHe8fsVgw6Z<_AktWwkjT5ic@UX?{F0LkO@?hVmuoBXl}c6`@VpNh@)1RH)=> zzSQdY$4TOVwHsfXvWaj{uR%Z6*JN>v)nfDBUBDnMN}ji`PoO`RYJNXFw26i9!x8`l z=!Dry*qw1@ntGU))H*pBEVHxcf=ZOq`Oj|ZMEv{a$qD#ro7i^xcB~g^u5c6<6EZp` ztcGIer22}3gsrgk$?ToJkN*1obvL`ajG7w9i?}Bx?XevY`N7OMvWOS0cFrt8sz{>K zf-3oS?6D&q{oOl|+TvxYv-AueMw@>O4wn2AlB)jA1eG%*f{yOi(W_JmPR6Uii`qlD z7DSKHdKZt!om5H*{WC(t-q!eSDOxK{#UkN#2}*T!6)$^_1k(KEs5b1_1+47@GKPT( zPjU2MwJM89j8wYwiQFBK^}X_R_dI&vO39fYkW~Q3W&i0owikHQwZPe7gziJSOQX#0 zBLWK(ww#l#wVW~a63IzjWdxMkCHS3Ch}pH{YRV)pj=d_zmHT{?h7=V$Rms%{$O!mD zm8=saxoqWZaP<|eNDr@xj-bXq1lET%UZ5WTL#0}~)ytZB(atnZ9*gNPP_-_Hm^)DAQ_@l~$qbc3&oKvYn7P3rQ z^C8!n77{tuNk9|d8!gC#hbc)vtB5YgwevxoMn-C&UqnI;n0OeOA52At`aDwE0ac+c zp6ikg(`M_~xvRcTxoZ)r`P{y~&1M5+O1@Rg-6H;!CQ0Kvs+JhO%y!D6O%&f#L$%tv z;fgCfHGjoZJQrEk#!k)!Aqu;&L8mCfQU?DUzu^k+B*D^l?6@VYn$_2sm<%h%`NMnX zKhS&wXmBel%bA=GKPj5sCD1dTO<(W%+#3f(!|U2%^pZpow#FjQDj!0Qq3T|)wSRYe z`KlZ{$L-W7(PR2t=E0|=FuH^dtV62r@6#+>7-ZSMOl2dNRoEfG64O)_P2iJ|;?EOb z#1Q|IOcTBAUE(>#NXYQS*f&Ph=FmPVaO-SQu5w99z_Wzi?HIHbWpa}jx0v)0uH&Nf z$?y}SCjMS|E@%~N1IS?+?Bc1hR*Aa=qal)!UB2pjJE(@JGimgT9{~TfCPoJ@!vWUI zR_vEWUi8U&>%%z;4|5v&6PB5{t9|VGboz$&NqpZlRYWaS8xHpMFTy57kK1d9txhL_ zcxrUV))x!Xes;AB=GSP;izcSar*+@Hq;sLj^8~oCQS18uGOhQDJ`FkAvYBfQmn$k9m-LU&%aYhu7K;;oLTM?HzDa7)dYk(aFwgkP`jQ zvs!xZh}2V3%S|1aqL3X|J2_vDb*H{#Mi7bY-tyeC%mI;7J6nE*g{lOQOu3(@X)x%UqXr^O>awu%>(jCJR> zo&OON9~${pSx(1NfX(Y-C5xjTFaRa^_jiO<OM7A@G?TjE5)N7mYn(Y@%NP5+I zXnR$K#pDVY;f`Q%F+-lJ zsDOMO8tpEt!|-e$y7zO70?T}-?e|iFO0#tielO=h){*?nT&bKHS}IqlYnDvSwmm!0 zu_{7XT4#{eg^a7+9upMx+-IIbm`oUHI-w!5T~TXqq#|v{(0dizgl|7_pvp6&hNQUa zxojZg{_?0M!pN)?!G)dcuM+|!Kb9Ky+0luc&NTbOt9|T+RiN)uFujRyvDd2M7WcLeJeQ14;+yV zE&%)g<7&?MO1qi_iJA80{;@ogp98W#HJHsuY?Q)5 z=KXpQL?+OD%=K`#37~*}px*1Wh_R2=Wa zoo(9d^W7q$T`KWV3p%q|ys2*7YEXLrS-n6)i0O0k+9M|)pRBUX;nMZg;zq8fk$&KM zX)xD63-t}o#2gJVH;3}MNY38{6B6%zEXeFb;5WL{c6u6F`fT_2pHQA{7IQwsrxDt0 zZlht^UrN-(w)>7;6#Dw4`Kp#;5I<9hBjFDH4DWiyK-SDBU39|pmJnb^!P5J5oCR_L z%ww{<<EFQ3B=7BTjBRSQdLbSA{?F z6LaK#Qe?gt7@QwerW8$j3~N&VRx+kdK<;Rpg0%s`)U|<@)94r@M@Q^;>UifP36xc} z^5W}&K%N9?D7k1W8^PYkU+j=L_%pUh6z|YK=m@e+z6RR0w+k3$tK?=(5F`~59NjUP~1Iy(Wc|?T&1EzUtG5`Po literal 0 HcmV?d00001 diff --git a/inst/extdata/who_sub_regions.csv b/inst/extdata/who_sub_regions.csv new file mode 100644 index 0000000..051ab6b --- /dev/null +++ b/inst/extdata/who_sub_regions.csv @@ -0,0 +1,250 @@ +choice_subregion,country_name,country,Global.Name,Region.Name,Sub.region,Intermediate.Region.Name,subregion, vimc117 +EMR D,Afghanistan,AFG,World,Asia,Southern Asia,,Central and Southern Asia,1 +AFR D,Angola,AGO,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,1 +EUR B,Albania,ALB,World,Europe,Southern Europe,,Eastern and Southern Europe,1 +EUR A,Andorra,AND,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +EMR B,United Arab Emirates,ARE,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +AMR B,Argentina,ARG,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +EUR B,Armenia,ARM,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +AMR B,Antigua and Barbuda,ATG,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +WPR A,Australia,AUS,World,Oceania,Australia and New Zealand,,Oceania,0 +EUR A,Austria,AUT,World,Europe,Western Europe,,Northern and Western Europe,0 +EUR B,Azerbaijan,AZE,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +AFR E,Burundi,BDI,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +EUR A,Belgium,BEL,World,Europe,Western Europe,,Northern and Western Europe,0 +AFR D,Benin,BEN,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Burkina Faso,BFA,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +SEAR D,Bangladesh,BGD,World,Asia,Southern Asia,,Central and Southern Asia,1 +EUR B,Bulgaria,BGR,World,Europe,Eastern Europe,,Eastern and Southern Europe,0 +EMR B,Bahrain,BHR,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +AMR B,Bahamas,BHS,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +EUR B,Bosnia and Herzegovina,BIH,World,Europe,Southern Europe,,Eastern and Southern Europe,1 +EUR C,Belarus,BLR,World,Europe,Eastern Europe,,Eastern and Southern Europe,1 +AMR B,Belize,BLZ,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,1 +AMR D,Bolivia (Plurinational State of),BOL,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,1 +AMR B,Brazil,BRA,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +AMR B,Barbados,BRB,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +WPR A,Brunei Darussalam,BRN,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,0 +SEAR D,Bhutan,BTN,World,Asia,Southern Asia,,Central and Southern Asia,1 +AFR E,Botswana,BWA,World,Africa,Sub-Saharan Africa,Southern Africa,Southern Africa,0 +AFR E,Central African Republic,CAF,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,1 +AMR A,Canada,CAN,World,Americas,Northern America,,Northern America,0 +EUR A,Switzerland,CHE,World,Europe,Western Europe,,Northern and Western Europe,0 +AMR B,Chile,CHL,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +WPR B,China,CHN,World,Asia,Eastern Asia,,Eastern and South-Eastern Asia,1 +AFR E,Cote d'Ivoire,CIV,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Cameroon,CMR,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,1 +AFR E,Democratic Republic of the Congo,COD,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,1 +AFR E,Congo,COG,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,1 +WPR B,Cook Islands,COK,World,Oceania,Polynesia,,Oceania,0 +AMR B,Colombia,COL,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,1 +AFR D,Comoros,COM,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +AFR D,Cape Verde,CPV,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AMR B,Costa Rica,CRI,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,0 +AMR A,Cuba,CUB,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,1 +EUR A,Cyprus,CYP,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +EUR A,Czech Republic,CZE,World,Europe,Eastern Europe,,Eastern and Southern Europe,0 +EUR A,Germany,DEU,World,Europe,Western Europe,,Northern and Western Europe,0 +EMR D,Djibouti,DJI,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +AMR B,Dominica,DMA,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,1 +EUR A,Denmark,DNK,World,Europe,Northern Europe,,Northern and Western Europe,0 +AMR B,Dominican Republic,DOM,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +AFR D,Algeria,DZA,World,Africa,Northern Africa,,Northern Africa and Western Asia,1 +AMR D,Ecuador,ECU,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,1 +EMR D,Egypt,EGY,World,Africa,Northern Africa,,Northern Africa and Western Asia,1 +AFR E,Eritrea,ERI,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +EUR A,Spain,ESP,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +EUR C,Estonia,EST,World,Europe,Northern Europe,,Northern and Western Europe,0 +AFR E,Ethiopia,ETH,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +EUR A,Finland,FIN,World,Europe,Northern Europe,,Northern and Western Europe,0 +WPR B,Fiji,FJI,World,Oceania,Melanesia,,Oceania,1 +EUR A,France,FRA,World,Europe,Western Europe,,Northern and Western Europe,0 +WPR B,Micronesia (Federated States of),FSM,World,Oceania,Micronesia,,Oceania,1 +AFR D,Gabon,GAB,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,0 +EUR A,United Kingdom,GBR,World,Europe,Northern Europe,,Northern and Western Europe,0 +EUR B,Georgia,GEO,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +AFR D,Ghana,GHA,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Guinea,GIN,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Gambia,GMB,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Guinea-Bissau,GNB,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Equatorial Guinea,GNQ,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,0 +EUR A,Greece,GRC,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +AMR B,Grenada,GRD,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,1 +AMR D,Guatemala,GTM,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,1 +AMR B,Guyana,GUY,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,1 +AMR B,Honduras,HND,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,1 +EUR A,Croatia,HRV,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +AMR D,Haiti,HTI,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,1 +EUR C,Hungary,HUN,World,Europe,Eastern Europe,,Eastern and Southern Europe,0 +SEAR B,Indonesia,IDN,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +SEAR D,India,IND,World,Asia,Southern Asia,,Central and Southern Asia,1 +EUR A,Ireland,IRL,World,Europe,Northern Europe,,Northern and Western Europe,0 +EMR B,Iran (Islamic Republic of),IRN,World,Asia,Southern Asia,,Central and Southern Asia,1 +EMR D,Iraq,IRQ,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +EUR A,Iceland,ISL,World,Europe,Northern Europe,,Northern and Western Europe,0 +EUR A,Israel,ISR,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +EUR A,Italy,ITA,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +AMR B,Jamaica,JAM,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,1 +EMR B,Jordan,JOR,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +WPR A,Japan,JPN,World,Asia,Eastern Asia,,Eastern and South-Eastern Asia,0 +EUR C,Kazakhstan,KAZ,World,Asia,Central Asia,,Central and Southern Asia,0 +AFR E,Kenya,KEN,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +EUR B,Kyrgyzstan,KGZ,World,Asia,Central Asia,,Central and Southern Asia,1 +WPR B,Cambodia,KHM,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +WPR B,Kiribati,KIR,World,Oceania,Micronesia,,Oceania,1 +AMR B,Saint Kitts and Nevis,KNA,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +WPR B,Republic of Korea,KOR,World,Asia,Eastern Asia,,Eastern and South-Eastern Asia,0 +EMR B,Kuwait,KWT,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +WPR B,Lao People's Democratic Republic,LAO,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +EMR B,Lebanon,LBN,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +AFR D,Liberia,LBR,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +EMR B,Libyan Arab Jamahiriya,LBY,World,Africa,Northern Africa,,Northern Africa and Western Asia,0 +AMR B,Saint Lucia,LCA,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,1 +SEAR B,Sri Lanka,LKA,World,Asia,Southern Asia,,Central and Southern Asia,1 +AFR E,Lesotho,LSO,World,Africa,Sub-Saharan Africa,Southern Africa,Southern Africa,1 +EUR C,Lithuania,LTU,World,Europe,Northern Europe,,Northern and Western Europe,0 +EUR A,Luxembourg,LUX,World,Europe,Western Europe,,Northern and Western Europe,0 +EUR C,Latvia,LVA,World,Europe,Northern Europe,,Northern and Western Europe,0 +EMR D,Morocco,MAR,World,Africa,Northern Africa,,Northern Africa and Western Asia,1 +EUR A,Monaco,MCO,World,Europe,Western Europe,,Northern and Western Europe,0 +EUR C,Republic of Moldova,MDA,World,Europe,Eastern Europe,,Eastern and Southern Europe,1 +AFR D,Madagascar,MDG,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +SEAR D,Maldives,MDV,World,Asia,Southern Asia,,Central and Southern Asia,1 +AMR B,Mexico,MEX,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,0 +WPR B,Marshall Islands,MHL,World,Oceania,Micronesia,,Oceania,1 +EUR B,The Former Yugoslav Republic of Macedonia,MKD,World,Europe,Southern Europe,,Eastern and Southern Europe,1 +AFR D,Mali,MLI,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +EUR A,Malta,MLT,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +SEAR D,Myanmar,MMR,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +EUR B,Montenegro,MNE,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +WPR B,Mongolia,MNG,World,Asia,Eastern Asia,,Eastern and South-Eastern Asia,1 +AFR E,Mozambique,MOZ,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +AFR D,Mauritania,MRT,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Mauritius,MUS,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,0 +AFR E,Malawi,MWI,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +WPR B,Malaysia,MYS,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,0 +AFR E,Namibia,NAM,World,Africa,Sub-Saharan Africa,Southern Africa,Southern Africa,1 +AFR D,Niger,NER,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AFR D,Nigeria,NGA,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AMR D,Nicaragua,NIC,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,1 +WPR B,Niue,NIU,World,Oceania,Polynesia,,Oceania,0 +EUR A,Netherlands,NLD,World,Europe,Western Europe,,Northern and Western Europe,0 +EUR A,Norway,NOR,World,Europe,Northern Europe,,Northern and Western Europe,0 +SEAR D,Nepal,NPL,World,Asia,Southern Asia,,Central and Southern Asia,1 +WPR B,Nauru,NRU,World,Oceania,Micronesia,,Oceania,0 +WPR A,New Zealand,NZL,World,Oceania,Australia and New Zealand,,Oceania,0 +EMR B,Oman,OMN,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +EMR D,Pakistan,PAK,World,Asia,Southern Asia,,Central and Southern Asia,1 +AMR B,Panama,PAN,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,0 +AMR D,Peru,PER,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,1 +WPR B,Philippines,PHL,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +WPR B,Palau,PLW,World,Oceania,Micronesia,,Oceania,0 +WPR B,Papua New Guinea,PNG,World,Oceania,Melanesia,,Oceania,1 +EUR B,Poland,POL,World,Europe,Eastern Europe,,Eastern and Southern Europe,0 +SEAR D,Democratic People's Republic of Korea,PRK,World,Asia,Eastern Asia,,Eastern and South-Eastern Asia,1 +EUR A,Portugal,PRT,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +AMR B,Paraguay,PRY,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,1 +EMR B,Qatar,QAT,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +EUR B,Romania,ROU,World,Europe,Eastern Europe,,Eastern and Southern Europe,0 +EUR C,Russian Federation,RUS,World,Europe,Eastern Europe,,Eastern and Southern Europe,0 +AFR E,Rwanda,RWA,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +EMR B,Saudi Arabia,SAU,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +EMR D,Sudan,SDN,World,Africa,Northern Africa,,Northern Africa and Western Asia,1 +AFR D,Senegal,SEN,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +WPR A,Singapore,SGP,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,0 +WPR B,Solomon Islands,SLB,World,Oceania,Melanesia,,Oceania,1 +AFR D,Sierra Leone,SLE,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +AMR B,El Salvador,SLV,World,Americas,Latin America and the Caribbean,Central America,Latin America and the Caribbean,1 +EUR A,San Marino,SMR,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +EMR D,Somalia,SOM,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +EUR B,Serbia,SRB,World,Europe,Southern Europe,,Eastern and Southern Europe,1 +EMR D,South Sudan,SSD,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +AFR D,Sao Tome and Principe,STP,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,1 +AMR B,Suriname,SUR,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +EUR B,Slovakia,SVK,World,Europe,Eastern Europe,,Eastern and Southern Europe,0 +EUR A,Slovenia,SVN,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +EUR A,Sweden,SWE,World,Europe,Northern Europe,,Northern and Western Europe,0 +AFR E,Swaziland,SWZ,World,Africa,Sub-Saharan Africa,Southern Africa,Southern Africa,1 +AFR D,Seychelles,SYC,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,0 +EMR B,Syrian Arab Republic,SYR,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +AFR D,Chad,TCD,World,Africa,Sub-Saharan Africa,Middle Africa,Middle Africa,1 +AFR D,Togo,TGO,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,1 +SEAR B,Thailand,THA,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +EUR B,Tajikistan,TJK,World,Asia,Central Asia,,Central and Southern Asia,1 +EUR B,Turkmenistan,TKM,World,Asia,Central Asia,,Central and Southern Asia,1 +SEAR D,Timor-Leste,TLS,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +WPR B,Tonga,TON,World,Oceania,Polynesia,,Oceania,1 +AMR B,Trinidad and Tobago,TTO,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +EMR B,Tunisia,TUN,World,Africa,Northern Africa,,Northern Africa and Western Asia,1 +EUR B,Turkey,TUR,World,Asia,Western Asia,,Northern Africa and Western Asia,0 +WPR B,Tuvalu,TUV,World,Oceania,Polynesia,,Oceania,1 +AFR E,United Republic of Tanzania,TZA,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +AFR E,Uganda,UGA,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +EUR C,Ukraine,UKR,World,Europe,Eastern Europe,,Eastern and Southern Europe,1 +AMR B,Uruguay,URY,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +AMR A,United States of America,USA,World,Americas,Northern America,,Northern America,0 +EUR B,Uzbekistan,UZB,World,Asia,Central Asia,,Central and Southern Asia,1 +AMR B,Saint Vincent and the Grenadines,VCT,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,1 +AMR B,Venezuela (Bolivarian Republic of),VEN,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,1 +WPR B,Viet Nam,VNM,World,Asia,South-eastern Asia,,Eastern and South-Eastern Asia,1 +WPR B,Vanuatu,VUT,World,Oceania,Melanesia,,Oceania,1 +WPR B,Samoa,WSM,World,Oceania,Polynesia,,Oceania,1 +EMR D,Yemen,YEM,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +AFR E,South Africa,ZAF,World,Africa,Sub-Saharan Africa,Southern Africa,Southern Africa,1 +AFR E,Zambia,ZMB,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +AFR E,Zimbabwe,ZWE,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,1 +NA,NA,ESH,World,Africa,Northern Africa,,Northern Africa and Western Asia,0 +NA,NA,IOT,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,0 +NA,NA,ATF,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,0 +NA,NA,MYT,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,0 +NA,NA,REU,World,Africa,Sub-Saharan Africa,Eastern Africa,Eastern Africa,0 +NA,NA,SHN,World,Africa,Sub-Saharan Africa,Western Africa,Western Africa,0 +NA,NA,AIA,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,ABW,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,BES,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,VGB,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,CYM,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,CUW,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,GLP,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,MTQ,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,MSR,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,PRI,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,BLM,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,MAF,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,SXM,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,TCA,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,VIR,World,Americas,Latin America and the Caribbean,Caribbean,Latin America and the Caribbean,0 +NA,NA,BVT,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +NA,NA,FLK,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +NA,NA,GUF,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +NA,NA,SGS,World,Americas,Latin America and the Caribbean,South America,Latin America and the Caribbean,0 +NA,NA,BMU,World,Americas,Northern America,,Northern America,0 +NA,NA,GRL,World,Americas,Northern America,,Northern America,0 +NA,NA,SPM,World,Americas,Northern America,,Northern America,0 +NA,NA,ATA,World,,,,,0 +NA,NA,HKG,World,Asia,Eastern Asia,,Eastern and South-Eastern Asia,0 +NA,NA,MAC,World,Asia,Eastern Asia,,Eastern and South-Eastern Asia,0 +NA,Palestine,PSE,World,Asia,Western Asia,,Northern Africa and Western Asia,1 +NA,NA,ALA,World,Europe,Northern Europe,,Northern and Western Europe,0 +NA,NA,FRO,World,Europe,Northern Europe,,Northern and Western Europe,0 +NA,NA,GGY,World,Europe,Northern Europe,,Northern and Western Europe,0 +NA,NA,IMN,World,Europe,Northern Europe,,Northern and Western Europe,0 +NA,NA,JEY,World,Europe,Northern Europe,,Northern and Western Europe,0 +NA,NA,SJM,World,Europe,Northern Europe,,Northern and Western Europe,0 +NA,NA,GIB,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +NA,NA,VAT,World,Europe,Southern Europe,,Eastern and Southern Europe,0 +NA,NA,LIE,World,Europe,Western Europe,,Northern and Western Europe,0 +NA,NA,CXR,World,Oceania,Australia and New Zealand,,Oceania,0 +NA,NA,CCK,World,Oceania,Australia and New Zealand,,Oceania,0 +NA,NA,HMD,World,Oceania,Australia and New Zealand,,Oceania,0 +NA,NA,NFK,World,Oceania,Australia and New Zealand,,Oceania,0 +NA,NA,NCL,World,Oceania,Melanesia,,Oceania,0 +NA,NA,GUM,World,Oceania,Micronesia,,Oceania,0 +NA,NA,MNP,World,Oceania,Micronesia,,Oceania,0 +NA,NA,UMI,World,Oceania,Micronesia,,Oceania,0 +NA,NA,ASM,World,Oceania,Polynesia,,Oceania,0 +NA,NA,PYF,World,Oceania,Polynesia,,Oceania,0 +NA,NA,PCN,World,Oceania,Polynesia,,Oceania,0 +NA,NA,TKL,World,Oceania,Polynesia,,Oceania,0 +NA,NA,WLF,World,Oceania,Polynesia,,Oceania,0 +EUR B,Kosovo,XK,World,Europe,Southern Europe,,Eastern and Southern Europe,1 \ No newline at end of file From 5024eb99107a6dbb42c3f22b7d2d29a81d7ee7e6 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Fri, 5 Jun 2026 15:17:40 +0100 Subject: [PATCH 21/29] Minor fixes to fns --- R/fn_impact_diagnostics.R | 50 ++++++++++++++++--------- R/fn_plotting_prep_impact_diagnostics.R | 2 +- 2 files changed, 34 insertions(+), 18 deletions(-) diff --git a/R/fn_impact_diagnostics.R b/R/fn_impact_diagnostics.R index 8280845..89e49f7 100644 --- a/R/fn_impact_diagnostics.R +++ b/R/fn_impact_diagnostics.R @@ -111,15 +111,14 @@ flag_duplicates <- function(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) { name = "n_key" ) - # dplyr::filter(df, .data$n_key == 1L) if (any(df$n_key > 1)) { - n_duplicates <- sum(df$n_key > 1) + n_duplicates <- sum(df$n_key > 1) # nolint used below cli::cli_warn( "{n_duplicates} duplicates found in data; please check for plausibility!" ) } - return(df) + df } #' @name filter_impact_data @@ -138,7 +137,6 @@ filter_invalid_trajectories <- function( ) { checkmate::assert_data_frame(df, min.cols = 1L, min.rows = 1L) - # TODO: can we find checks for prev_data size in reln to df? rows? cols? checkmate::assert_data_frame( prev_data, min.rows = nrow(df) @@ -289,7 +287,7 @@ generate_diffs <- function( interest_cols ) - tibble::as_tibble(changes) + changes } #' Generate IQR for key outcomes @@ -352,7 +350,7 @@ gen_national_iqr <- function( .groups = "drop" ) - tibble::as_tibble(df) + df } #' Flag significant changes in impact estimates @@ -399,12 +397,15 @@ flag_large_diffs <- function( touchstone_new = DEF_TOUCHSTONE_NEW ) { checkmate::assert_list(changes_list, c("data.frame", "NULL")) - checkmate::assert_data_frame(iqr_df, min.rows = 1L, min.cols = 1L) + checkmate::assert_data_frame( + iqr_df, + min.rows = 1L, + min.cols = length(group_cols) + ) variable <- rlang::arg_match(variable) checkmate::assert_character(group_cols, min.len = 1L, any.missing = FALSE) - # TODO: check what a sensible upper limit might be checkmate::assert_number(threshold, lower = 1.0, finite = TRUE) touchstone_old <- validate_ts_year(touchstone_old) @@ -479,12 +480,12 @@ flag_large_diffs <- function( ) df_compare <- dplyr::rename( df_compare, - rename_lookup + dplyr::all_of(rename_lookup) ) df_compare <- dplyr::arrange(df_compare, dplyr::desc(diff)) - tibble::as_tibble(df_compare) + df_compare } #' Combine and align data from two touchstones @@ -495,8 +496,8 @@ flag_large_diffs <- function( #' @param prev_dat A data.frame of impact estimates corresponding to an earlier #' touchstone. #' -#' @param df_clean A data.frame of impact estimates corresponding to a more recent -#' touchstone. +#' @param df_clean A data.frame of impact estimates corresponding to a more +#' recent touchstone. #' #' @param interest_cols A character vector of columns of interest. Defaults to #' [COLNAMES_INTEREST_PRESSURE_TEST]. @@ -504,8 +505,8 @@ flag_large_diffs <- function( #' @param key_cols A character vector of columns of interest. Defaults to #' [COLNAMES_KEY_PRESSURE_TEST]. #' -#' @return A data.frame which is a full join of `prev_dat` and `df_clean`. Columns -#' are disambiguated with the suffixes `"_old"` and `"_new"`. +#' @return A data.frame which is a full join of `prev_dat` and `df_clean`. +#' Columns are disambiguated with the suffixes `"_old"` and `"_new"`. #' #' @keywords impact_diagnostics #' @@ -574,7 +575,7 @@ gen_combined_df <- function( dplyr::all_of(cols_to_select) ) - tibble::as_tibble(combined) + combined } #' Compare sub-regional and national estimates @@ -599,6 +600,21 @@ compare_natl_subreg <- function( outcome = c("deaths_averted_rate", "dalys_averted_rate"), activity_filter = c("campaign", "routine") ) { + checkmate::assert_data_frame( + df, + min.rows = 1L, + min.cols = length( + c(outcome, "subregion", COLNAMES_KEY_PRESSURE_TEST) + ) + ) + outcome <- rlang::arg_match(outcome) + activity_filter <- rlang::arg_match(activity_filter) + + checkmate::assert_names( + names(df), + must.include = c(outcome, "subregion", COLNAMES_KEY_PRESSURE_TEST) + ) + df <- dplyr::filter(df, .data$activity_type == activity_filter) df <- dplyr::select( df, @@ -611,7 +627,7 @@ compare_natl_subreg <- function( national_summary <- dplyr::select( df, dplyr::all_of(COLNAMES_KEY_PRESSURE_TEST), - .data$subregion, + "subregion", !!outcome ) national_summary <- dplyr::rename( @@ -668,7 +684,7 @@ compare_natl_subreg <- function( comparison <- dplyr::select(comparison, {{ cols_to_select }}) comparison <- dplyr::arrange(comparison, dplyr::desc(.data$iqr_score)) - tibble::as_tibble(comparison) + comparison } #' Save pressure-testing diagnostics to local file diff --git a/R/fn_plotting_prep_impact_diagnostics.R b/R/fn_plotting_prep_impact_diagnostics.R index d529d7d..272771a 100644 --- a/R/fn_plotting_prep_impact_diagnostics.R +++ b/R/fn_plotting_prep_impact_diagnostics.R @@ -333,5 +333,5 @@ prep_plot_cumul <- function( return(NULL) } - tibble::as_tibble(df_plot) + df_plot } From 991d47946088d38cd8c33f7558264bec92ce93a2 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Fri, 5 Jun 2026 15:17:58 +0100 Subject: [PATCH 22/29] Add test suite for impact fns --- .../test-impact_diagnostics_filtering.R | 187 +++++++++++++ tests/testthat/test-impact_diffs.R | 257 ++++++++++++++++++ tests/testthat/test-natl_subreg_comparison.R | 65 +++++ 3 files changed, 509 insertions(+) create mode 100644 tests/testthat/test-impact_diagnostics_filtering.R create mode 100644 tests/testthat/test-impact_diffs.R create mode 100644 tests/testthat/test-natl_subreg_comparison.R diff --git a/tests/testthat/test-impact_diagnostics_filtering.R b/tests/testthat/test-impact_diagnostics_filtering.R new file mode 100644 index 0000000..af05bd9 --- /dev/null +++ b/tests/testthat/test-impact_diagnostics_filtering.R @@ -0,0 +1,187 @@ +# each test uses a scoped copy of impact data +test_that("`filter_recent_ts()`: Filtering by touchstone works", { + df <- eg_impact + df$touchstone <- DEF_TOUCHSTONE_NEW + test_scenario_types <- rep( + c("default", "dummy"), + each = nrow(df) / 2 + ) + df$scenario_type <- test_scenario_types + + # touchstone is most recent one - expect filtering + expect_data_frame( + filter_recent_ts(df) + ) + # half rows are excluded due to scenario name + expect_equal( + nrow(filter_recent_ts(df)), + nrow(df) / 2L + ) + + # touchstone is older - no filtering + df$touchstone <- DEF_TOUCHSTONE_OLD + + expect_data_frame( + filter_recent_ts(df) + ) + expect_equal( + nrow(filter_recent_ts(df)), + nrow(df) + ) + + # warnings and errors + # bad df input + expect_error( + filter_recent_ts("df"), + "Must be of type 'data.frame'" + ) + expect_error( + filter_recent_ts(data.frame()) + ) + expect_error( + filter_recent_ts(data.frame(year = 2026)) + ) + expect_error( + filter_recent_ts(data.frame(year = 2026, disease = "YF")), + "Names must include the elements \\{'touchstone'\\}" + ) + expect_error( + filter_recent_ts(data.frame(touchstone = 2026, year = 2026)), + "(Touchstone year should be a string with at least 6)*(characters)" + ) + + # bad touchstone + expect_error( + filter_recent_ts(df, as.numeric(DEF_TOUCHSTONE_NEW)), + "(Touchstone year should be a string with at least 6)*(characters)" + ) +}) + +# each test uses a scoped copy of impact data +test_that("`filter_excluded_diseases_ts()`: Filtering by disease works", { + df <- eg_impact + df$touchstone <- DEF_TOUCHSTONE_NEW + + # replace known rows with an exlcuded disease + n_replaced <- 100L + df[1:n_replaced, "disease"] <- EXCLUDED_DISEASES[1L] + + # touchstone at/above threshold - expect no filtering + expect_data_frame( + filter_excluded_diseases_ts(df) + ) + expect_equal( + nrow(filter_excluded_diseases_ts(df)), + nrow(df) + ) + + # touchstone is older than threshold - expect filtering + df$touchstone <- DEF_TOUCHSTONE_OLD + expect_equal( + nrow(filter_excluded_diseases_ts(df, DEF_TOUCHSTONE_NEW)), + nrow(df) - n_replaced + ) + + # warnings and errors + # bad df input + expect_error( + filter_excluded_diseases_ts("df"), + "Must be of type 'data.frame'" + ) + expect_error( + filter_excluded_diseases_ts(data.frame()) + ) + expect_error( + filter_excluded_diseases_ts(data.frame(year = 2026)), + "Names must include the elements \\{'touchstone'\\}" + ) + expect_error( + filter_excluded_diseases_ts(data.frame(touchstone = 2026)), + "(Touchstone year should be a string with at least 6)*(characters)" + ) + + # bad touchstone + expect_error( + filter_excluded_diseases_ts(df, as.numeric(DEF_TOUCHSTONE_NEW)), + "(Touchstone year should be a string with at least 6)*(characters)" + ) +}) + +test_that("`flag_duplicates()`: Flagging duplicates works", { + df <- eg_impact + expect_warning( + flag_duplicates(df), + "duplicates found in data" + ) + expect_data_frame( + suppressWarnings(flag_duplicates(df)) + ) + + # TODO: please check that duplicates are true duplicates + expect_equal( + nrow(flag_duplicates(df)), + nrow(df) + ) + + expect_true( + "n_key" %in% colnames(flag_duplicates(df)) + ) + + # errors + expect_error( + flag_duplicates("df"), + "Must be of type 'data.frame'" + ) + expect_error( + flag_duplicates(df, 1:100), + "Must have at least 100 cols" + ) + expect_error( + flag_duplicates(df, 1:6), + "'key_cols' failed: Must be of type 'character'" + ) + expect_error( + flag_duplicates( + data.frame(year = 2026), + "vaccine" + ), + "(Expected `df` to have columns)*(but columns)*(were missing)" + ) +}) + +# TODO: how should this be tested? +test_that("`filter_invalid_trajectories()`: Filtering impact trends works", { + prev_df <- flag_duplicates(eg_impact) + prev_df <- dplyr::filter(prev_df, n_key == 1) + prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" + ) + prev_df$support_type <- "other" # unsure what values this can take + prev_df$coverage <- 0.5 + prev_df$deaths_averted <- 1e3 + prev_df$dalys_averted <- 1e6 + + # assign dummy values + curr_df <- prev_df + curr_df$deaths_averted <- NA_real_ + curr_df$dalys_averted <- NA_real_ + + expect_data_frame( + filter_invalid_trajectories( + curr_df, + prev_df + ) + ) + expect_equal( + nrow( + filter_invalid_trajectories( + curr_df, + prev_df + ) + ), + nrow(curr_df) + ) +}) diff --git a/tests/testthat/test-impact_diffs.R b/tests/testthat/test-impact_diffs.R new file mode 100644 index 0000000..2876ce9 --- /dev/null +++ b/tests/testthat/test-impact_diffs.R @@ -0,0 +1,257 @@ +test_that("`gen_national_iqr()`: Generating impact IQR works", { + df <- flag_duplicates(eg_impact) + df <- dplyr::filter(df, n_key == 1) + df <- tidyr::pivot_wider( + df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" + ) + + expect_data_frame( + gen_national_iqr(df) + ) + expect_data_frame( + gen_national_iqr(df, value_cols = "deaths_averted") + ) + expect_data_frame( + gen_national_iqr(df, value_cols = "deaths_averted") + ) + + group_cols <- c("country", "vaccine", "activity_type") + value_cols <- c("deaths_averted", "dalys_averted") + prefix <- "xyz_prefix" + df_iqr <- gen_national_iqr( + df, + group_cols, + value_cols, + prefix + ) + + expect_names( + names(df_iqr), + must.include = c(group_cols, sprintf("%s_%s", prefix, value_cols)) + ) + + # check for errors + expect_error( + gen_national_iqr("df"), + "Must be of type 'data.frame'" + ) + expect_error( + gen_national_iqr(data.frame(year = 2026)), + "Must have at least 5 cols" + ) + expect_error( + gen_national_iqr( + as.data.frame(as.list(1:10)) + ), + "Names must include" + ) + expect_error( + gen_national_iqr( + df, + 1:10 + ), + "(group_cols)*(Must be of type 'character')" + ) + expect_error( + gen_national_iqr( + df, + value_cols = "dummy_value_col" + ), + "(value_cols)*(has additional elements)*(dummy_value_col)" + ) + expect_error( + gen_national_iqr(df, prefix = 1L), + "Must be of type 'string'" + ) +}) + +test_that("`generate_diffs()`: Generating differences works", { + prev_df <- flag_duplicates(eg_impact) + prev_df <- dplyr::filter(prev_df, n_key == 1) + prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" + ) + prev_df$support_type <- "other" # unsure what values this can take + prev_df$coverage <- 0.5 + + # assign dummy values + curr_df <- prev_df + curr_df$deaths_averted <- 1e3 + curr_df$dalys_averted <- 1e6 + + interest_cols <- c("deaths_averted", "dalys_averted") + difflist <- generate_diffs( + prev_df, + curr_df, + interest_cols + ) + expect_list( + difflist, + names = "unique" + ) + expect_names( + names(difflist), + permutation.of = interest_cols + ) + + # errors and warnings + expect_error( + generate_diffs("df"), + "Must be of type 'data.frame'" + ) + expect_error( + generate_diffs(data.frame(year = 2026)), + "Must have at least 14 cols" + ) + expect_error( + generate_diffs(prev_df, "df"), + "Must be of type 'data.frame'" + ) + expect_error( + generate_diffs(prev_df, data.frame(year = 2026)), + "Must have at least 14 cols" + ) + expect_error( + generate_diffs( + prev_df, + curr_df, + 1:10 + ), + "(interest_cols)*(Must be of type 'character')" + ) + expect_error( + generate_diffs( + prev_df, + curr_df, + key_cols = 1:10 + ), + "(key_cols)*(Must be of type 'character')" + ) + expect_error( + generate_diffs( + as.data.frame(as.list(1:14)), + curr_df + ), + "(colnames\\(prev_df\\))*(Names must include)" + ) + expect_error( + generate_diffs( + prev_df, + as.data.frame(as.list(1:14)) + ), + "(colnames\\(curr_df\\))*(Names must include)" + ) + expect_error( + generate_diffs( + prev_df, + curr_df, + touchstone = "999999" + ) + ) +}) + + +test_that("`flag_large_diffs()`: Flagging large diffs works", { + prev_df <- flag_duplicates(eg_impact) + prev_df <- dplyr::filter(prev_df, n_key == 1) + prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" + ) + prev_df$support_type <- "other" # unsure what values this can take + prev_df$coverage <- 0.5 + + # assign dummy values + curr_df <- prev_df + curr_df$deaths_averted <- 1e6 + curr_df$dalys_averted <- 1e9 + + interest_cols <- c("deaths_averted", "dalys_averted") + changes <- generate_diffs( + prev_df, + curr_df, + interest_cols + ) + + # national IQR - inset dummy values for tests + national_iqr <- gen_national_iqr(prev_df) + national_iqr$national_iqr_deaths_averted <- seq_len(nrow(national_iqr)) + + expect_data_frame( + flag_large_diffs( + changes, + national_iqr, + "deaths_averted" + ) + ) + expect_data_frame( + flag_large_diffs( + changes, + national_iqr, + "dalys_averted" + ) + ) + + # check touchstones added + tstone_old <- "208801" + tstone_new <- "209901" + diffs <- flag_large_diffs( + changes, + national_iqr, + "deaths_averted", + touchstone_old = tstone_old, + touchstone_new = tstone_new + ) + expect_names( + names(diffs), + must.include = c(tstone_old, tstone_new) + ) +}) + +test_that("`gen_combined_df()`: Generating combined data works", { + prev_df <- flag_duplicates(eg_impact) + prev_df <- dplyr::filter(prev_df, n_key == 1) + prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" + ) + prev_df$support_type <- "other" # unsure what values this can take + prev_df$coverage <- 0.5 + prev_df$fvps <- 1e6 + prev_df$target_population <- 2e6 + + # assign dummy values + curr_df <- prev_df + curr_df$deaths_averted <- 1e6 + curr_df$dalys_averted <- 1e9 + + expect_data_frame( + gen_combined_df( + prev_df, + curr_df + ) + ) + expect_names( + names( + gen_combined_df( + prev_df, + curr_df + ) + ), + must.include = sprintf( + "%s_%s", + c("deaths_averted", "dalys_averted"), + c("old", "new") + ) + ) +}) diff --git a/tests/testthat/test-natl_subreg_comparison.R b/tests/testthat/test-natl_subreg_comparison.R new file mode 100644 index 0000000..6ff1e37 --- /dev/null +++ b/tests/testthat/test-natl_subreg_comparison.R @@ -0,0 +1,65 @@ +# TODO: unsure how this should be tested with data provided +test_that("`compare_natl_subreg()`: Comparing national-subregional works", { + df <- flag_duplicates(eg_impact) + df <- dplyr::filter(df, n_key == 1) + df <- tidyr::pivot_wider( + df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" + ) + # prev_df$support_type <- "other" # unsure what values this can take + # prev_df$coverage <- 0.5 + + # assign dummy values + df$deaths_averted <- 1e3 + df$dalys_averted <- 1e6 + + df <- dplyr::left_join( + df, + who_subregions, + by = c("country", "country_name") + ) + + expect_data_frame( + compare_natl_subreg(df) + ) + expect_names( + names(compare_natl_subreg(df)), + must.include = c( + "country_name", + "vaccine", + "year", + "modelling_group", + "national_value", + "subregional_mean", + "subregional_iqr", + "difference", + "iqr_score" + ) + ) + + # errors and warnings + expect_error( + compare_natl_subreg("df"), + "Must be of type 'data.frame'" + ) + expect_error( + compare_natl_subreg(data.frame(year = 2026)), + "Must have at least 10 cols" + ) + expect_error( + compare_natl_subreg( + as.data.frame(as.list(1:10)) + ), + "Names must include the elements" + ) + expect_error( + compare_natl_subreg(df, "dummy_outcome"), + "`outcome` must be one of" + ) + expect_error( + compare_natl_subreg(df, activity_filter = "dummy_activity"), + "`activity_filter` must be one of" + ) +}) From 9663b5cb00f03b9f8506db912fa4c936752a17db Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Fri, 5 Jun 2026 15:18:21 +0100 Subject: [PATCH 23/29] Update docs and NEWS --- NAMESPACE | 2 +- NEWS.md | 2 ++ man/eg_impact.Rd | 35 +++++++++++++++++++++++++++++++++++ man/filter_impact_data.Rd | 8 ++++---- man/who_subregions.Rd | 34 ++++++++++++++++++++++++++++++++++ tests/testthat.R | 1 + 6 files changed, 77 insertions(+), 5 deletions(-) create mode 100644 man/eg_impact.Rd create mode 100644 man/who_subregions.Rd diff --git a/NAMESPACE b/NAMESPACE index 7caa5f0..cb7c3f0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,10 +21,10 @@ export(colnames_df_missing_cols) export(colnames_plot_demog_compare) export(compare_natl_subreg) export(file_dict_colnames) -export(filter_duplicates) export(filter_excluded_diseases_ts) export(filter_invalid_trajectories) export(filter_recent_ts) +export(flag_duplicates) export(flag_large_diffs) export(gen_combined_df) export(gen_national_iqr) diff --git a/NEWS.md b/NEWS.md index b7f6fc8..be7d35e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,8 @@ - Added impact diagnostics functions in `R/fn_impact_diagnostics.R`. +- Added test data originally used in [vimpact](https://github.com/vimc/vimpact) for use with vimcheck. + - Added plotting preparation functions and plotting functions in `R/fn_plotting_prep_impact_diagnostics.R` and `R/fn_plotting_impact_diagnostics.R`. - Added dependencies _diffdf_ and _here_. diff --git a/man/eg_impact.Rd b/man/eg_impact.Rd new file mode 100644 index 0000000..7334325 --- /dev/null +++ b/man/eg_impact.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/example_data.R +\docType{data} +\name{eg_impact} +\alias{eg_impact} +\title{Example of impact data} +\format{ +\subsection{\code{eg_impact}}{ + +A data frame with 5396 rows and 9 columns: +\describe{ +\item{disease}{Disease name.} +\item{vaccine}{Vaccine identifier.} +\item{modelling_group}{Modelling group name.} +\item{country}{Country ISO 3-character code.} +\item{country_name}{Country name.} +\item{year}{Year for which impacts are modelled.} +\item{activity_type}{Activity type: either "routine" or "campaign."} +\item{burden_outcome}{Name of the burden outcome; one of "deaths_averted" +or "dalys_averted".} +\item{impact}{Value of the impact}. +} +} +} +\source{ +Prepared by the VIMC secretariat. +} +\usage{ +eg_impact +} +\description{ +Example of vaccine impact data taken from data used to test \pkg{vimpact}. +This data is primarily used for testing here too. +} +\keyword{data} diff --git a/man/filter_impact_data.Rd b/man/filter_impact_data.Rd index da36793..bb941e3 100644 --- a/man/filter_impact_data.Rd +++ b/man/filter_impact_data.Rd @@ -4,7 +4,7 @@ \alias{filter_impact_data} \alias{filter_recent_ts} \alias{filter_excluded_diseases_ts} -\alias{filter_duplicates} +\alias{flag_duplicates} \alias{filter_invalid_trajectories} \title{Filter data for touchstones or diseases} \usage{ @@ -12,7 +12,7 @@ filter_recent_ts(df, threshold = DEF_TOUCHSTONE_NEW) filter_excluded_diseases_ts(df, threshold = DEF_TOUCHSTONE_OLD_OLD) -filter_duplicates(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) +flag_duplicates(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) filter_invalid_trajectories( df, @@ -44,8 +44,8 @@ is not met excluded. \item \code{filter_excluded_diseases_ts()} returns \code{df} with rows where rows relating to the \link{EXCLUDED_DISEASES}, when the touchstone year in \code{df} is less than the \code{threshold}, excluded. -\item \code{filter_duplicates()} returns \code{df} with duplicated combinations of -\code{key_cols} removed. +\item \code{flag_duplicates()} returns \code{df} with duplicated combinations of +\code{key_cols} flagged using the column \code{n_key} (or a user-defined name). \item \code{filter_invalid_trajectories()} returns \code{df} with bad outcome trajectories (\code{NA} to non-\code{NA}) removed. } diff --git a/man/who_subregions.Rd b/man/who_subregions.Rd new file mode 100644 index 0000000..5cd4166 --- /dev/null +++ b/man/who_subregions.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_who_subregions.R +\docType{data} +\name{who_subregions} +\alias{who_subregions} +\title{Data on countries in WHO subregions} +\format{ +\subsection{\code{who_subregions}}{ + +A data frame with 249 rows and 9 columns: +\describe{ +\item{choice_subregion}{Sub-region three character code with added letter +identifier.} +\item{country_name}{Country name in long form.} +\item{country}{ISO 3 character country code.} +\item{Global.Name}{A constant, 'World'.} +\item{Region.Name}{Continent-scale region identifier.} +\item{Sub.region}{Sub-continental scale region identifer.} +\item{Intermediate.Region.Name}{Alternative regional scale identifier.} +\item{subregion}{Sub-regional identifier.} +\item{vimc117}{Logical identifier.} +} +} +} +\source{ +Prepared by the VIMC secretariat. +} +\usage{ +who_subregions +} +\description{ +Data that groups countries into WHO subregions. +} +\keyword{data} diff --git a/tests/testthat.R b/tests/testthat.R index 5e3689c..c425a75 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -7,6 +7,7 @@ # * https://testthat.r-lib.org/articles/special-files.html library(testthat) +library(checkmate) library(vimcheck) test_check("vimcheck") From 72dff258628a151a6c9bb6b58eb1dad9d234d97d Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 8 Jun 2026 17:14:29 +0100 Subject: [PATCH 24/29] Minor edits to fns --- R/data_who_subregions.R | 2 +- R/fn_helpers.R | 10 +++++----- R/fn_impact_diagnostics.R | 23 ++++++++++++++++++----- R/fn_plotting_impact_diagnostics.R | 11 +++++------ man/gen_combined_df.Rd | 8 ++++---- man/generate_diffs.Rd | 2 +- man/plot_impact_diagnostics.Rd | 9 ++++----- man/who_subregions.Rd | 2 +- 8 files changed, 39 insertions(+), 28 deletions(-) diff --git a/R/data_who_subregions.R b/R/data_who_subregions.R index 2e435b6..abc796a 100644 --- a/R/data_who_subregions.R +++ b/R/data_who_subregions.R @@ -11,7 +11,7 @@ #' \item{country}{ISO 3 character country code.} #' \item{Global.Name}{A constant, 'World'.} #' \item{Region.Name}{Continent-scale region identifier.} -#' \item{Sub.region}{Sub-continental scale region identifer.} +#' \item{Sub.region}{Sub-continental scale region identifier.} #' \item{Intermediate.Region.Name}{Alternative regional scale identifier.} #' \item{subregion}{Sub-regional identifier.} #' \item{vimc117}{Logical identifier.} diff --git a/R/fn_helpers.R b/R/fn_helpers.R index d3997f8..73dcde3 100644 --- a/R/fn_helpers.R +++ b/R/fn_helpers.R @@ -143,13 +143,13 @@ validate_ts_year <- function(x) { if (!is_good_month) { cli::cli_abort( "Touchstone month string has an inferred month of \ - {.strong {inferred_month}} but expected an month in the range \ + {.strong {inferred_month}} but expected a month in the range \ [{MIN_TS_MONTH}, {MAX_TS_MONTH}]." ) } - # return year-month as numeric - substr(x, 1, N_TS_MIN_CHARS) + # return year-month as string + as.numeric(substr(x, 1, N_TS_MIN_CHARS)) } #' Add campaign id to dataframe @@ -163,7 +163,7 @@ validate_ts_year <- function(x) { #' #' @keywords internal add_campaign_id <- function(df, key_cols) { - checkmate::assert_data_frame(df) + checkmate::assert_data_frame(df, min.cols = length(key_cols)) checkmate::assert_character(key_cols, any.missing = FALSE) has_cols <- checkmate::test_names( @@ -171,7 +171,7 @@ add_campaign_id <- function(df, key_cols) { must.include = key_cols ) if (!has_cols) { - missing_cols <- setdiff(colnames(df), key_cols) # nolint used in cli + missing_cols <- setdiff(key_cols, colnames(df)) # nolint used in cli cli::cli_abort( "Expected {.code df} to have columns {.str {key_cols}} but columns \ {.str {missing_cols}} are missing." diff --git a/R/fn_impact_diagnostics.R b/R/fn_impact_diagnostics.R index 89e49f7..9539094 100644 --- a/R/fn_impact_diagnostics.R +++ b/R/fn_impact_diagnostics.R @@ -45,6 +45,8 @@ filter_recent_ts <- function(df, threshold = DEF_TOUCHSTONE_NEW) { ts_number <- validate_ts_year(touchstone_year) # see R/helpers.R + df <- tibble::as_tibble(df) + # NOTE: consider converting to Date and checking - numeric comparison # works okay for now if (ts_number >= threshold) { @@ -75,6 +77,8 @@ filter_excluded_diseases_ts <- function( touchstone_year <- unique(df$touchstone) ts_number <- validate_ts_year(touchstone_year) + df <- tibble::as_tibble(df) + if (ts_number <= threshold) { dplyr::filter(df, !.data$disease %in% EXCLUDED_DISEASES) } else { @@ -118,7 +122,7 @@ flag_duplicates <- function(df, key_cols = COLNAMES_KEY_PRESSURE_TEST) { ) } - df + tibble::as_tibble(df) } #' @name filter_impact_data @@ -191,11 +195,13 @@ filter_invalid_trajectories <- function( ) # `,` replaces `&` for dplyr syntax - dplyr::filter( + result <- dplyr::filter( result, !is.na(.data$outcome_prev), is.na(.data$outcome_cur) ) + + tibble::as_tibble(result) } #' Explore significant changes in deaths and DALYs @@ -216,7 +222,7 @@ filter_invalid_trajectories <- function( #' @param touchstone A six character string that can be converted to a six digit #' numeric giving a touchstone identifier in `YYYYMM` format. #' -#' @return A list of data.frames of differences between `prev_df` and `curr_df`, +#' @return A list of tibbles of differences between `prev_df` and `curr_df`, #' with one list element per element of `interest_cols`. #' #' @keywords impact_diagnostics @@ -279,6 +285,7 @@ generate_diffs <- function( keys = diff_keys ) + # diffdf's Vardiff_* returns a tibble, no need to convert changes <- stats::setNames( lapply(interest_cols, function(v) { nm <- glue::glue("VarDiff_{v}") @@ -287,7 +294,7 @@ generate_diffs <- function( interest_cols ) - changes + changes # a list of tibbles } #' Generate IQR for key outcomes @@ -336,6 +343,8 @@ gen_national_iqr <- function( must.include = union(group_cols, value_cols) ) + df <- tibble::as_tibble(df) + # long-winded syntax to pass grouping variables as char vec df <- dplyr::group_by(df, dplyr::across(dplyr::all_of(group_cols))) df <- dplyr::summarise( @@ -419,7 +428,7 @@ flag_large_diffs <- function( {.str {variable}}, but it does not." ) } - df_compare <- changes_list[[variable]] + df_compare <- tibble::as_tibble(changes_list[[variable]]) checkmate::assert_names( colnames(df_compare), @@ -565,6 +574,8 @@ gen_combined_df <- function( suffix = c("_old", "_new") ) + combined <- tibble::as_tibble(combined) + checkmate::assert_names( colnames(combined), must.include = cols_to_select @@ -615,6 +626,8 @@ compare_natl_subreg <- function( must.include = c(outcome, "subregion", COLNAMES_KEY_PRESSURE_TEST) ) + df <- tibble::as_tibble(df) + df <- dplyr::filter(df, .data$activity_type == activity_filter) df <- dplyr::select( df, diff --git a/R/fn_plotting_impact_diagnostics.R b/R/fn_plotting_impact_diagnostics.R index dfb1e8f..c0cbd08 100644 --- a/R/fn_plotting_impact_diagnostics.R +++ b/R/fn_plotting_impact_diagnostics.R @@ -18,15 +18,14 @@ #' @description #' Plotting functions for impact diagnostics. See #' [plotting-preparation functions][plot_prep_impact_diagnostics] for a set of -#' helper functions that prepare impact diagnostics for plotting. +#' helper functions that prepare impact diagnostics for plotting. See the +#' details of the `data` argument for functions that help to prepare the data. #' #' @param data A data.frame suitable for plotting. #' -#' - `plot_sig_diff()`: Output of -#' [`flag_large_diff()`][plot_prep_impact_diagnostics]. +#' - `plot_sig_diff()`: Output of [`flag_large_diff()`][flag_large_diffs]. #' -#' - `plot_diff()`: Output of -#' [`gen_combined_df()`][plot_prep_impact_diagnostics]. +#' - `plot_diff()`: Output of [`gen_combined_df()`][gen_combined_df]. #' #' - `plot_modelling_group_variation()`: Output of #' [`plot_prep_mod_grp_varn()`][plot_prep_impact_diagnostics]. @@ -61,7 +60,7 @@ plot_sig_diff <- function(data, outcome = IMPACT_OUTCOMES) { ) + geom_segment( aes(x = 0, xend = .data$diff, y = .data$label, yend = .data$label), - size = 1 + linewidth = 1 ) + geom_point(size = 2) + labs( diff --git a/man/gen_combined_df.Rd b/man/gen_combined_df.Rd index 13dd05d..db8a4ad 100644 --- a/man/gen_combined_df.Rd +++ b/man/gen_combined_df.Rd @@ -15,8 +15,8 @@ gen_combined_df( \item{prev_dat}{A data.frame of impact estimates corresponding to an earlier touchstone.} -\item{df_clean}{A data.frame of impact estimates corresponding to a more recent -touchstone.} +\item{df_clean}{A data.frame of impact estimates corresponding to a more +recent touchstone.} \item{interest_cols}{A character vector of columns of interest. Defaults to \link{COLNAMES_INTEREST_PRESSURE_TEST}.} @@ -25,8 +25,8 @@ touchstone.} \link{COLNAMES_KEY_PRESSURE_TEST}.} } \value{ -A data.frame which is a full join of \code{prev_dat} and \code{df_clean}. Columns -are disambiguated with the suffixes \code{"_old"} and \code{"_new"}. +A data.frame which is a full join of \code{prev_dat} and \code{df_clean}. +Columns are disambiguated with the suffixes \code{"_old"} and \code{"_new"}. } \description{ Generates a full join of two data.frames, selecting for columns of interest. diff --git a/man/generate_diffs.Rd b/man/generate_diffs.Rd index 03a8500..a577600 100644 --- a/man/generate_diffs.Rd +++ b/man/generate_diffs.Rd @@ -30,7 +30,7 @@ identifiers. Passed to \code{\link[=add_campaign_id]{add_campaign_id()}}, defaul numeric giving a touchstone identifier in \code{YYYYMM} format.} } \value{ -A list of data.frames of differences between \code{prev_df} and \code{curr_df}, +A list of tibbles of differences between \code{prev_df} and \code{curr_df}, with one list element per element of \code{interest_cols}. } \description{ diff --git a/man/plot_impact_diagnostics.Rd b/man/plot_impact_diagnostics.Rd index c195f97..aee324f 100644 --- a/man/plot_impact_diagnostics.Rd +++ b/man/plot_impact_diagnostics.Rd @@ -28,10 +28,8 @@ plot_cumul(data) \arguments{ \item{data}{A data.frame suitable for plotting. \itemize{ -\item \code{plot_sig_diff()}: Output of -\code{\link[=plot_prep_impact_diagnostics]{flag_large_diff()}}. -\item \code{plot_diff()}: Output of -\code{\link[=plot_prep_impact_diagnostics]{gen_combined_df()}}. +\item \code{plot_sig_diff()}: Output of \code{\link[=flag_large_diffs]{flag_large_diff()}}. +\item \code{plot_diff()}: Output of \code{\link[=gen_combined_df]{gen_combined_df()}}. \item \code{plot_modelling_group_variation()}: Output of \code{\link[=plot_prep_impact_diagnostics]{plot_prep_mod_grp_varn()}}. \item \code{plot_vaccine_gavi()}: Output of @@ -62,5 +60,6 @@ selection and label preparation is automated to reduce function arguments. Plotting functions for impact diagnostics. See \link[=plot_prep_impact_diagnostics]{plotting-preparation functions} for a set of -helper functions that prepare impact diagnostics for plotting. +helper functions that prepare impact diagnostics for plotting. See the +details of the \code{data} argument for functions that help to prepare the data. } diff --git a/man/who_subregions.Rd b/man/who_subregions.Rd index 5cd4166..56c5552 100644 --- a/man/who_subregions.Rd +++ b/man/who_subregions.Rd @@ -15,7 +15,7 @@ identifier.} \item{country}{ISO 3 character country code.} \item{Global.Name}{A constant, 'World'.} \item{Region.Name}{Continent-scale region identifier.} -\item{Sub.region}{Sub-continental scale region identifer.} +\item{Sub.region}{Sub-continental scale region identifier.} \item{Intermediate.Region.Name}{Alternative regional scale identifier.} \item{subregion}{Sub-regional identifier.} \item{vimc117}{Logical identifier.} From 97585b11a0b1742988964eeeab190c882748c91f Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 8 Jun 2026 17:14:54 +0100 Subject: [PATCH 25/29] Add tests for plotting fns --- tests/testthat.R | 1 + .../plotting-pressure-testing/plot-cumul.svg | 78 + .../plotting-pressure-testing/plot-diff.svg | 1288 +++++++++++++++++ .../plot-modelling-group-variation.svg | 292 ++++ .../plot-sig-diff.svg | 236 +++ .../plot-vaccine-gavi.svg | 247 ++++ tests/testthat/test-helpers.R | 119 ++ .../testthat/test-plotting-pressure-testing.R | 90 ++ 8 files changed, 2351 insertions(+) create mode 100644 tests/testthat/_snaps/plotting-pressure-testing/plot-cumul.svg create mode 100644 tests/testthat/_snaps/plotting-pressure-testing/plot-diff.svg create mode 100644 tests/testthat/_snaps/plotting-pressure-testing/plot-modelling-group-variation.svg create mode 100644 tests/testthat/_snaps/plotting-pressure-testing/plot-sig-diff.svg create mode 100644 tests/testthat/_snaps/plotting-pressure-testing/plot-vaccine-gavi.svg create mode 100644 tests/testthat/test-plotting-pressure-testing.R diff --git a/tests/testthat.R b/tests/testthat.R index c425a75..25c27c3 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -8,6 +8,7 @@ library(testthat) library(checkmate) +library(dplyr) library(vimcheck) test_check("vimcheck") diff --git a/tests/testthat/_snaps/plotting-pressure-testing/plot-cumul.svg b/tests/testthat/_snaps/plotting-pressure-testing/plot-cumul.svg new file mode 100644 index 0000000..df9658c --- /dev/null +++ b/tests/testthat/_snaps/plotting-pressure-testing/plot-cumul.svg @@ -0,0 +1,78 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0e+00 +1e+04 +2e+04 +3e+04 + + + + + + + + +2000 +2010 +2020 +2030 +Year +Cumulative deaths_averted + +Modelling Group + + + + +LSHTM-Jit-201910 +LSHTM-Jit-202310 +Cumulative deaths_averted Over Time - + + diff --git a/tests/testthat/_snaps/plotting-pressure-testing/plot-diff.svg b/tests/testthat/_snaps/plotting-pressure-testing/plot-diff.svg new file mode 100644 index 0000000..a4a983e --- /dev/null +++ b/tests/testthat/_snaps/plotting-pressure-testing/plot-diff.svg @@ -0,0 +1,1288 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +routine + + + + + + + + + + +YF + + + + + + + + + + +routine + + + + + + + + + + +HepB_BD + + + + + + + + + + +routine + + + + + + + + + + +MCV1 + + + + + + + + + + +routine + + + + + + + + + + +MCV2 + + + + + + + + + + +campaign + + + + + + + + + + +Measles + + + + + + + + + + +campaign + + + + + + + + + + +YF + + + + + + + + + + +routine + + + + + + + + + + +HepB + + + + + + + +299.8 +299.9 +300.0 +300.1 +300.2 + + + + + +299.8 +299.9 +300.0 +300.1 +300.2 + + + + +299.8 +300.0 +300.2 +300.4 + + + + + +299.8 +299.9 +300.0 +300.1 +300.2 + + + + + + +299.7 +299.8 +299.9 +300.0 +300.1 +300.2 + + + + + +299.8 +299.9 +300.0 +300.1 +300.2 + + + + + + +299.7 +299.8 +299.9 +300.0 +300.1 +300.2 +99.7 +99.8 +99.9 +100.0 +100.1 +100.2 + + + + + + +99.8 +99.9 +100.0 +100.1 +100.2 + + + + + +99.8 +99.9 +100.0 +100.1 +100.2 + + + + + +99.8 +100.0 +100.2 +100.4 + + + + +99.7 +99.8 +99.9 +100.0 +100.1 +100.2 + + + + + + +99.8 +99.9 +100.0 +100.1 +100.2 + + + + + +99.8 +99.9 +100.0 +100.1 +100.2 + + + + + +202310 - deaths_averted +201910 - deaths_averted +deaths_averted: Current vs Previous Report + + diff --git a/tests/testthat/_snaps/plotting-pressure-testing/plot-modelling-group-variation.svg b/tests/testthat/_snaps/plotting-pressure-testing/plot-modelling-group-variation.svg new file mode 100644 index 0000000..09035fa --- /dev/null +++ b/tests/testthat/_snaps/plotting-pressure-testing/plot-modelling-group-variation.svg @@ -0,0 +1,292 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +activity_type + + + + + + + +10 +2.4768 +10 +2.477 +10 +2.4772 +10 +2.4774 +10 +2.4776 +Measles +HepB +MCV2 +MCV1 +HepB_BD +YF + + + + + + +Burden averted (deaths) +Vaccine +plot_modelling_group_variation + + diff --git a/tests/testthat/_snaps/plotting-pressure-testing/plot-sig-diff.svg b/tests/testthat/_snaps/plotting-pressure-testing/plot-sig-diff.svg new file mode 100644 index 0000000..7fe5197 --- /dev/null +++ b/tests/testthat/_snaps/plotting-pressure-testing/plot-sig-diff.svg @@ -0,0 +1,236 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Ethiopia | HepB | routine | 2003 +Ethiopia | HepB | routine | 2004 +Ethiopia | HepB | routine | 2018 +Ethiopia | HepB | routine | 2019 +Ethiopia | HepB | routine | 2022 +Ethiopia | HepB | routine | 2026 +Ethiopia | HepB | routine | 2000 +Ethiopia | HepB | routine | 2002 +Ethiopia | HepB | routine | 2005 +Ethiopia | HepB | routine | 2006 +Ethiopia | HepB | routine | 2007 +Ethiopia | HepB | routine | 2008 +Ethiopia | HepB | routine | 2009 +Ethiopia | HepB | routine | 2010 +Ethiopia | HepB | routine | 2011 +Ethiopia | HepB | routine | 2012 +Ethiopia | HepB | routine | 2013 +Ethiopia | HepB | routine | 2014 +Ethiopia | HepB | routine | 2015 +Ethiopia | HepB | routine | 2020 +Ethiopia | HepB | routine | 2021 +Ethiopia | HepB | routine | 2023 +Ethiopia | HepB | routine | 2024 +Ethiopia | HepB | routine | 2025 +Ethiopia | HepB | routine | 2027 +Ethiopia | HepB | routine | 2028 +Ethiopia | HepB | routine | 2029 +Ethiopia | HepB | routine | 2030 +Ethiopia | HepB | routine | 2001 +Ethiopia | HepB | routine | 2016 +Ethiopia | HepB | routine | 2017 +Ethiopia | HepB_BD | routine | 2007 +Ethiopia | HepB_BD | routine | 2013 +Ethiopia | HepB_BD | routine | 2016 +Ethiopia | HepB_BD | routine | 2023 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +50 +100 +150 +200 +Difference + +modelling_group + + + +IC-Hallett +Significant Differences in deaths_averted by Country, Vaccine, Activity Type and Year + + diff --git a/tests/testthat/_snaps/plotting-pressure-testing/plot-vaccine-gavi.svg b/tests/testthat/_snaps/plotting-pressure-testing/plot-vaccine-gavi.svg new file mode 100644 index 0000000..e19814f --- /dev/null +++ b/tests/testthat/_snaps/plotting-pressure-testing/plot-vaccine-gavi.svg @@ -0,0 +1,247 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +201910 + + + + + + + + + + +Difference + + + + + + + + + + +202310 + + + + + + +Measles +YF +MenA +HepB + + + + +Measles +YF +MenA +HepB + + + + +Measles +YF +MenA +HepB +0.0e+00 +5.0e+02 +1.0e+03 +1.5e+03 +2.0e+03 +2.5e+03 + + + + + + +0.0e+00 +5.0e+02 +1.0e+03 +1.5e+03 + + + + +0e+00 +2e+02 +4e+02 +6e+02 +8e+02 + + + + + +Disease +Impact - deaths_averted + +Year + + + + + + + + +2021 +2022 +2023 +2024 +plot_vaccine_gavi + + diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 4c7f56d..e6b277b 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -11,3 +11,122 @@ test_that("`make_novax_scenario()` works", { file_dict_colnames ) }) + +test_that("Adaptive rounding works", { + expect_number( + adaptive_round(runif(1)) + ) + expect_numeric( + adaptive_round(runif(10)) + ) + + large_num <- 1.346 + expected_num <- 1.3 + expect_identical( + adaptive_round(large_num), + expected_num + ) + + small_num <- 0.345 + expected_num <- 0.34 + expect_identical( + adaptive_round(small_num), + expected_num + ) + + # round numeric + df <- data.frame( + year_but_complex = 2010:2015 + 0.35, + num = 1.346 + ) + expect_data_frame(round_numeric(df)) + df_new <- round_numeric(df) + + # expect year not rounded + expect_identical( + df_new$year_but_complex, + df$year_but_complex + ) + + expect_identical( + df_new$num, + adaptive_round(df_new$num) + ) +}) + +test_that("`validate_ts_year()`: Validating touchstone works", { + ts <- "202010" + expect_number( + validate_ts_year(ts), + lower = 200001, + upper = 210012 + ) + + expect_error( + validate_ts_year(202010), + "should be a string" + ) + + ts <- "2020" + expect_error( + validate_ts_year(ts), + "at least 6 characters" + ) + + ts <- "199910" + expect_error( + validate_ts_year(ts), + "expected an year in the range \\[2000, 2100\\]" + ) + + ts <- "220010" + expect_error( + validate_ts_year(ts), + "expected an year in the range \\[2000, 2100\\]" + ) + + ts <- "202019" + expect_error( + validate_ts_year(ts), + "expected a month in the range \\[1, 12\\]" + ) +}) + +test_that("`add_campaign_id()`: Adding campaign identifier works", { + df <- data.frame( + key1 = c("a", "b", "c", "a", "b", "c"), + key2 = letters[1:6] + ) + + df_new <- add_campaign_id(df, c("key1", "key2")) + expect_data_frame(df_new) + expect_names(names(df_new), must.include = "campaign_id") + expect_identical( + unique(df_new$campaign_id), + 1L + ) + + df_new <- add_campaign_id(df, c("key1")) + expect_identical( + unique(df_new$campaign_id), + c(1L, 2L) + ) + + expect_error( + add_campaign_id("df", "key"), + "Must be of type 'data.frame'" + ) + expect_error( + add_campaign_id(df, letters), + "Must have at least 26 cols" + ) + expect_error( + add_campaign_id(df, c("a", "b")), + "(columns)*(are missing)" + ) + + expect_error( + add_campaign_id(df, 1:2), + "(key_cols)*(Must be of type 'character')" + ) +}) diff --git a/tests/testthat/test-plotting-pressure-testing.R b/tests/testthat/test-plotting-pressure-testing.R new file mode 100644 index 0000000..f6871e6 --- /dev/null +++ b/tests/testthat/test-plotting-pressure-testing.R @@ -0,0 +1,90 @@ +# preparatory code +prev_df <- flag_duplicates(eg_impact) +prev_df <- dplyr::filter(prev_df, n_key == 1) +prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" +) +prev_df$support_type <- "other" # unsure what values this can take +prev_df$coverage <- 0.5 +prev_df$fvps <- 1e6 +prev_df$target_population <- 2e6 + +prev_df$deaths_averted <- withr::with_seed( + 1, + rnorm(nrow(prev_df), 100, 0.1) +) +prev_df$dalys_averted <- prev_df$deaths_averted * 100 + +# assign dummy values +curr_df <- prev_df +curr_df$deaths_averted <- withr::with_seed( + 1, + rnorm(nrow(prev_df), 300, 0.1) +) +curr_df$dalys_averted <- curr_df$deaths_averted * 100 + +interest_cols <- c("deaths_averted", "dalys_averted") +changes <- generate_diffs( + prev_df, + curr_df, + interest_cols +) + +# national IQR - inset dummy values for tests +national_iqr <- gen_national_iqr(prev_df) +national_iqr$national_iqr_deaths_averted <- seq_len(nrow(national_iqr)) + +test_that("plot_sig_diff() works", { + df_plot <- flag_large_diffs(changes, national_iqr) + + p <- plot_sig_diff(df_plot) + + expect_class(p, "ggplot") + vdiffr::expect_doppelganger("plot_sig_diff", p) +}) + +test_that("plot_diff() works", { + df_plot <- gen_combined_df(prev_df, curr_df) + + p <- plot_diff(df_plot) + + expect_class(p, "ggplot") + vdiffr::expect_doppelganger("plot_diff", p) +}) + +test_that("plot_modelling_group_variation() works", { + prev_df <- dplyr::select(curr_df, vaccine, modelling_group) %>% + dplyr::distinct() %>% + dplyr::group_by(vaccine) %>% + dplyr::mutate(mod_num = dplyr::row_number()) + + df_plot <- prep_plot_mod_grp_varn(curr_df, prev_df) + + p <- plot_modelling_group_variation(df_plot) + + expect_class(p, "ggplot") + vdiffr::expect_doppelganger("plot_modelling_group_variation", p) +}) + +test_that("plot_vaccine_gavi() works", { + df_plot <- prep_plot_vax_gavi(curr_df, prev_df, "deaths_averted") + + p <- plot_vaccine_gavi(df_plot) + + expect_class(p, "ggplot") + vdiffr::expect_doppelganger("plot_vaccine_gavi", p) +}) + +test_that("plot_cumul() works", { + combined_df <- gen_combined_df(prev_df, curr_df) + + df_plot <- prep_plot_cumul(combined_df, "deaths_averted", "Measles") + + p <- plot_cumul(df_plot) + + expect_class(p, "ggplot") + vdiffr::expect_doppelganger("plot_cumul", p) +}) From 113b551fd39671cbcddc1702c04fa66d943cb59d Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 8 Jun 2026 17:15:22 +0100 Subject: [PATCH 26/29] Update wordlist and add design vignette --- inst/WORDLIST | 11 ++++ vignettes/design_decisions.Rmd | 104 +++++++++++++++++++++++++++++++++ 2 files changed, 115 insertions(+) create mode 100644 vignettes/design_decisions.Rmd diff --git a/inst/WORDLIST b/inst/WORDLIST index bc3ac78..2a6ca65 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -14,18 +14,29 @@ Nayagam ORCID Shevanthi Susy +Tidyverse Toor VIMC +VIMC's WIP WPP YLLs YYYYMM autogenerated +cli dalys +devtools diffdf +eg erroring facetted ggplot iqr +pkgdown +roxygen +testthat tibble tibbles +timeseries +usethis +vimpact diff --git a/vignettes/design_decisions.Rmd b/vignettes/design_decisions.Rmd new file mode 100644 index 0000000..60bc59f --- /dev/null +++ b/vignettes/design_decisions.Rmd @@ -0,0 +1,104 @@ +--- +title: "Package design decisions" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Package design decisions} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +This page documents _vimcheck_ package design decisions as a guide to users, and to potential contributors seeking to extend this package or revise some of those decisions. + +Some design decisions that live in the background include: + +- _vimcheck_ is set up as a modern R package built with _devtools_, _usethis_, and _testthat_ (testing); +- _vimcheck_ is documented using _roxygen2_ and _pkgdown_ for the package website; +- _vimcheck_ is developed on GitHub and uses continuous integration workflows provided by GitHub Actions; +- Any other decisions not covered here most likely follow advice in [Wickham and Bryan's _R Packages_](https://r-pkgs.org/). + +## Big picture + +_vimcheck_ is intended to collect, house, and be the single source for functionality used by VIMC to check submitted modelling outputs for discrepancies. +This solves the immediate problem that this functionality is currently spread and repeated over multiple reports, increasing the potential for discrepancies and functionality drift in the tools. +The overall goal is to improve the quality of VIMC's work by improving the reliability of VIMC outputs. +The main users are currently intended to be members of the VIMC Secretariat, but may include VIMC consortium members in future. + +## Function organisation + +_vimcheck_ is currently developed in bursts, with each burst so far adding a set of data wrangling and plotting functions taken from a specific VIMC report. + +The package has two axes of organisation for its functionality: the theme or goal of the report from which the function comes, and what the function does. + +The current reports from which functions have been taken relate to: + +- Diagnostics on burden estimates provided by VIMC modelling groups, and +- Pressure testing diagnostics intended to check for outliers in vaccine impact estimates. + +Functions are split into four categories, and the general idea is to have functionality be modular. +As an example, _vimcheck_ favours functions that produce intermediate products that can be reused by multiple downstream functions (following the [DRY principle](https://en.wikipedia.org/wiki/Don%27t_repeat_yourself)). + +- Functions that work on data: This is the main functionality of the package and includes functions that work with raw or semi-processed data, such as burden or impact estimates; +- Functions that prepare data for plotting: These are functions that sit between the data wrangling functions and plotting functions; +- Plotting functions that are typically related to one upstream data-wrangling or plotting-preparation function; +- Helper functions that provide useful but miscellaneous functionality. + +The general idea is to be able to set up small R pipelines within reports of the following form. + +```r +# some data read in from a local source +data |> + fn_wrangle_data() |> + fn_prep_data_for_plotting() |> + fn_plot_data() +``` + +The [function reference in the documentation](https://vimc.github.io/vimcheck/reference/index.html) is organised similarly. + +The R source code files in `./R/` are also organised in this way; for example `R/fn_burden_diagnostics.R` holds data-wrangling functions related to burden estimates, `R/fn_plotting_prep_bur_diag.R` holds functions to prepare wrangled data for plotting, and `R/fn_plotting_burden_diagnostics.R` holds plotting functions for the prepared data. + +## Package data + +_vimcheck_ includes some package data which is used to demonstrate and test its functionality. +Some data is purely dummy data that follows the structure of data seen in VIMC reports. +However, some data such as [eg_impact] is real VIMC data that has been released publicly as part of other packages. + +There is a number of package constants, which are single values or small vectors that are provided with and exported from the package. + +## Package dependencies + +We only list notable dependencies here. + +- [Tidyverse packages](https://www.tidyverse.org/) over base R or _data.table_; this is to keep functions within the dependency framework used in the reports from which they come --- we assume the report writers are also the package user-base and _vimcheck_ aims to be used, and friendly to use, for these people. + +- _cli_ and _glue_ for string interpolation and printing error messages to screen. + +- _diffdf_ to provide differences between data.frames. + +- _ggplot2_ for plotting; functions are not explicitly namespaced in many cases, but imported from the package to reduce code clutter in plotting function files. + +- _checkmate_ for input checking and to extend _testthat_. + +- [_vdiffr_](https://cran.r-project.org/package=vdiffr) for snapshot tests of plotting functions. + +### Data frames and tibbles + +Data-wrangling functions are agnostic to the type of tabular input, but always return a [tibble](https://tibble.tidyverse.org/) rather than a plain data.frame (if they return tabular data). +This is because internal manipulation using Tidyverse functions often results in tibbles being produced (e.g. using `tidyr::pivot_*()`, or `dplyr::group_by()` followed by ungrouping), but inexplicably some Tidyverse functions preserve data.frames. +We think it is preferable for users and developers to have a uniform function output type rather than have to guess whether it will be a tibble or a data.frame. +A second reason is that tibbles are much easier to read when printed to screen. + +**Note that** all downstream functions --- plotting preparation and plotting functions --- that expect tabular data expect a tibble, and **will error** if they are not passed a tibble! +This is partially to create some friction so that users check what they are passing: data processed with _vimcheck_ will always return a tibble, downstream functions only work on processed data, and errors might indicate that the wrong data are being passed. + +## Testing + +_vimcheck_ function are tested using package data (see above). +As a result, tests focus on input checking and the form of outputs. +There are comparatively few tests on correctness (e.g. are output numbers within a range), and this is a clear avenue for further development. From d87f5a0398104508adb19508d93a18ba2d90ce4b Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 9 Jun 2026 10:25:15 +0100 Subject: [PATCH 27/29] WIP pressure testing vignette --- vignettes/pressure_testing.Rmd | 76 ++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 vignettes/pressure_testing.Rmd diff --git a/vignettes/pressure_testing.Rmd b/vignettes/pressure_testing.Rmd new file mode 100644 index 0000000..8dbe4bf --- /dev/null +++ b/vignettes/pressure_testing.Rmd @@ -0,0 +1,76 @@ +--- +title: "Pressure testing functions" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Pressure testing functions} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +This vignette shows how to use functions added from the pressure testing report. + +```{r setup} +library(vimcheck) +library(dplyr) +library(tidyr) +``` + +## Example data + +Example impact data are taken from [_vimpact_](github.com/vimc/vimpact) and included in the package as [eg_impact]. +This dataset holds projections for four countries, four diseases, and three modelling groups; combinations are shown below. + +```{r impact_data} +eg_impact + +# check countries +unique(eg_impact$country_name) + +# check diseases +unique(eg_impact$disease) + +# check modelling group +unique(eg_impact$modelling_group) + +# check combinations +distinct(eg_impact, country_name, disease, modelling_group) +``` + +Data on WHO regions is provided as [who_subregions] to enable comparing countries with their regions. + +```{r who_regions} +who_subregions +``` + +## Filtering impact data + +Impact data can be filtered, or flagged for filtering, in different ways. + +Flag data for filtering on touchstone using [filter_recent_ts()]. + +```{r filter_ts} +# assign dummy touchstones and scenario type for demo +df <- eg_impact +df$touchstone <- rep( + c("202412", "202012"), + each = nrow(df) / 2 +) + +test_scenario_types <- rep( + c("default", "dummy"), + each = nrow(df) / 2 +) + +# use a package default touchstone +DEF_TOUCHSTONE_NEW + +# only touchstones from 2020 remain +filter_recent_ts(df, DEF_TOUCHSTONE_NEW) +``` From 1f1ac93520b18a1afb56be854de45e649188a6e9 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 9 Jun 2026 16:18:20 +0100 Subject: [PATCH 28/29] Minor updates, update vignette --- NEWS.md | 2 + R/fn_impact_diagnostics.R | 24 +- R/fn_plotting_impact_diagnostics.R | 1 - inst/WORDLIST | 12 +- .../test-impact_diagnostics_filtering.R | 7 +- tests/testthat/test-impact_diffs.R | 32 +- tests/testthat/test-natl_subreg_comparison.R | 2 +- .../testthat/test-plotting-pressure-testing.R | 13 +- vignettes/pressure_testing.Rmd | 286 +++++++++++++++++- 9 files changed, 340 insertions(+), 39 deletions(-) diff --git a/NEWS.md b/NEWS.md index be7d35e..fcaa798 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,8 @@ - Added dependencies _diffdf_ and _here_. +- Added vignette on design decisions and pressure testing functions. + # vimcheck 0.0.3 - Separated data-prep for plotting from plotting functions. diff --git a/R/fn_impact_diagnostics.R b/R/fn_impact_diagnostics.R index 9539094..95575c2 100644 --- a/R/fn_impact_diagnostics.R +++ b/R/fn_impact_diagnostics.R @@ -526,9 +526,16 @@ gen_combined_df <- function( interest_cols = COLNAMES_INTEREST_PRESSURE_TEST, key_cols = COLNAMES_KEY_PRESSURE_TEST ) { + n_expected_cols <- length(union(interest_cols, key_cols)) checkmate::assert_data_frame( prev_dat, - min.cols = 1L, + min.cols = n_expected_cols, + min.rows = 1L + ) + + checkmate::assert_data_frame( + df_clean, + min.cols = n_expected_cols, min.rows = 1L ) @@ -557,13 +564,24 @@ gen_combined_df <- function( checkmate::assert_names( colnames(prev_dat), - must.include = c(interest_cols, key_cols) + must.include = c(interest_cols, key_cols, "touchstone") ) checkmate::assert_names( colnames(df_clean), - must.include = c(interest_cols, key_cols) + must.include = c(interest_cols, key_cols, "touchstone") ) + # check touchstones + ts_old <- validate_ts_year(unique(prev_dat$touchstone)) + ts_new <- validate_ts_year(unique(df_clean$touchstone)) + + if (ts_old == ts_new) { + cli::cli_abort( + "Touchstones for previous data and current data are the same: {ts_old}, \ + please check datasets!" + ) + } + prev_df <- dplyr::select(prev_dat, {{ interest_cols }}) cur_df <- dplyr::select(df_clean, {{ interest_cols }}) diff --git a/R/fn_plotting_impact_diagnostics.R b/R/fn_plotting_impact_diagnostics.R index c0cbd08..273628e 100644 --- a/R/fn_plotting_impact_diagnostics.R +++ b/R/fn_plotting_impact_diagnostics.R @@ -187,7 +187,6 @@ plot_modelling_group_variation <- function(data) { # for scales formatting .x <- NULL - # TODO: should NA-producing values (< 1) be removed? ggplot(data) + aes( fill = as.character(.data$mod_num), diff --git a/inst/WORDLIST b/inst/WORDLIST index 2a6ca65..380dd4c 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -7,6 +7,7 @@ FVPs GAVI GHA Hallett +IQRs Jaspreet Kaja Londono @@ -24,19 +25,28 @@ YLLs YYYYMM autogenerated cli +cumul dalys devtools +df diffdf eg erroring facetted +gavi ggplot +grp iqr pkgdown roxygen +sig +subreg testthat tibble tibbles -timeseries +ts usethis +varn +vax +vdiffr vimpact diff --git a/tests/testthat/test-impact_diagnostics_filtering.R b/tests/testthat/test-impact_diagnostics_filtering.R index af05bd9..db0cc00 100644 --- a/tests/testthat/test-impact_diagnostics_filtering.R +++ b/tests/testthat/test-impact_diagnostics_filtering.R @@ -117,14 +117,13 @@ test_that("`flag_duplicates()`: Flagging duplicates works", { suppressWarnings(flag_duplicates(df)) ) - # TODO: please check that duplicates are true duplicates expect_equal( - nrow(flag_duplicates(df)), + nrow(suppressWarnings(flag_duplicates(df))), nrow(df) ) expect_true( - "n_key" %in% colnames(flag_duplicates(df)) + "n_key" %in% colnames(suppressWarnings(flag_duplicates(df))) ) # errors @@ -151,7 +150,7 @@ test_that("`flag_duplicates()`: Flagging duplicates works", { # TODO: how should this be tested? test_that("`filter_invalid_trajectories()`: Filtering impact trends works", { - prev_df <- flag_duplicates(eg_impact) + prev_df <- suppressWarnings(flag_duplicates(eg_impact)) prev_df <- dplyr::filter(prev_df, n_key == 1) prev_df <- tidyr::pivot_wider( prev_df, diff --git a/tests/testthat/test-impact_diffs.R b/tests/testthat/test-impact_diffs.R index 2876ce9..f4da073 100644 --- a/tests/testthat/test-impact_diffs.R +++ b/tests/testthat/test-impact_diffs.R @@ -1,5 +1,5 @@ test_that("`gen_national_iqr()`: Generating impact IQR works", { - df <- flag_duplicates(eg_impact) + df <- suppressWarnings(flag_duplicates(eg_impact)) df <- dplyr::filter(df, n_key == 1) df <- tidyr::pivot_wider( df, @@ -69,7 +69,7 @@ test_that("`gen_national_iqr()`: Generating impact IQR works", { }) test_that("`generate_diffs()`: Generating differences works", { - prev_df <- flag_duplicates(eg_impact) + prev_df <- suppressWarnings(flag_duplicates(eg_impact)) prev_df <- dplyr::filter(prev_df, n_key == 1) prev_df <- tidyr::pivot_wider( prev_df, @@ -86,10 +86,12 @@ test_that("`generate_diffs()`: Generating differences works", { curr_df$dalys_averted <- 1e6 interest_cols <- c("deaths_averted", "dalys_averted") - difflist <- generate_diffs( - prev_df, - curr_df, - interest_cols + difflist <- suppressWarnings( + generate_diffs( + prev_df, + curr_df, + interest_cols + ) ) expect_list( difflist, @@ -158,7 +160,7 @@ test_that("`generate_diffs()`: Generating differences works", { test_that("`flag_large_diffs()`: Flagging large diffs works", { - prev_df <- flag_duplicates(eg_impact) + prev_df <- suppressWarnings(flag_duplicates(eg_impact)) prev_df <- dplyr::filter(prev_df, n_key == 1) prev_df <- tidyr::pivot_wider( prev_df, @@ -175,11 +177,11 @@ test_that("`flag_large_diffs()`: Flagging large diffs works", { curr_df$dalys_averted <- 1e9 interest_cols <- c("deaths_averted", "dalys_averted") - changes <- generate_diffs( + changes <- suppressWarnings(generate_diffs( prev_df, curr_df, interest_cols - ) + )) # national IQR - inset dummy values for tests national_iqr <- gen_national_iqr(prev_df) @@ -217,7 +219,7 @@ test_that("`flag_large_diffs()`: Flagging large diffs works", { }) test_that("`gen_combined_df()`: Generating combined data works", { - prev_df <- flag_duplicates(eg_impact) + prev_df <- suppressWarnings(flag_duplicates(eg_impact)) prev_df <- dplyr::filter(prev_df, n_key == 1) prev_df <- tidyr::pivot_wider( prev_df, @@ -229,11 +231,13 @@ test_that("`gen_combined_df()`: Generating combined data works", { prev_df$coverage <- 0.5 prev_df$fvps <- 1e6 prev_df$target_population <- 2e6 + prev_df$touchstone <- "202010" # assign dummy values curr_df <- prev_df curr_df$deaths_averted <- 1e6 curr_df$dalys_averted <- 1e9 + curr_df$touchstone <- "202310" expect_data_frame( gen_combined_df( @@ -254,4 +258,12 @@ test_that("`gen_combined_df()`: Generating combined data works", { c("old", "new") ) ) + + # check error on touchstone + prev_df$touchstone <- NULL + curr_df$touchstone <- NULL + expect_error( + gen_combined_df(prev_df, curr_df), + "(Names)*(is missing elements)*(touchstone)" + ) }) diff --git a/tests/testthat/test-natl_subreg_comparison.R b/tests/testthat/test-natl_subreg_comparison.R index 6ff1e37..8194391 100644 --- a/tests/testthat/test-natl_subreg_comparison.R +++ b/tests/testthat/test-natl_subreg_comparison.R @@ -1,6 +1,6 @@ # TODO: unsure how this should be tested with data provided test_that("`compare_natl_subreg()`: Comparing national-subregional works", { - df <- flag_duplicates(eg_impact) + df <- suppressWarnings(flag_duplicates(eg_impact)) df <- dplyr::filter(df, n_key == 1) df <- tidyr::pivot_wider( df, diff --git a/tests/testthat/test-plotting-pressure-testing.R b/tests/testthat/test-plotting-pressure-testing.R index f6871e6..a27dead 100644 --- a/tests/testthat/test-plotting-pressure-testing.R +++ b/tests/testthat/test-plotting-pressure-testing.R @@ -1,5 +1,5 @@ # preparatory code -prev_df <- flag_duplicates(eg_impact) +prev_df <- suppressWarnings(flag_duplicates(eg_impact)) prev_df <- dplyr::filter(prev_df, n_key == 1) prev_df <- tidyr::pivot_wider( prev_df, @@ -17,6 +17,7 @@ prev_df$deaths_averted <- withr::with_seed( rnorm(nrow(prev_df), 100, 0.1) ) prev_df$dalys_averted <- prev_df$deaths_averted * 100 +prev_df$touchstone <- "202010" # assign dummy values curr_df <- prev_df @@ -25,13 +26,14 @@ curr_df$deaths_averted <- withr::with_seed( rnorm(nrow(prev_df), 300, 0.1) ) curr_df$dalys_averted <- curr_df$deaths_averted * 100 +curr_df$touchstone <- "202110" interest_cols <- c("deaths_averted", "dalys_averted") -changes <- generate_diffs( +changes <- suppressWarnings(generate_diffs( prev_df, curr_df, interest_cols -) +)) # national IQR - inset dummy values for tests national_iqr <- gen_national_iqr(prev_df) @@ -81,7 +83,10 @@ test_that("plot_vaccine_gavi() works", { test_that("plot_cumul() works", { combined_df <- gen_combined_df(prev_df, curr_df) - df_plot <- prep_plot_cumul(combined_df, "deaths_averted", "Measles") + # NOTE: warnings probably generated due to use of dummy data + df_plot <- suppressWarnings( + prep_plot_cumul(combined_df, "deaths_averted", "Measles") + ) p <- plot_cumul(df_plot) diff --git a/vignettes/pressure_testing.Rmd b/vignettes/pressure_testing.Rmd index 8dbe4bf..1fbe66b 100644 --- a/vignettes/pressure_testing.Rmd +++ b/vignettes/pressure_testing.Rmd @@ -30,15 +30,6 @@ This dataset holds projections for four countries, four diseases, and three mode ```{r impact_data} eg_impact -# check countries -unique(eg_impact$country_name) - -# check diseases -unique(eg_impact$disease) - -# check modelling group -unique(eg_impact$modelling_group) - # check combinations distinct(eg_impact, country_name, disease, modelling_group) ``` @@ -53,24 +44,289 @@ who_subregions Impact data can be filtered, or flagged for filtering, in different ways. -Flag data for filtering on touchstone using [filter_recent_ts()]. +### Filtering on touchstone + +Data can be filtered on touchstone using [filter_recent_ts()]; rows with `scenario_type` matching "default" are retained. + +Some useful default touchstone values are `DEF_TOUCHSTONE_NEW` (`r DEF_TOUCHSTONE_NEW`), `DEF_TOUCHSTONE_OLD` (`r DEF_TOUCHSTONE_OLD`), and `DEF_TOUCHSTONE_OLD_OLD` (`r DEF_TOUCHSTONE_OLD_OLD`) ```{r filter_ts} # assign dummy touchstones and scenario type for demo df <- eg_impact -df$touchstone <- rep( - c("202412", "202012"), - each = nrow(df) / 2 -) +df$touchstone <- "202401" test_scenario_types <- rep( c("default", "dummy"), each = nrow(df) / 2 ) +df$scenario_type <- test_scenario_types # use a package default touchstone DEF_TOUCHSTONE_NEW -# only touchstones from 2020 remain +# touchstone filtering is applied to all non-default scenario rows filter_recent_ts(df, DEF_TOUCHSTONE_NEW) ``` + +### Filtering on diseases + +Data can be filtered to exclude a fixed set of diseases, if the touchstone is older than a threshold value, using [filter_excluded_diseases_ts()]. + +The excluded diseases are stored as the package constant `EXCLUDED_DISEASES` (`r cli::cli_text("{.str {EXCLUDED_DISEASES}}")`). + +```{r filter_diseases} +# make a copy and add dummy disease values +df_copy <- df +df_copy$disease <- rep( + EXCLUDED_DISEASES, each = nrow(df_copy) / length(EXCLUDED_DISEASES) +) + +# pass dummy touchstone to filter out all rows +filter_excluded_diseases_ts(df_copy, "202501") +``` + +### Flagging duplicates + +Duplicated rows in the data can be identifier by adding a flag variable column `n_key`, using [flag_duplicates()]. + +Duplicates are identified across columns specified by the argument `key_cols`, which defaults to `r cli::cli_text("{.str {COLNAMES_KEY_PRESSURE_TEST}}")`. + +```{r flag_dups} +# view n_keys column +flag_duplicates(eg_impact) %>% + select( + modelling_group, country, disease, + vaccine, activity_type, year, n_key + ) +``` + +### Filtering invalid trajectories + +The function [filter_invalid_trajectories()] can be used to remove rows where outcome values are missing in one of two paired datasets (each ideally from a different touchstone). + +This function should be applied to data which has the impact outcomes as columns (i.e., in wide format), with duplicates removed. + +The outcome to check is specified by the argument `"outcome"`. + +```{r filter_traj} +# create some dummy data from exampled data +prev_df <- flag_duplicates(eg_impact) +prev_df <- dplyr::filter(prev_df, n_key == 1) +prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" +) +prev_df$support_type <- "other" # unsure what values this can take +rows <- nrow(prev_df) +prev_df$coverage <- 0.5 + +prev_df$deaths_averted <- withr::with_seed( + 1, sample(c(5e2, NA_real_), rows, TRUE) +) +prev_df$dalys_averted <- withr::with_seed( + 1, sample(c(5e5, NA_real_), rows, TRUE) +) + +# assign dummy values +curr_df <- prev_df +curr_df$deaths_averted <- 1e3 +curr_df$dalys_averted <- 1e6 + +# View data with invalid trajectories removed +filter_invalid_trajectories(prev_df, curr_df, "deaths_averted") +``` + +## Identifying differences between datasets + +This section provides a general demonstration of tools that help to identify differences between two paired datasets. + +### Generating differences + +The function [generate_diffs()] uses the _diffdf_ package to identify differences between two data frames. +The output is a list of tibbles with the added column `VARIABLE` for the column examined for differences, with the baseline and comparator as `BASE` and `COMPARE`. + +```{r gen_diffs} +# use prev_df from section above +prev_df$deaths_averted <- withr::with_seed( + 1, rnorm(rows, 1e3, 100) +) +prev_df$dalys_averted <- withr::with_seed( + 1, rnorm(rows, 1e6, 100) +) + +# assign dummy values +curr_df <- prev_df +curr_df$deaths_averted <- prev_df$deaths_averted * 2 +curr_df$dalys_averted <- prev_df$dalys_averted * 2 + +interest_cols <- c("deaths_averted", "dalys_averted") +difflist <- generate_diffs( + prev_df, + curr_df, + interest_cols +) + +# all rows are different - view the output types +names(difflist) + +difflist +``` + +### Generate national IQRs + +The function [generate_national_iqr()] generates the inter-quartile range of the impact outcome for a dataset. + +```{r gen_iqr} +# assign dummy values to check functionality +df <- prev_df +df$deaths_averted <- withr::with_seed( + 1, rnorm(rows, 1e3, 100) +) + +iqr_df <- gen_national_iqr(df, value_cols = "deaths_averted") + +iqr_df +``` + +### Flag large differences + +The function [flag_large_diffs()] can be used with the outputs of [generate_diffs()] and [gen_national_iqr()] to find rows where the impact estimate is outside the range expected, given the IQR. + +```{r flag_diffs} +# assign some dummy values that will trigger flagging +difflist2 <- difflist +difflist2$deaths_averted$COMPARE <- 1e9 # typical values for BASE are ~1000 + +# all rows are flagged as having differences > IQR +flag_large_diffs(difflist2, iqr_df, "deaths_averted") +``` + +### Generate a combined dataset + +[gen_combined_df()] can be used to generate a combined dataset across two different touchstones. + +```{r gen_combined} +# regenerate data +prev_df <- flag_duplicates(eg_impact) +prev_df <- dplyr::filter(prev_df, n_key == 1) +prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" +) +prev_df$support_type <- "other" # unsure what values this can take +prev_df$coverage <- 0.5 +prev_df$fvps <- 1e6 +prev_df$target_population <- 2e6 +prev_df$touchstone <- "202010" + +# assign dummy values +curr_df <- prev_df +curr_df$deaths_averted <- 1e6 +curr_df$dalys_averted <- 1e9 +curr_df$touchstone <- "202110" + +gen_combined_df(prev_df, curr_df) +``` + +## Comparing national values to regional values + +[compare_natl_subreg()] allows comparing national impact rates with regional rates, where regions are the WHO regions. + +There is no example for this functionality as yet. + +## Plotting functions + +This section covers plotting functions. + +First we prepare some dummy data for plotting. + +```{r plot_prep} +# preparatory code with dummy data +prev_df <- flag_duplicates(eg_impact) +prev_df <- dplyr::filter(prev_df, n_key == 1) +prev_df <- tidyr::pivot_wider( + prev_df, + id_cols = {{ COLNAMES_KEY_PRESSURE_TEST }}, + names_from = "burden_outcome", + values_from = "impact" +) +prev_df$support_type <- "other" # unsure what values this can take +prev_df$coverage <- 0.5 +prev_df$fvps <- 1e6 +prev_df$target_population <- 2e6 + +prev_df$deaths_averted <- withr::with_seed( + 1, + rnorm(nrow(prev_df), 100, 0.1) +) +prev_df$dalys_averted <- prev_df$deaths_averted * 100 +prev_df$touchstone <- "202010" + +# assign dummy values +curr_df <- prev_df +curr_df$deaths_averted <- withr::with_seed( + 1, + rnorm(nrow(prev_df), 300, 0.1) +) +curr_df$dalys_averted <- curr_df$deaths_averted * 100 +curr_df$touchstone <- "202110" + +interest_cols <- c("deaths_averted", "dalys_averted") +changes <- generate_diffs( + prev_df, + curr_df, + interest_cols +) + +# national IQR - inset dummy values for tests +national_iqr <- gen_national_iqr(prev_df) +national_iqr$national_iqr_deaths_averted <- seq_len(nrow(national_iqr)) +``` + +### Plotting significant differences + +Find and flag large diffs using [flag_large_diffs()] and visualise the output using [plot_sig_diff()]. + +```{r plot_sig_diff} +flag_large_diffs(changes, national_iqr) |> + plot_sig_diff() +``` + +### Plotting modelling group variation + +Visualise variation in impact by modelling group using [plot_modelling_group_variation()]. + +Data should be prepared using [prep_plot_mod_grp_varn()] first. + +```{r plot_mod_grp_var} +prev_df_copy <- dplyr::select(curr_df, vaccine, modelling_group) %>% + dplyr::distinct() %>% + dplyr::group_by(vaccine) %>% + dplyr::mutate(mod_num = dplyr::row_number()) + +prep_plot_mod_grp_varn(curr_df, prev_df_copy) |> + plot_modelling_group_variation() +``` + +### Plotting GAVI vaccination + +Use [plot_vaccine_gavi()] on data that has been prepared using [prep_plot_vax_gavi()]. + +```{r plot_gavi} +prep_plot_vax_gavi(curr_df, prev_df, "deaths_averted") |> + plot_vaccine_gavi() +``` + +### Plot cumulative values + +Use [plot_cumul()] on data prepared using [prep_plot_cumul()] and [gen_combined_df()]. + +```{r plot_cumul} +gen_combined_df(prev_df, curr_df) |> + prep_plot_cumul("deaths_averted", "Measles") |> + plot_cumul() +``` \ No newline at end of file From 812311d88cd7df9cb0dda772eb0d3809f18b8fe0 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 9 Jun 2026 16:31:18 +0100 Subject: [PATCH 29/29] Fix docs issues --- vignettes/design_decisions.Rmd | 2 +- vignettes/pressure_testing.Rmd | 32 ++++++++++++++++---------------- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/vignettes/design_decisions.Rmd b/vignettes/design_decisions.Rmd index 60bc59f..638f786 100644 --- a/vignettes/design_decisions.Rmd +++ b/vignettes/design_decisions.Rmd @@ -75,7 +75,7 @@ There is a number of package constants, which are single values or small vectors We only list notable dependencies here. -- [Tidyverse packages](https://www.tidyverse.org/) over base R or _data.table_; this is to keep functions within the dependency framework used in the reports from which they come --- we assume the report writers are also the package user-base and _vimcheck_ aims to be used, and friendly to use, for these people. +- [Tidyverse packages](https://tidyverse.org/) over base R or _data.table_; this is to keep functions within the dependency framework used in the reports from which they come --- we assume the report writers are also the package user-base and _vimcheck_ aims to be used, and friendly to use, for these people. - _cli_ and _glue_ for string interpolation and printing error messages to screen. diff --git a/vignettes/pressure_testing.Rmd b/vignettes/pressure_testing.Rmd index 1fbe66b..e19271a 100644 --- a/vignettes/pressure_testing.Rmd +++ b/vignettes/pressure_testing.Rmd @@ -24,7 +24,7 @@ library(tidyr) ## Example data -Example impact data are taken from [_vimpact_](github.com/vimc/vimpact) and included in the package as [eg_impact]. +Example impact data are taken from [_vimpact_](https://github.com/vimc/vimpact) and included in the package as `eg_impact`. This dataset holds projections for four countries, four diseases, and three modelling groups; combinations are shown below. ```{r impact_data} @@ -34,7 +34,7 @@ eg_impact distinct(eg_impact, country_name, disease, modelling_group) ``` -Data on WHO regions is provided as [who_subregions] to enable comparing countries with their regions. +Data on WHO regions is provided as `who_subregions` to enable comparing countries with their regions. ```{r who_regions} who_subregions @@ -46,7 +46,7 @@ Impact data can be filtered, or flagged for filtering, in different ways. ### Filtering on touchstone -Data can be filtered on touchstone using [filter_recent_ts()]; rows with `scenario_type` matching "default" are retained. +Data can be filtered on touchstone using `filter_recent_ts()`; rows with `scenario_type` matching "default" are retained. Some useful default touchstone values are `DEF_TOUCHSTONE_NEW` (`r DEF_TOUCHSTONE_NEW`), `DEF_TOUCHSTONE_OLD` (`r DEF_TOUCHSTONE_OLD`), and `DEF_TOUCHSTONE_OLD_OLD` (`r DEF_TOUCHSTONE_OLD_OLD`) @@ -70,7 +70,7 @@ filter_recent_ts(df, DEF_TOUCHSTONE_NEW) ### Filtering on diseases -Data can be filtered to exclude a fixed set of diseases, if the touchstone is older than a threshold value, using [filter_excluded_diseases_ts()]. +Data can be filtered to exclude a fixed set of diseases, if the touchstone is older than a threshold value, using `filter_excluded_diseases_ts()`. The excluded diseases are stored as the package constant `EXCLUDED_DISEASES` (`r cli::cli_text("{.str {EXCLUDED_DISEASES}}")`). @@ -87,7 +87,7 @@ filter_excluded_diseases_ts(df_copy, "202501") ### Flagging duplicates -Duplicated rows in the data can be identifier by adding a flag variable column `n_key`, using [flag_duplicates()]. +Duplicated rows in the data can be identifier by adding a flag variable column `n_key`, using `flag_duplicates()`. Duplicates are identified across columns specified by the argument `key_cols`, which defaults to `r cli::cli_text("{.str {COLNAMES_KEY_PRESSURE_TEST}}")`. @@ -102,7 +102,7 @@ flag_duplicates(eg_impact) %>% ### Filtering invalid trajectories -The function [filter_invalid_trajectories()] can be used to remove rows where outcome values are missing in one of two paired datasets (each ideally from a different touchstone). +The function `filter_invalid_trajectories()` can be used to remove rows where outcome values are missing in one of two paired datasets (each ideally from a different touchstone). This function should be applied to data which has the impact outcomes as columns (i.e., in wide format), with duplicates removed. @@ -144,7 +144,7 @@ This section provides a general demonstration of tools that help to identify dif ### Generating differences -The function [generate_diffs()] uses the _diffdf_ package to identify differences between two data frames. +The function `generate_diffs()` uses the [_diffdf_ package](https://cran.r-project.org/package=diffdf) to identify differences between two data frames. The output is a list of tibbles with the added column `VARIABLE` for the column examined for differences, with the baseline and comparator as `BASE` and `COMPARE`. ```{r gen_diffs} @@ -176,7 +176,7 @@ difflist ### Generate national IQRs -The function [generate_national_iqr()] generates the inter-quartile range of the impact outcome for a dataset. +The function `generate_national_iqr()` generates the inter-quartile range of the impact outcome for a dataset. ```{r gen_iqr} # assign dummy values to check functionality @@ -192,7 +192,7 @@ iqr_df ### Flag large differences -The function [flag_large_diffs()] can be used with the outputs of [generate_diffs()] and [gen_national_iqr()] to find rows where the impact estimate is outside the range expected, given the IQR. +The function `flag_large_diffs()` can be used with the outputs of `generate_diffs()` and `gen_national_iqr()` to find rows where the impact estimate is outside the range expected, given the IQR. ```{r flag_diffs} # assign some dummy values that will trigger flagging @@ -205,7 +205,7 @@ flag_large_diffs(difflist2, iqr_df, "deaths_averted") ### Generate a combined dataset -[gen_combined_df()] can be used to generate a combined dataset across two different touchstones. +`gen_combined_df()` can be used to generate a combined dataset across two different touchstones. ```{r gen_combined} # regenerate data @@ -234,7 +234,7 @@ gen_combined_df(prev_df, curr_df) ## Comparing national values to regional values -[compare_natl_subreg()] allows comparing national impact rates with regional rates, where regions are the WHO regions. +`compare_natl_subreg()` allows comparing national impact rates with regional rates, where regions are the WHO regions. There is no example for this functionality as yet. @@ -289,7 +289,7 @@ national_iqr$national_iqr_deaths_averted <- seq_len(nrow(national_iqr)) ### Plotting significant differences -Find and flag large diffs using [flag_large_diffs()] and visualise the output using [plot_sig_diff()]. +Find and flag large diffs using `flag_large_diffs()` and visualise the output using `plot_sig_diff()`. ```{r plot_sig_diff} flag_large_diffs(changes, national_iqr) |> @@ -298,9 +298,9 @@ flag_large_diffs(changes, national_iqr) |> ### Plotting modelling group variation -Visualise variation in impact by modelling group using [plot_modelling_group_variation()]. +Visualise variation in impact by modelling group using `plot_modelling_group_variation()`. -Data should be prepared using [prep_plot_mod_grp_varn()] first. +Data should be prepared using `prep_plot_mod_grp_varn()` first. ```{r plot_mod_grp_var} prev_df_copy <- dplyr::select(curr_df, vaccine, modelling_group) %>% @@ -314,7 +314,7 @@ prep_plot_mod_grp_varn(curr_df, prev_df_copy) |> ### Plotting GAVI vaccination -Use [plot_vaccine_gavi()] on data that has been prepared using [prep_plot_vax_gavi()]. +Use `plot_vaccine_gavi()` on data that has been prepared using `prep_plot_vax_gavi()`. ```{r plot_gavi} prep_plot_vax_gavi(curr_df, prev_df, "deaths_averted") |> @@ -323,7 +323,7 @@ prep_plot_vax_gavi(curr_df, prev_df, "deaths_averted") |> ### Plot cumulative values -Use [plot_cumul()] on data prepared using [prep_plot_cumul()] and [gen_combined_df()]. +Use `plot_cumul()` on data prepared using `prep_plot_cumul()` and `gen_combined_df()`. ```{r plot_cumul} gen_combined_df(prev_df, curr_df) |>