vimc-7498: upload - able to create age specific calendar impact

DESCRIPTION

@@ -1,11 +1,11 @@
 Package: vimpact
 Title: Vaccine Impact Calculation
-Version: 0.1.3
+Version: 0.1.4
 Authors@R:
-    c(person(given = "Rich",
-             family = "FitzJohn",
+    c(person(given = "Xiang",
+             family = "Li",
              role = c("aut", "cre"),
-             email = "rich.fitzjohn@gmail.com"),
+             email = "x.li@imperial.ac.uk"),
       person("Imperial College of Science, Technology and Medicine",
              role = "cph"))
 Description: VIMC IMPACT CALCULATION PACKAGE. This package is mainly for the VIMC Science Team to investigate vaccination impact.
@@ -34,6 +34,6 @@ Suggests:
     RSQLite,
     withr
 Remotes: reside-ic/fakerbase
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 VignetteBuilder: knitr
 Config/testthat/edition: 3

NEWS.md

@@ -1,3 +1,7 @@
+# vimpact 0.1.4
+
+* Produce age specific calendar impact.
+
 # vimpact 0.1.3
 
 * Recognise new burden outcomes.

R/impact_central.R

@@ -1,32 +1,10 @@
-get_raw_impact_details <- function(con, meta1, burden_outcome, is_under5 = FALSE, countries_to_extract = NULL){
+get_raw_impact_details <- function(con, meta1, burden_outcome, is_under5 = FALSE, countries_to_extract = NULL, age_specific = FALSE){
   #verify parameters
   stopifnot(nrow(meta1) == 2L)
   stopifnot(burden_outcome %in% c("deaths", "cases", "dalys", "yll",
                                   "deaths_cwyx", "cases_cwyx", "dalys_cwyx", "yll_cwyx")) # _cwyx outcomes are MenA specific.
   stopifnot(is_under5 %in% c(TRUE, FALSE))
 
-  #preparation
-  # determine burden outcome, k will be used to determine burden outcome ids
-  if(burden_outcome == "deaths"){
-    k <- 1
-  } else if(burden_outcome == "cases"){
-    k <- 2
-  } else if(burden_outcome == "dalys"){
-    k <- 3
-  } else if(burden_outcome == "yll"){
-    k <- 4
-  } else if(burden_outcome == "deaths_cwyx"){
-    k <- 5
-  } else if(burden_outcome == "cases_cwyx"){
-    k <- 6
-  } else if(burden_outcome == "dalys_cwyx"){
-    k <- 7
-  } else if(burden_outcome == "yll_cwyx"){
-    k <- 8
-  } else {
-    stop("Can only take burden outcome as one of deaths, cases, dalys, yll, deaths_cwyx, cases_cwyx, dalys_cwyx, yll_cwyx")
-  }
-
   # determine whether a recipe is for routine or campaign vaccine delivery
   # routine or campaign matters for method2a in terms of the shape of burden estimates to extract
   # if routine, by year of birth
@@ -56,13 +34,22 @@ get_raw_impact_details <- function(con, meta1, burden_outcome, is_under5 = FALSE
 
   # set up db extraction sql queries
   if((meta1$method[1] == "method0") || (meta1$method[1] == "method2a" && any(j))){
-    sql <- paste("SELECT country, year AS time, sum(value) AS value",
-                 "FROM burden_estimate",
-                 "WHERE burden_estimate_set = %s",
-                 "AND burden_outcome IN %s",
-                 age_constrain,
-                 country_constrain,
-                 "GROUP BY country, year")
+    if(meta1$method[1] == "method0" & age_specific){
+      sql <- paste("SELECT country, year AS time, age, value",
+                   "FROM burden_estimate",
+                   "WHERE burden_estimate_set = %s",
+                   "AND burden_outcome IN %s",
+                   age_constrain,
+                   country_constrain)
+    } else {
+      sql <- paste("SELECT country, year AS time, sum(value) AS value",
+                   "FROM burden_estimate",
+                   "WHERE burden_estimate_set = %s",
+                   "AND burden_outcome IN %s",
+                   age_constrain,
+                   country_constrain,
+                   "GROUP BY country, year")
+    }
   } else if((meta1$method[1] == "method1") || (meta1$method[1] == "method2a" && any(i)) || (meta1$method[1] == "method2b")){
     sql <- paste("SELECT country, (year-age) AS time, sum(value)AS value",
                  "FROM burden_estimate",
@@ -75,18 +62,23 @@ get_raw_impact_details <- function(con, meta1, burden_outcome, is_under5 = FALSE
 
   # get burden outcome ids
   i <- meta1$meta_type == "focal"
-  ii <- unlist(strsplit(meta1$burden_outcome_id[i], ";"))
+  ss_id <- unlist(strsplit(meta1$burden_outcome_id[i], ";"))
+  ss_code <- unlist(strsplit(meta1$burden_outcome[i], ";"))
+  ii <- ss_id[ss_code == burden_outcome]
+
   j <- meta1$meta_type == "baseline"
-  jj <- unlist(strsplit(meta1$burden_outcome_id[j], ";"))
+  ss_id <- unlist(strsplit(meta1$burden_outcome_id[j], ";"))
+  ss_code <- unlist(strsplit(meta1$burden_outcome[j], ";"))
+  jj <- ss_id[ss_code == burden_outcome]
 
   # extract burden estimates
   d_baseline <- DBI::dbGetQuery(con, sprintf(sql,
                                              sql_in(meta1$burden_estimate_set[j], text_item = FALSE),
-                                             sql_in(jj[k], text_item = FALSE)))
+                                             sql_in(jj, text_item = FALSE)))
 
   d_focal <- DBI::dbGetQuery(con, sprintf(sql,
                                           sql_in(meta1$burden_estimate_set[i], text_item = FALSE),
-                                          sql_in(ii[k], text_item = FALSE)))
+                                          sql_in(ii, text_item = FALSE)))
   if(meta1$disease[1] == "HepB" && (nrow(d_focal) == 0L || nrow(d_baseline) == 0L)) {
     # when you are extracting data for HepB - IC and CDA models - for specific countries
     # you may end out with 0 rows for d_baseline or d_focal

tests/testthat/test-db-impact.R

@@ -180,6 +180,7 @@ test_that("impact calculation by year of vaccination country perspective", {
 })
 
 test_that("impact calculation by year of vaccination cohort perspective", {
+
   impact <- impact_by_year_of_vaccination_cohort_perspective(
     impact_test_data, fvp_test_data_15, 2000:2030)
   expect_equal(colnames(impact),
@@ -272,11 +273,13 @@ test_that("impact by calendar year: external and internal functions agree", {
 
   meta <- data_frame(
     scenario_type = c("default", "default"),
+    disease = c("YF", "YF"),
     vaccine_delivery = c("YF-campaign,YF-routine", "YF-routine"),
     meta_type = c("baseline", "focal"),
     index = c(1, 1),
     method = c("method0", "method0"),
     burden_estimate_set = c(1, 2),
+    burden_outcome = c("deaths", "deaths"),
     burden_outcome_id = c("1", "1"))
 
   vimc_impact <- get_raw_impact_details(con = con, meta,
@@ -332,14 +335,16 @@ test_that("impact by birth year: external and internal functions agree", {
 
   meta <- data_frame(
     scenario_type = c("default", "default"),
+    disease = c("YF", "YF"),
     vaccine_delivery = c("YF-campaign,YF-routine", "YF-routine"),
     meta_type = c("baseline", "focal"),
     index = c(1, 1),
     method = c("method1", "method1"),
     burden_estimate_set = c(1, 2),
+    burden_outcome = c("deaths", "deaths"),
     burden_outcome_id = c("1", "1"))
 
-  vimc_impact <- get_raw_impact_details(con = con, meta,
+    vimc_impact <- get_raw_impact_details(con = con, meta,
                                         burden_outcome = "deaths")
   public_impact <- impact_by_birth_year(impact_test_data_baseline,
                                            impact_test_data_focal)
@@ -426,6 +431,7 @@ test_that("impact activity type: functions agree - routine", {
     index = c(1, 1),
     method = c("method2a", "method2a"),
     burden_estimate_set = c(1, 2),
+    burden_outcome = c("deaths", "deaths"),
     burden_outcome_id = c("1", "1"))
 
   routine_raw_impact <- get_raw_impact_details(con = con, meta,
@@ -475,6 +481,7 @@ test_that("impact activity type: functions agree - campaign", {
     index = c(1, 1),
     method = c("method2a", "method2a"),
     burden_estimate_set = c(1, 2),
+    burden_outcome = c("deaths", "deaths"),
     burden_outcome_id = c("1", "1"))
 
   campaign_raw_impact <- get_raw_impact_details(con = con, meta,
@@ -541,6 +548,7 @@ test_that("impact birth cohort: internal and external functions agree", {
     index = c(1, 1),
     method = c("method2b", "method2b"),
     burden_estimate_set = c(1, 2),
+    burden_outcome = c("deaths", "deaths"),
     burden_outcome_id = c("1", "1"))
 
   vimc_raw_impact <- get_raw_impact_details(con = con, meta,