From 30b1891cf67e642856f61aaf1d25efc479ffc8a4 Mon Sep 17 00:00:00 2001 From: lucygf Date: Thu, 21 Nov 2024 17:00:50 +0000 Subject: [PATCH] updating figures --- inst/analysis/renv.lock | 37 +++++---- inst/analysis/renv/activate.R | 105 +++++++++++++++++++++--- inst/analysis/scripts/fig_averted.R | 11 ++- inst/analysis/scripts/fig_fullsummary.R | 6 +- inst/analysis/scripts/fig_utilities.R | 26 +++++- inst/analysis/scripts/fig_yll.R | 15 ++-- inst/analysis/scripts/param.R | 1 + 7 files changed, 153 insertions(+), 48 deletions(-) diff --git a/inst/analysis/renv.lock b/inst/analysis/renv.lock index 12577e6..ba2edb1 100644 --- a/inst/analysis/renv.lock +++ b/inst/analysis/renv.lock @@ -11,7 +11,7 @@ "Packages": { "MASS": { "Package": "MASS", - "Version": "7.3-58.2", + "Version": "7.3-60.2", "Source": "Repository", "Repository": "CRAN", "Requirements": [ @@ -22,15 +22,16 @@ "stats", "utils" ], - "Hash": "e02d1a0f6122fd3e634b25b433704344" + "Hash": "2f342c46163b0b54d7b64d1f798e2c78" }, "Matrix": { "Package": "Matrix", - "Version": "1.5-3", + "Version": "1.7-1", "Source": "Repository", "Repository": "CRAN", "Requirements": [ "R", + "grDevices", "graphics", "grid", "lattice", @@ -38,7 +39,7 @@ "stats", "utils" ], - "Hash": "4006dffe49958d2dd591c17e61e60591" + "Hash": "5122bb14d8736372411f955e1b16bc8a" }, "R6": { "Package": "R6", @@ -181,13 +182,13 @@ }, "dotCall64": { "Package": "dotCall64", - "Version": "1.1-1", + "Version": "1.2", "Source": "Repository", "Repository": "CRAN", "Requirements": [ "R" ], - "Hash": "80f374ef8500fcdc5d84a0345b837227" + "Hash": "7339da8bc231184ec506d7d144776b2a" }, "fansi": { "Package": "fansi", @@ -210,7 +211,7 @@ }, "fields": { "Package": "fields", - "Version": "16.2", + "Version": "16.3", "Source": "Repository", "Repository": "CRAN", "Requirements": [ @@ -220,7 +221,7 @@ "spam", "viridisLite" ], - "Hash": "dac9b7c0f2450644021e2097a5360c12" + "Hash": "2900d13ae2ee1dcf9f9cce088103667c" }, "generics": { "Package": "generics", @@ -452,7 +453,7 @@ }, "nlme": { "Package": "nlme", - "Version": "3.1-165", + "Version": "3.1-164", "Source": "Repository", "Repository": "CRAN", "Requirements": [ @@ -462,7 +463,7 @@ "stats", "utils" ], - "Hash": "2769a88be217841b1f33ed469675c3cc" + "Hash": "a623a2239e642806158bc4dc3f51565d" }, "oai": { "Package": "oai", @@ -480,9 +481,9 @@ }, "odin": { "Package": "odin", - "Version": "1.2.6", + "Version": "1.2.5", "Source": "Repository", - "Repository": "CRAN", + "Repository": "RSPM", "Requirements": [ "R6", "cinterpolate", @@ -493,7 +494,7 @@ "ring", "withr" ], - "Hash": "9f16ddb7672f4d2b4aa796cfb066b141" + "Hash": "28f2759ad947425cf50aa0069b5a2f57" }, "openssl": { "Package": "openssl", @@ -514,7 +515,7 @@ "RemoteUsername": "cmmid", "RemoteRepo": "paramix", "RemoteRef": "main", - "RemoteSha": "f67557c943c3111027d12d84d457d408431cde54", + "RemoteSha": "7d5e46f5afe942a94bd8486c5f1dc48756163261", "Requirements": [ "R", "data.table" @@ -579,13 +580,13 @@ }, "renv": { "Package": "renv", - "Version": "1.0.7", + "Version": "1.0.11", "Source": "Repository", "Repository": "CRAN", "Requirements": [ "utils" ], - "Hash": "397b7b2a265bc5a7a06852524dabae20" + "Hash": "47623f66b4e80b3b0587bc5d7b309888" }, "ring": { "Package": "ring", @@ -652,7 +653,7 @@ }, "spam": { "Package": "spam", - "Version": "2.10-0", + "Version": "2.11-0", "Source": "Repository", "Repository": "CRAN", "Requirements": [ @@ -662,7 +663,7 @@ "grid", "methods" ], - "Hash": "ffe1f9e95a4375530747b268f82b5086" + "Hash": "6581c0a0bb8594b85c8de869644174ac" }, "stringi": { "Package": "stringi", diff --git a/inst/analysis/renv/activate.R b/inst/analysis/renv/activate.R index d13f993..0eb5108 100644 --- a/inst/analysis/renv/activate.R +++ b/inst/analysis/renv/activate.R @@ -2,7 +2,7 @@ local({ # the requested version of renv - version <- "1.0.7" + version <- "1.0.11" attr(version, "sha") <- NULL # the project directory @@ -98,6 +98,66 @@ local({ unloadNamespace("renv") # load bootstrap tools + ansify <- function(text) { + if (renv_ansify_enabled()) + renv_ansify_enhanced(text) + else + renv_ansify_default(text) + } + + renv_ansify_enabled <- function() { + + override <- Sys.getenv("RENV_ANSIFY_ENABLED", unset = NA) + if (!is.na(override)) + return(as.logical(override)) + + pane <- Sys.getenv("RSTUDIO_CHILD_PROCESS_PANE", unset = NA) + if (identical(pane, "build")) + return(FALSE) + + testthat <- Sys.getenv("TESTTHAT", unset = "false") + if (tolower(testthat) %in% "true") + return(FALSE) + + iderun <- Sys.getenv("R_CLI_HAS_HYPERLINK_IDE_RUN", unset = "false") + if (tolower(iderun) %in% "false") + return(FALSE) + + TRUE + + } + + renv_ansify_default <- function(text) { + text + } + + renv_ansify_enhanced <- function(text) { + + # R help links + pattern <- "`\\?(renv::(?:[^`])+)`" + replacement <- "`\033]8;;ide:help:\\1\a?\\1\033]8;;\a`" + text <- gsub(pattern, replacement, text, perl = TRUE) + + # runnable code + pattern <- "`(renv::(?:[^`])+)`" + replacement <- "`\033]8;;ide:run:\\1\a\\1\033]8;;\a`" + text <- gsub(pattern, replacement, text, perl = TRUE) + + # return ansified text + text + + } + + renv_ansify_init <- function() { + + envir <- renv_envir_self() + if (renv_ansify_enabled()) + assign("ansify", renv_ansify_enhanced, envir = envir) + else + assign("ansify", renv_ansify_default, envir = envir) + + } + `%||%` <- function(x, y) { if (is.null(x)) y else x } @@ -142,7 +202,10 @@ local({ # compute common indent indent <- regexpr("[^[:space:]]", lines) common <- min(setdiff(indent, -1L)) - leave - paste(substring(lines, common), collapse = "\n") + text <- paste(substring(lines, common), collapse = "\n") + + # substitute in ANSI links for executable renv code + ansify(text) } @@ -305,8 +368,11 @@ local({ quiet = TRUE ) - if ("headers" %in% names(formals(utils::download.file))) - args$headers <- renv_bootstrap_download_custom_headers(url) + if ("headers" %in% names(formals(utils::download.file))) { + headers <- renv_bootstrap_download_custom_headers(url) + if (length(headers) && is.character(headers)) + args$headers <- headers + } do.call(utils::download.file, args) @@ -385,10 +451,21 @@ local({ for (type in types) { for (repos in renv_bootstrap_repos()) { + # build arguments for utils::available.packages() call + args <- list(type = type, repos = repos) + + # add custom headers if available -- note that + # utils::available.packages() will pass this to download.file() + if ("headers" %in% names(formals(utils::download.file))) { + headers <- renv_bootstrap_download_custom_headers(repos) + if (length(headers) && is.character(headers)) + args$headers <- headers + } + # retrieve package database db <- tryCatch( as.data.frame( - utils::available.packages(type = type, repos = repos), + do.call(utils::available.packages, args), stringsAsFactors = FALSE ), error = identity @@ -470,6 +547,14 @@ local({ } + renv_bootstrap_github_token <- function() { + for (envvar in c("GITHUB_TOKEN", "GITHUB_PAT", "GH_TOKEN")) { + envval <- Sys.getenv(envvar, unset = NA) + if (!is.na(envval)) + return(envval) + } + } + renv_bootstrap_download_github <- function(version) { enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") @@ -477,16 +562,16 @@ local({ return(FALSE) # prepare download options - pat <- Sys.getenv("GITHUB_PAT") - if (nzchar(Sys.which("curl")) && nzchar(pat)) { + token <- renv_bootstrap_github_token() + if (nzchar(Sys.which("curl")) && nzchar(token)) { fmt <- "--location --fail --header \"Authorization: token %s\"" - extra <- sprintf(fmt, pat) + extra <- sprintf(fmt, token) saved <- options("download.file.method", "download.file.extra") options(download.file.method = "curl", download.file.extra = extra) on.exit(do.call(base::options, saved), add = TRUE) - } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { + } else if (nzchar(Sys.which("wget")) && nzchar(token)) { fmt <- "--header=\"Authorization: token %s\"" - extra <- sprintf(fmt, pat) + extra <- sprintf(fmt, token) saved <- options("download.file.method", "download.file.extra") options(download.file.method = "wget", download.file.extra = extra) on.exit(do.call(base::options, saved), add = TRUE) diff --git a/inst/analysis/scripts/fig_averted.R b/inst/analysis/scripts/fig_averted.R index 8a42f34..499ce3b 100644 --- a/inst/analysis/scripts/fig_averted.R +++ b/inst/analysis/scripts/fig_averted.R @@ -27,11 +27,12 @@ int_dt <- ts_dt[intervention != "none", .( int_dt[, averted_death := i.deaths - deaths] int_dt$method <- factor(int_dt$method, levels=unique(int_dt$method)) +int_dt$intervention <- factor(int_dt$intervention, levels=unique(int_dt$intervention)) # in this model, deaths do not affect dynamics, so the method for aggregating # death parameter (`method` field) is irrelevant -p <- ggplot(int_dt) + aes( - x = method, y = 1000*averted_death/capita, fill = intervention +p <- ggplot(int_dt[!method=='mean_f']) + aes( + x = intervention, y = 1000*averted_death/capita, fill = method ) + facet_nested(place ~ pathogen, scale = "free_y", labeller = labeller( pathogen = pathogen_labels, place = iso_labels @@ -41,10 +42,8 @@ p <- ggplot(int_dt) + aes( element_text(size = 16), legend.position = "right", panel.spacing.x = unit(1.5, "line") ) + - scale_x_discrete("Aggregation assumption", labels = model_assumption_labels) + + scale_x_discrete("Vaccination age group", labels = intervention_labels) + scale_y_continuous("Deaths averted (per 1000)") + - scale_color_intervention( - breaks = rev(names(intervention_labels)) # order by ranking - ) + scale_color_model() ggsave(tail(.args, 1), p, width = 25, height = 14, units = "cm", bg = "white") diff --git a/inst/analysis/scripts/fig_fullsummary.R b/inst/analysis/scripts/fig_fullsummary.R index cdc66ea..013bc39 100644 --- a/inst/analysis/scripts/fig_fullsummary.R +++ b/inst/analysis/scripts/fig_fullsummary.R @@ -58,7 +58,7 @@ ifr_dt <- bound_pop_dt[, by = iso3 ] -ifr_p <- ggplot(ifr_dt[x <= 100]) + aes(x, y = value, color = method) + +ifr_p <- ggplot(ifr_dt[x <= 100 & !method=='mean_f']) + aes(x, y = value, color = method) + facet_iso(rows = vars(pathogen), labeller = labeller( iso3 = iso_labels, pathogen = pathogen_labels )) + @@ -99,8 +99,8 @@ inc_p <- ggplot(inc_dt[between(time, 0, 7*15)]) + aes( ) -summary_p <- pop_p + lex_p + ifr_p + inc_p + plot_layout( - ncol = 1, heights = c(1, 1, 2, 1) +summary_p <- pop_p + ifr_p + inc_p + plot_layout( + ncol = 1, heights = c(1, 2, 1) ) + plot_annotation(tag_levels = 'a', tag_prefix = '(', tag_suffix = ') ') diff --git a/inst/analysis/scripts/fig_utilities.R b/inst/analysis/scripts/fig_utilities.R index e1fab78..cde8f2a 100644 --- a/inst/analysis/scripts/fig_utilities.R +++ b/inst/analysis/scripts/fig_utilities.R @@ -150,17 +150,23 @@ trap <- function(.target) { pathogen_labels <- c(FLU = "Flu-like", SC2 = "COVID-like") model_assumption_labels <- c( - f_mid = "IFR(mid(Age))", f_mean = "IFR(E[Age])", mean_f = "E[IFR(Age)]", wm_f = "paramix", - f_val = "IFR(age)", full = "1 yr groups" + f_mid = "IFR(mid(Age))", f_mean = "IFR(E[Age])", mean_f = 'unused', wm_f = "paramix", + f_val = "IFR(age)", full = "High resolution" ) model_assumption_cols <- c("#d01c8b", "#f1b6da", "#b8e186", "#4dac26", "black", "grey25") |> setNames(names(model_assumption_labels)) distill_assumption_labels <- c( "Uniform\nacross age group", "Mean age", - "Prop. to\npop. density", "paramix", "unused", "1 yr groups" + "Prop. to\npop. density", "paramix", "unused", "High resolution" ) |> setNames(names(model_assumption_labels)) + model_cols <- c("#fed976", "#feb24c", "black", "#fd8d3c", "#f03b20", "#bd0026") |> + setNames(names(model_assumption_labels)) + + distill_cols <- c("#fed976", "#feb24c", "#fd8d3c", "#f03b20", "black", "#bd0026") |> + setNames(names(distill_assumption_labels)) + scale_color_intervention <- rejig( scale_color_manual, name = "Vaccinate ", breaks = names(intervention_labels), labels = intervention_labels, @@ -168,6 +174,20 @@ trap <- function(.target) { aesthetics = c("color", "fill") ) + scale_color_model <- rejig( + scale_color_manual, name = "Approach", + breaks = names(model_assumption_labels), labels = model_assumption_labels, + values = model_cols, + aesthetics = c("color", "fill") + ) + + scale_color_distill <- rejig( + scale_color_manual, name = "Approach", + breaks = names(distill_assumption_labels), labels = distill_assumption_labels, + values = distill_cols, + aesthetics = c("color", "fill") + ) + scale_x_simtime <- rejig( scale_x_continuous, name = "Simulation Time (weeks)", breaks = \(lims) seq(0, lims[2], by = 7), labels = \(b) b / 7, diff --git a/inst/analysis/scripts/fig_yll.R b/inst/analysis/scripts/fig_yll.R index ebd885c..3960f57 100644 --- a/inst/analysis/scripts/fig_yll.R +++ b/inst/analysis/scripts/fig_yll.R @@ -27,10 +27,12 @@ int_dt[, method := factor(method, levels = names(model_assumption_labels), order int_dt[sim_method == "full", method := factor(sim_method, levels = names(model_assumption_labels), ordered = TRUE) ] +int_dt$intervention <- factor(int_dt$intervention, levels=c('vax_young','vax_working','vax_older')) + # choosing to only show results when using the 'paramix' deaths -p <- ggplot(int_dt[sim_method == 'wm_f' | sim_method == "full"]) + aes( - x = method, group = intervention, - y = averted_yll/1000, fill = intervention, shape = sim_method +p <- ggplot(int_dt[sim_method == "wm_f" | sim_method == 'full']) + aes( + x = intervention, group = method, + y = averted_yll/1000, fill = method, shape = sim_method ) + facet_nested(place ~ pathogen, scale = "free_y", labeller = labeller( pathogen = pathogen_labels, place = iso_labels @@ -42,12 +44,9 @@ p <- ggplot(int_dt[sim_method == 'wm_f' | sim_method == "full"]) + aes( panel.spacing.x = unit(1.5, "line"), axis.text.x = element_text(angle = 0) ) + - scale_x_discrete("Disaggregation assumption", labels = distill_assumption_labels) + - # scale_y_log10("Years of life saved (thousands)") + + scale_x_discrete("Vaccination age group", labels = intervention_labels) + scale_y_continuous("Years of life saved (thousands)") + - scale_color_intervention( - breaks = rev(names(intervention_labels)) # order by ranking - ) + scale_shape_discrete("Simulation\nRate Assumption", labels = model_assumption_labels) + scale_color_distill() + scale_shape_discrete("Simulation\nRate Assumption", labels = model_assumption_labels) ggsave(tail(.args, 1), p, width = 25, height = 14, units = "cm", bg = "white") diff --git a/inst/analysis/scripts/param.R b/inst/analysis/scripts/param.R index 85a1fd4..8308417 100644 --- a/inst/analysis/scripts/param.R +++ b/inst/analysis/scripts/param.R @@ -66,3 +66,4 @@ save( model_agelimits, ifr_params, mapping_dt, cmij, sim_pars, cmijfull, file = tail(.args, 1) ) +