Skip to content

Separate plotting code from data prep #13

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
pratikunterwegs wants to merge 1 commit into
base: main
Choose a base branch
from
+347 −137
Draft

Separate plotting code from data prep #13

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
237 changes: 100 additions & 137 deletions R/plotting.R
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
# TODO: add documentations for these functions
#' Plotting theme for vimcheck
#'
#' @description
Expand All @@ -17,6 +16,8 @@
#'
#' @return A `ggplot2` theme that can be added to `ggplot2` plots or objects.
#'
#' @keywords plotting
#'
#' @export
theme_vimc <- function(x_text_angle = 45, y_text_angle = 0, ...) {
ggplot2::theme_bw() +
Expand Down Expand Up @@ -44,45 +45,36 @@ theme_vimc <- function(x_text_angle = 45, y_text_angle = 0, ...) {
#' Plotting functions for burden and impact diagnostics. This documentation
#' holds all plotting functions for now.
#'
#' @param d
#' @param data A `<data.frame>` that gives the comparison between VIMC-provided
#' and modeller-used demography values, in long-format. This is primarily
#' expected to be the output of `check_demography_alignment()` processed by
#' `prep_plot_demography()`.
#'
#' @param fig_number
#' @param fig_number The figure number.
#'
#' @return A `<ggplot>` object that can be printed to screen in the plot frame
#' or saved to an output device (i.e., saved as an image file).
#'
#' @examples
#' @keywords plotting
#'
#' @export
plot_compare_demography <- function(d, fig_number) {
num_countries <- length(unique(d$country))
names_melting_data <- c(
"scenario",
"age",
"year",
"expected",
"provided",
"difference"
)
names_melting_by <- c("scenario", "age", "year")

# TODO: use tidyr; BIG PICTURE: NO DATA PREP IN PLOTTING FUNCTIONS!
tot <- reshape2::melt(d[, names_melting_data], id.vars = names_melting_by)
dat <- tot %>%
dplyr::group_by(variable, scenario, year, age) %>%
dplyr::summarise(value = sum(value)) %>%
dplyr::mutate(millions = value / 1e6) %>%
dplyr::arrange(age)
plot_compare_demography <- function(data, fig_number) {
# NOTE: not implementing a lot of checks on inputs
checkmate::assert_tibble(data)
checkmate::assert_count(fig_number, positive = TRUE) # no zeros allowed

# TODO: use .data and .vars, import or namespace functions
g <- ggplot(data = dat, aes(x = year, y = millions, fill = age)) +
geom_bar(stat = "identity") +
g <- ggplot(
data = data,
aes(x = year, y = millions, fill = age)
) +
geom_col() +
facet_wrap(~ scenario + variable, ncol = 3) +
scale_fill_distiller(palette = "PuOr") +
geom_hline(yintercept = 0, color = 'red') +
geom_hline(yintercept = 0, colour = "red") +
labs(
x = "calendar year",
y = glue::glue("people (in millions"),
y = "people (in millions",
title = glue::glue(
"Fig. {fig_number}. Comparison between interpolated population and \\
cohort size ({num_countries} countries)."
Expand All @@ -95,23 +87,24 @@ plot_compare_demography <- function(d, fig_number) {

#' @name plotting
#'
#' @param burden
#' @param burden_age A `<tibble>` with the minimum column names
#' "age", "millions"
#'
#' @export
plot_age_patterns <- function(burden, fig_number) {
# TODO: REMOVE DATA PREP FROM PLOTTING FNS
d <- burden %>%
group_by(scenario, burden_outcome, age) %>%
summarise(millions = sum(value) / 1e6)
plot_age_patterns <- function(burden_age, fig_number) {
checkmate::assert_tibble(burden_age)
checkmate::assert_count(fig_number, positive = TRUE) # no zeros allowed

g <- ggplot(d, aes(x = age, y = millions)) +
geom_bar(stat = "identity") +
max_age <- max(burden_age$age) + 1

g <- ggplot(burden_age, aes(x = age, y = value_millions)) +
geom_col() +
facet_grid(
burden_outcome ~ scenario,
scales = "free_y",
labeller = labeller(scenario = label_wrap_gen(10))
) +
coord_cartesian(xlim = c(0, max(d$age) + 1)) +
coord_cartesian(xlim = c(NA_real_, max_age)) + # no lower limit, expect > 0
labs(
y = "people (in millions)",
title = glue::glue(
Expand All @@ -125,29 +118,16 @@ plot_age_patterns <- function(burden, fig_number) {

#' @name plotting
#'
#' @param year_max
#' @param burden_decades A `<tibble>` giving the burden by decade, up to
#' `year_max`. This should be the output of [prep_plot_burden_decades()].
#'
#' @export
plot_global_burden_decades <- function(burden, year_max, fig_number) {
# TODO: prefer moving these conditional checks elsewhere
# TODO: prefer moving data prep outside plotting fn
stopifnot(year_max %% 10 == 0)
d <- burden %>%
filter(year <= year_max) %>%
mutate(year2 = ifelse(year == year_max, year_max - 1, year)) %>%
mutate(decade = floor(year2 / 10) * 10) %>%
mutate(
decade_label = ifelse(
decade == year_max - 10,
paste0(decade, "-", decade + 10),
paste0(decade, "-", decade + 9)
)
) %>%
group_by(scenario, burden_outcome, decade_label) %>%
summarise(millions = sum(value) / 1e6)

g <- ggplot(d, aes(x = scenario, y = millions, fill = scenario)) +
geom_bar(stat = "identity") +
plot_global_burden_decades <- function(burden_decades, fig_number) {
g <- ggplot(
burden_decades,
aes(x = scenario, y = millions, fill = scenario)
) +
geom_col() +
facet_grid(burden_outcome ~ decade_label, scales = "free_y") +
labs(
y = "people (in millions)",
Expand All @@ -169,33 +149,38 @@ plot_global_burden_decades <- function(burden, year_max, fig_number) {

#' @name plotting
#'
#' @param d
#'
#' @param outcome
#' @param burden_data This is expected to be a `<tibble>` from a
#' nested-`<tibble>` constructed using [prep_plot_global_burden()].
#'
#' @export
plot_global_burden <- function(d, outcome, fig_number) {
data_ <- dplyr::filter(
d,
.data$burden_outcome == outcome
plot_global_burden <- function(burden_data, outcome_name, fig_number) {
checkmate::assert_tibble(burden_data)
checkmate::assert_subset(
outcome_name,
burden_outcome_names
)
checkmate::assert_count(fig_number)

scenarios_per_gridcol <- 10

g <- ggplot(
data,
aes(x = year, y = millions, fill = age)
burden_data,
aes(year, millions, fill = age)
) +
geom_bar(stat = "identity", aes(fill = age)) +
geom_col() +
facet_grid(
~scenario,
scales = "free_y",
labeller = labeller(scenario = label_wrap_gen(10)) # TODO: avoid magic numbers
labeller = labeller(
scenario = label_wrap_gen(scenarios_per_gridcol)
)
) +
scale_fill_distiller(palette = "Spectral") +
labs(
x = "calendar year",
y = paste(outcomes_list[i], "(in millions)"), # TODO: where is outcomes_list!?
y = glue::glue("{outcome_name} (in millions)"),
title = glue::glue(
"Fig. {fig_number}: Global trends of disease burden ({outcome})."
"Fig. {fig_number}: Global trends of disease burden ({outcome_name})."
)
) +
theme_vimc(x_text_angle = 90)
Expand All @@ -205,43 +190,43 @@ plot_global_burden <- function(d, outcome, fig_number) {

#' @name plotting
#'
#' @param cov
#' @param coverage_set A `<tibble>` that is the output of
#' [prep_plot_coverage_set()].
#'
#' @export
plot_coverage_set <- function(cov, figure_number) {
# TODO: remove data prep
no_vacc <- expand_grid(
year = unique(cov$year),
country = unique(cov$country)
) %>%
mutate(
coverage = 0,
delivery = "none",
scenario_description = "No vaccination"
)
plot_coverage_set <- function(coverage_set, figure_number) {
checkmate::assert_tibble(coverage_set)
checkmate::assert_count(figure_number)

dodge_width <- 0.9
col_opacity <- 0.7
scenarios_per_gridcol <- 10

cov1 <- cov %>%
mutate(delivery = paste(vaccine, activity_type, sep = "-")) %>%
select(scenario_description, delivery, country, year, coverage) %>%
bind_rows(no_vacc)
disease_name <- unique(coverage_set$disease) # expecting a single value

g <- ggplot(cov1, aes(x = year, y = coverage, fill = delivery)) +
geom_bar(
stat = "identity",
position = position_dodge(width = 0.9),
alpha = 0.7
g <- ggplot(
coverage_set,
aes(x = year, y = coverage, fill = delivery)
) +
geom_col(
# TODO: check if dodging is really needed
position = position_dodge(dodge_width),
alpha = col_opacity
) +
facet_grid(
"country ~ scenario_description",
rows = vars(country),
cols = vars(scenario_description),
scales = "free_y",
labeller = labeller(scenario_description = label_wrap_gen(10))
labeller = labeller(
scenario_description = label_wrap_gen(scenarios_per_gridcol)
)
) +
scale_x_continuous(breaks = pretty(unique(cov1$year))) +
scale_x_continuous() +
labs(
x = "calendar year",
y = "Proportion of target population",
title = glue::glue(
"Fig. {figure_number}: Coverage sets for {cov$disease[1]}"
"Fig. {figure_number}: Coverage sets for {disease_name}"
)
) +
theme_vimc(90)
Expand All @@ -251,63 +236,41 @@ plot_coverage_set <- function(cov, figure_number) {

#' @name plotting
#'
#' @param fvp
#'
#' @param year_min
#'
#' @param year_max
#' @param fvp_data A `<tibble>` of estimates of fully-vaccinated persons (FVPs) per
#' scenario, with scenarios as factors in order of the number of adjusted-FVPs.
#' Expected to be the output of [prep_plot_fvp()].
#'
#' @export
plot_fvp <- function(fvp, year_min, year_max, figure_number) {
# TODO: PREFER TO REMOVE DATA PREP CODE
no_vacc <- expand_grid(
year = unique(fvp$year),
country = unique(fvp$country)
) %>%
mutate(fvps_adjusted = 0, scenario_description = "No vaccination")

fvp_final <- bind_rows(fvp, no_vacc) %>%
filter(year >= year_min & year <= year_max) %>%
mutate(scenario = as.factor(scenario_description))
plot_fvp <- function(fvp_data, figure_number) {
checkmate::assert_tibble(fvp_data)
checkmate::assert_count(figure_number)

fvp_final$scenario <- relevel(fvp_final$scenario, "No vaccination")
fvp_final$scenario <- gsub(tolower(fvp$disease[1L]), "", fvp_final$scenario)
fvp_final$scenario <- gsub("-", " ", fvp_final$scenario)
scenarios_per_gridcol <- 10
scale_millions <- 1e-6
disease_name <- unique(fvp_data$disease)

scenario_order <- c(names(sort(tapply(
fvp_final$fvps_adjusted,
fvp_final$scenario,
sum,
na.rm = TRUE
))))

fvp_final$scenario <- forcats::fct_relevel(fvp_final$scenario, scenario_order)

fvp_agg <-
fvp_final %>%
dplyr::group_by(year, scenario, disease) %>%
dplyr::summarise(fvp = sum(fvps_adjusted, na.rm = TRUE))

# TODO: prefer to use a scale transform rather than touching data
g <- ggplot(fvp_agg, aes(x = year, y = fvp / 1e6, fill = scenario)) +
geom_bar(
stat = "identity",
colour = "midnightblue",
g <- ggplot(
fvp_data,
aes(x = year, y = fvp, fill = scenario)
) +
geom_col(
fill = "midnightblue"
) +
facet_grid(
~scenario,
scales = "free_y",
labeller = labeller(scenario = label_wrap_gen(10))
labeller = labeller(scenario = label_wrap_gen(scenarios_per_gridcol))
) +
scale_x_continuous() +
scale_y_continuous(
labels = scales::label_number(scale = scale_millions)
) +
scale_x_continuous(breaks = pretty(unique(fvp_agg$year))) +
ylab(paste("FVP (in millions)")) +
labs(
x = "calendar year",
y = "FVP (in millions)",
title = glue::glue(
"Fig. {figure_number}: Fully Vaccinated Persons at global level by \\
scenario for {fvp$disease[1L]}"
scenario for {disease_name}"
)
) +
theme_vimc(90, legend.position = "none")
Expand Down
Loading
Loading