Merge pull request #87 from gpw13/scenarios

Enable 'prevent' indicator scenarios

NAMESPACE

@@ -10,6 +10,7 @@ export(billion_ind_codes)
 export(calculate_contribution_sums)
 export(calculate_hep_billion)
 export(calculate_hep_components)
+export(calculate_hep_prevent_ind)
 export(calculate_hpop_billion)
 export(calculate_hpop_billion_change)
 export(calculate_uhc_billion)

R/add_scenarios.R

@@ -76,7 +76,7 @@ add_scenario <- function(df,
                            "covid_sustained_disruption",
                            "return_previous_trajectory",
                            "top_n_iso3"),
-                         ind_ids = billion_ind_codes("all"),
+                         ind_ids = billion_ind_codes("all", include_calculated = TRUE),
                          scenario_col = "scenario",
                          start_year = 2018,
                          end_year = 2025,
@@ -170,7 +170,7 @@ add_scenario_indicator <- function(df,
                                      "top_n_iso3"),
                                    indicator,
                                    start_year = 2018,
-                                   ind_ids = billion_ind_codes("all"),
+                                   ind_ids = billion_ind_codes("all", include_calculated = TRUE),
                                    scenario_col = "scenario",
                                    default_scenario = "default",
                                    bau_scenario = "historical",

R/calculate_hep_components.R

