Vimc 9230

.covrignore

@@ -0,0 +1,4 @@
+# This does the API call to packit - not 
+# easy to test without mocking all the network.
+
+R/packit.R

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: stoner
 Title: Support for Building VIMC Montagu Touchstones, using Dettl
-Version: 0.1.19
+Version: 0.1.20
 Authors@R:
     c(person("Wes", "Hinsley",role = c("aut", "cre", "cst", "dnc", "elg", "itr", "sng", "ard"),
            email = "w.hinsley@imperial.ac.uk"),
@@ -20,13 +20,16 @@ Imports:
     cli,
     DBI,
     data.table,
+    httr2,
     jsonlite,
     lgr,
     dplyr,
     magrittr,
     prettyunits,
     readr,
     rlang,
+    shiny,
+    shinyjs,
     testthat,
     utils,
     withr
@@ -35,6 +38,7 @@ RoxygenNote: 7.3.3
 Roxygen: list(markdown = TRUE)
 Suggests:
     knitr,
+    mockery,
     rcmdcheck,
     rmarkdown,
     RPostgres

NAMESPACE

@@ -1,5 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
+export(fetch_packit)
+export(stochastic_explorer)
 export(stone_dump)
 export(stone_extract)
 export(stone_load)
@@ -16,17 +18,22 @@ export(stoner_calculate_dalys)
 export(stoner_dalys_for_db)
 import(arrow)
 import(dplyr)
+import(httr2)
 import(readr)
 importFrom(arrow,write_parquet)
 importFrom(data.table,as.data.table)
 importFrom(data.table,rbindlist)
+importFrom(grDevices,recordPlot)
 importFrom(graphics,lines)
+importFrom(graphics,par)
 importFrom(magrittr,"%>%")
 importFrom(rlang,":=")
+importFrom(shiny,runApp)
 importFrom(stats,median)
 importFrom(stats,quantile)
 importFrom(testthat,expect_equal)
 importFrom(testthat,expect_true)
+importFrom(tools,file_ext)
 importFrom(utils,capture.output)
 importFrom(utils,read.csv)
 importFrom(utils,write.csv)

NEWS.md

@@ -1,8 +1,13 @@
-# Stoner 0.1.19
+# Stoner 0.1.20
 
-* add stoner_stochastic_central to create central parquet from standardised stochastics.
+* Allow missing yll for processing older stochastics
+
+# Changes in 0.1.19
+
+* Add stoner_stochastic_central to create central parquet from standardised stochastics.
 
 # Changes in 0.1.18
+
 * Add stoner_stochastic_standardise for converting (drop)box stochastics to standard form
 * Add stoner_stochastic_graphs for quick plotting of stochastics.
 

R/packit.R

@@ -0,0 +1,77 @@
+##' Download a file from a packit, for example an artefact containing
+##' central burden estimates, which we could then plot on top of
+##' stochastics. But more generally, we can use this for fetching any
+##' file from packet (ie, from the Montagu Reporting Portal).
+##'
+##' @export
+##' @title Fetch packet from a packit server
+##' @import httr2
+##' @importFrom tools file_ext
+##' @param packet_id The id of the packet containing the artefact.
+##' @param filename The filename of the file within the packet.
+##' @param server By default, the URL to the packit API on Montagu,
+##' but this can be set to other packit API's if we want.
+##' @returns The filename of the temporary file which has been downloaded.
+fetch_packit <- function(packet_id, filename,
+  server = "https://montagu.vaccineimpact.org/packit/api/") {
+
+  # First we have to create a client, and a flow...
+
+  client <- httr2::oauth_client(
+    id = "orderly",
+    token_url = sprintf("%s/deviceAuth/token", server),
+    name = "orderly"
+  )
+
+  # You will be asked to type a code at this point...
+
+  flow <- httr2::oauth_flow_device(
+    client = client,
+    auth_url = sprintf("%s/deviceAuth", server),
+    pkce = FALSE,
+    scope = NULL,
+    open_browser = FALSE,
+    auth_params = list(),
+    token_params = list()
+  )
+
+  # Now we have a flow$access_token we can use, to get
+  # a one-time token to download the file.
+
+  req <- httr2::request(sprintf("%s/packets/%s/files/token", server, packet_id))
+  req <- req |>
+    httr2::req_headers("Accept" = "application/json",
+                       "Content-Type" = "application/json",
+                       "Authorization" = paste("Bearer", flow$access_token)) |>
+         httr2::req_method("POST") |>
+         httr2::req_body_json(list(paths = list(filename)))
+
+  x <- httr2::req_perform(req)
+  ott <- httr2::resp_body_json(x)$id
+
+  # This is the URL to the file we want, including the token.
+
+  url <- sprintf("%s/packets/%s/file?path=%s&token=%s&filename=%s&inline=false",
+                 server, packet_id, filename, ott, filename)
+
+  req <- httr2::request(url)
+  req <- req |>
+    httr2::req_headers("Authorization" = paste("Bearer", flow$access_token))
+
+
+  # And finally, we download the file in chunks.
+
+  out <- tempfile(fileext = paste0(".", tools::file_ext(filename)))
+  outfile <- file(out, open = "wb")
+  con <- httr2::req_perform_connection(req, blocking = TRUE)
+  while (!httr2::resp_stream_is_complete(con)) {
+    chunk <- httr2::resp_stream_raw(con, kb = 32)
+    if (length(chunk) == 0) break
+    writeBin(chunk, outfile)
+  }
+  close(outfile)
+  out
+}
+
+
+

R/stochastic_files.R

@@ -31,14 +31,30 @@
 ##' these to the simpler names. Processing Rubella stochastic files without
 ##' this set to TRUE will fail - so while we should always do this, keeping
 ##' the parameter makes it more clear in the code what we're doing and why.
+##' @param hepb2019_fix In 2019 (and 2017), HepB deaths and cases were subdivided into
+##' number of different causes. This flag combines those into the single
+##' appropriate burden outcome.
+##' @param hib2019_fix In 2019 (and 2017), Hib deaths and cases were subdivided into
+##' number of different causes. This flag combines those into the single
+##' appropriate burden outcome.
 ##' @param missing_run_id_fix Some groups in the past have omitted run_id
 ##' from the files, but included them in the filenames. This fix inserts
 ##' that into the files if the index parameter indicates we have 200 runs to
 ##' process.
-
+##' @param allow_missing_yll yll was introduced in 2023? This flag allows
+##' it to be missing for processing older stochastics.
+##' @param allow_missing_dalys Some early groups did not provide dalys; this
+##' flag allows dalys to be skipped.
+##' @param allow_missing_indexes In some early runs, different groups
+##' provided different numbers of files for each scenario, because some
+##' countries did not implement particular coverage campaigns. This
+##' flag needs to be TRUE for those groups, but the default is FALSE,
+##' since it's rare, and we generally want errors for missing files.
 stone_stochastic_standardise <- function(
     group, in_path, out_path, scenarios, files, index = 1,
-    rubella_fix = TRUE, missing_run_id_fix = TRUE) {
+    rubella_fix = TRUE, hepb2019_fix = TRUE, hib2019_fix = TRUE,
+    missing_run_id_fix = TRUE, allow_missing_yll = TRUE,
+    allow_missing_dalys = TRUE, allow_missing_indexes = FALSE) {
 
   dir.create(out_path, showWarnings = FALSE, recursive = TRUE)
   if ((length(files) == 1) && (grepl(":scenario", files))) {
@@ -47,36 +63,115 @@ stone_stochastic_standardise <- function(
       files[j] <- gsub(":scenario", scenarios[j], files[j])
     }
   }
-
   for (i in seq_along(scenarios)) {
     message(scenarios[i])
     all_data <- as.data.frame(data.table::rbindlist(lapply(index, function(j) {
       cat("\r", j)
       file <- gsub(":index", j, files[i])
-      d <- read.csv(file.path(in_path, file))
+      filepath <- file.path(in_path, file)
+      if (!file.exists(filepath) && (allow_missing_indexes)) {
+        return(NULL)
+      }
+      d <- read.csv(filepath)
       d$country_name <- NULL
 
-      # Fixes needed to standardise Rubella
+      # Various accumulated fixes for e/non-standard stochastics
+      # The flags are all true by default - Stoner will break untidily
+      # if the flags are turned off, but the problem occurs.
+
       if (rubella_fix) {
-        names(d)[names(d) == "rubella_deaths_congenital"] <- "deaths"
-        names(d)[names(d) == "rubella_cases_congenital"] <- "cases"
-        d$rubella_infections <- NULL
+        if ("rubella_deaths_congenital" %in% names(d)) {
+          message("Converting rubella_deaths_congenital to deaths")
+          names(d)[names(d) == "rubella_deaths_congenital"] <- "deaths"
+        }
+        if ("rubella_cases_congenital" %in% names(d)) {
+          message("Converting rubella_cases_congenital to cases")
+          names(d)[names(d) == "rubella_cases_congenital"] <- "cases"
+        }
+        if ("rubella_infections" %in% names(d)) {
+          message("Ignoring rubella_infections")
+          d$rubella_infections <- NULL
+        }
+      }
+
+      if (hepb2019_fix) {
+        if (!"cases" %in% names(d)) {
+          d$cases <- 0
+          cda_cases <- c("hepb_cases_acute_severe", "hepb_cases_dec_cirrh" ,
+                         "hepb_cases_hcc")
+          li_cases <- c("hepb_cases_acute_symp", "hepb_cases_fulminant",
+                        "hepb_cases_chronic",
+                        "hepb_chronic_symptomatic_in_acute_phase")
+          ic_cases <- c("hepb_cases_acute_severe", "hepb_cases_comp_cirrh",
+                        "hepb_cases_hcc_no_cirrh")
+          for (i in unique(c(cda_cases, li_cases, ic_cases))) {
+            if (i %in% names(d)) {
+              message(sprintf("Including %s in cases", i))
+              d$cases <- d$cases + d[[i]]
+              d[[i]] <- NULL
+            }
+          }
+        }
+
+        if (!"deaths" %in% names(d)) {
+          d$deaths <- 0
+          cda_deaths <- c("hepb_deaths_acute", "hepb_deaths_dec_cirrh",
+                          "hepb_deaths_hcc")
+          li_deaths <- c("hepb_deaths_acute", "hepb_deaths_total_cirrh",
+                         "hepb_deaths_hcc")
+          ic_deaths <- c("hepb_deaths_acute", "hepb_deaths_comp_cirrh",
+                         "hepb_deaths_dec_cirrh", "hepb_deaths_hcc")
+
+          for (i in unique(c(cda_deaths, li_deaths, ic_deaths))) {
+            if (i %in% names(d)) {
+              message(sprintf("Including %s in deaths", i))
+              d$deaths <- d$deaths + d[[i]]
+              d[[i]] <- NULL
+            }
+          }
+        }
       }
 
-      # Detect where run_id is missing, but in filenames
+      if (hib2019_fix) {
+        if (("cases_pneumo" %in% names(d)) &&
+            ("cases_men" %in% names(d))) {
+
+          message("cases = cases_men + cases_pneumo")
+          d$cases <- d$cases_pneumo + d$cases_men
+          d$cases_pneumo <- NULL
+          d$cases_men <- NULL
+        }
+        if (("deaths_pneumo" %in% names(d)) &&
+            ("deaths_men" %in% names(d))) {
+          message("deaths = deaths_men + deaths_pneumo")
+          d$deaths <- d$deaths_pneumo + d$deaths_men
+          d$deaths_pneumo <- NULL
+          d$deaths_men <- NULL
+        }
+      }
 
       if (missing_run_id_fix) {
         if ((!"run_id" %in% names(d)) && (length(index) == 200)) d$run_id <- j
       }
 
+
       # Round to integer, as per guidance. (Not using as.integer, as that
       # has limits on how large numbers can be, so we are just truncating
       # digits here)
 
-      d$dalys <- round(d$dalys)
+      if (("dalys" %in% names(d)) || (!allow_missing_dalys)) {
+        d$dalys <- round(d$dalys)
+      } else {
+        message("Dalys missing. (Ignored)")
+      }
+
       d$deaths <- round(d$deaths)
       d$cases <- round(d$cases)
-      d$yll <- round(d$yll)
+      if (("yll" %in% names(d)) || (!allow_missing_yll)) {
+        d$yll <- round(d$yll)
+      } else {
+        message("yll missing. (Ignored)")
+      }
       d$cohort_size <- round(d$cohort_size)
 
       d