@@ -32,13 +32,6 @@ calculate_hep_components <- function(df,
   df <- billionaiRe_add_columns(df, c("type", "source"), NA_character_)
 
   new_df <- df %>%
-    dplyr::bind_rows(prevent_calculations(
-      .,
-      scenario_col,
-      source,
-      transform_value_col,
-      ind_ids
-    )) %>%
     dplyr::bind_rows(calculate_hepi(
       .,
       scenario_col,
@@ -73,19 +66,28 @@ calculate_hep_components <- function(df,
 #' Calculate prevent indicators
 #'
 #' This function calculates the overall vaccine coverage scores for each pathogen,
-#' including the overall prevent indicator. It is used within `calculate_hep_components()`
-#' and primarily relies on using `purrr::pmap_dfr()` to apply the `pathogen_calc()`
-#' function for each prevent component and overall score.
+#' including the overall prevent indicator. It primarily relies on using
+#' `purrr::pmap_dfr()` to apply the `pathogen_calc()` function for each prevent
+#' component and overall score.
 #'
 #' @inheritParams calculate_hep_components
 #'
-#' @keywords internal
-#'
-prevent_calculations <- function(df,
-                                 scenario_col,
-                                 source,
-                                 transform_value_col,
-                                 ind_ids) {
+#' @export
+calculate_hep_prevent_ind <- function(df,
+                                      scenario_col = NULL,
+                                      transform_value_col = "transform_value",
+                                      source = sprintf("WHO DDI, %s", format(Sys.Date(), "%B %Y")),
+                                      level_col = stringr::str_replace(transform_value_col, "transform_value", "level"),
+                                      ind_ids = billion_ind_codes("hep", include_calculated = TRUE)) {
+
+  assert_columns(df, "iso3", "ind", "year", transform_value_col, scenario_col)
+  assert_same_length(transform_value_col, level_col)
+  assert_unique_rows(df, scenario_col, ind_ids)
+
+  df <- billionaiRe_add_columns(df, c("type", "source"), NA_character_)
+
+  df_original <- df
+
   df <- dplyr::group_by(df, dplyr::across(c("iso3", "year", !!scenario_col)))
 
   args <- list(
@@ -137,13 +139,15 @@ prevent_calculations <- function(df,
     max_value = c(rep(Inf, 13), 100)
   )
 
-  furrr::future_pmap_dfr(args,
+  df <- furrr::future_pmap_dfr(args,
     pathogen_calc,
     df = df,
     transform_value_col = transform_value_col,
     source = source,
     ind_ids = ind_ids
   )
+  df <- dplyr::bind_rows(df, df_original)
+  return(df)
 }
 
 #' Calculate the vaccine coverage for a specific pathogen
@@ -153,7 +157,7 @@ prevent_calculations <- function(df,
 #' currently counts the number of routine vaccinations included in the numerator,
 #' and multiplies the surviving infants denominator by that number.
 #'
-#' This function is currently called from the `prevent_calculations()` function
+#' This function is currently called from the `calculate_hep_prevent_ind()` function
 #' that sits within `calculate_hep_components()`.
 #'
 #' @inheritParams calculate_hep_components

R/scenarios_target.R

@@ -83,7 +83,7 @@ scenario_fixed_target <- function(df,
         is.na(.data[["baseline_value_"]]) ~ as.numeric(0),
         TRUE ~ as.numeric(.data[["baseline_value_"]])
       ),
-      scenario_value = calculate_fixed_target(target_value, small_is_best, .data[["year"]], start_year, target_year, .data[["baseline_value_"]]),
+      scenario_value = calculate_fixed_target(target_value, small_is_best, .data[["year"]], baseline_year, target_year, .data[["baseline_value_"]], .data[["value"]]),
       !!sym(scenario_col) := scenario_name
     ) %>%
     dplyr::select(-c("baseline_value_", "baseline_year_")) %>%
@@ -117,30 +117,30 @@ scenario_fixed_target <- function(df,
 #' @param target_value vector of values to use as targets
 #' @param baseline_value value at baseline_year
 #' @param year (vector) vector of years
+#' @param original_value (vector) vector of the original values. returned for years before the baseline year
 #'
 #' @noRd
 calculate_fixed_target <- function(target_value,
                                    small_is_best,
                                    year,
                                    baseline_year,
                                    target_year,
-                                   baseline_value) {
+                                   baseline_value,
+                                   original_value) {
   if (small_is_best) {
     dplyr::case_when(
-      year >= baseline_year & year <= target_year & baseline_value > target_value ~
+      year >= baseline_year & year <= target_year ~
         baseline_value + (target_value - baseline_value) * (year - baseline_year) / (target_year - baseline_year),
-      year >= baseline_year & year <= target_year & baseline_value <= target_value ~
-        as.numeric(baseline_value),
       year > target_year ~ target_value,
+      year < baseline_year ~ original_value,
       TRUE ~ NA_real_
     )
   } else {
     dplyr::case_when(
-      year >= baseline_year & year <= target_year & baseline_value < target_value ~
+      year >= baseline_year & year <= target_year ~
         baseline_value + (target_value - baseline_value) * (year - baseline_year) / (target_year - baseline_year),
-      year >= baseline_year & year <= target_year & baseline_value >= target_value ~
-        as.numeric(baseline_value),
       year > target_year ~ target_value,
+      year < baseline_year ~ original_value,
       TRUE ~ NA_real_
     )
   }

data-raw/indicator_df.csv

@@ -100,7 +100,7 @@ HE_notify,notify,NA,unproj_data,FALSE,FALSE,TRUE,FALSE,FALSE,DECREP2,Time to not
 NA,polio,NA,NA,FALSE,FALSE,TRUE,FALSE,TRUE,NA,NA,%,%,Polio - Campaigns and routine combined,Polio,NA,NA,NA,NA,NA,NA,NA
 HE_polio_Routine,polio_routine,WHS4_544,unproj_data,FALSE,FALSE,TRUE,FALSE,FALSE,PREV1,Polio 3 - Routine,%,%,Polio 3 - Routine,Polio 3 - Routine,52,prevent,FALSE,NA,NA,Business as usual,AROC 20% percent change between 2015 and 2025
 NA,polio_routine_num,NA,NA,FALSE,FALSE,TRUE,FALSE,FALSE,NA,NA,#,#,Polio - Routine reached population (numerator),Polio - Routine (numerator),NA,NA,FALSE,NA,NA,NA,NA
-HE_vaccinecov,prevent,NA,NA,FALSE,FALSE,TRUE,FALSE,TRUE,PREV8,Prevent,%,%,Prevent,Prevent,59,prevent,NA,NA,NA,NA,NA
+HE_vaccinecov,prevent,NA,NA,FALSE,FALSE,TRUE,FALSE,TRUE,PREV8,Prevent,%,%,Prevent,Prevent,59,prevent,FALSE,NA,NA,NA,NA
 HE_respond,respond,NA,unproj_data,FALSE,FALSE,TRUE,FALSE,FALSE,DECREP3,Time to respond,days,%,Time to respond,Time to respond,62,detect_respond,FALSE,NA,NA,Business as usual,Business as usual
 HE_surviving_infants,surviving_infants,NA,proj_data,FALSE,FALSE,TRUE,FALSE,FALSE,NA,NA,#,#,Surviving infants,Surviving infants,NA,NA,FALSE,NA,NA,NA,NA
 NA,yellow_fever,NA,NA,FALSE,FALSE,TRUE,FALSE,TRUE,NA,NA,#,#,Yellow fever - Campaign and routine combined,Yellow fever,NA,NA,NA,NA,NA,NA,NA

vignettes/hep.Rmd

@@ -18,7 +18,8 @@ To calculate the HEP Billion, there are a series of functions made available thr
 the billionaiRe package:
 
 * `transform_hep_data()` to transform raw values into normalized values used within the calculations. For now, this is primarily calculating the total prevent numerators and denominators for campaign and routine data.
-* `calculate_hep_components()` to calculate component indicators (Prevent coverages), the HEP index, and levels for all components.
+* `calculate_hep_prevent_ind` to calculate the sub-indicator for 'prevent'.
+* `calculate_hep_components()` to calculate the HEP index, and levels for all components.
 * `calculate_hep_billion()` to calculate the change for the three HEP components (DNR, Prepare, and Prevent), their contribution to the Billion, and overall HEPI change and contribution.
 
 Run in sequence, these can calculate the entire HEP Billion, or they can be run separately
@@ -33,6 +34,7 @@ library(billionaiRe)
 hep_df %>%
   transform_hep_data() %>%
   calculate_hep_components() %>%
+  calculate_hep_prevent_ind() %>%
   calculate_hep_billion(end_year = 2023) %>%
   dplyr::filter(ind %in% c("prevent",
                            "espar",