From 0d6355a0fb09e12179d8d8222ff07133a858d520 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Thu, 14 Nov 2024 15:44:52 +0000 Subject: [PATCH 01/10] add individual trajectories plot --- R/biokinetics.R | 2 +- R/plot.R | 55 +++++++++++ .../_snaps/plots/individualtrajectories.svg | 96 +++++++++++++++++++ tests/testthat/test-plots.R | 16 ++++ 4 files changed, 168 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/_snaps/plots/individualtrajectories.svg diff --git a/R/biokinetics.R b/R/biokinetics.R index d087f02..cf584b2 100644 --- a/R/biokinetics.R +++ b/R/biokinetics.R @@ -554,7 +554,7 @@ biokinetics <- R6::R6Class( }, #' @description Simulate individual trajectories from the model. This is #' computationally expensive and may take a while to run if n_draws is large. - #' @return A data.table. If summarise = TRUE columns are calendar_date, titre_type, me, lo, hi, time_shift. + #' @return A data.table. If summarise = TRUE columns are calendar_day, titre_type, me, lo, hi, time_shift. #' If summarise = FALSE, columns are pid, draw, time_since_last_exp, mu, titre_type, exposure_day, calendar_day, time_shift #' and a column for each covariate in the regression model. See the data vignette for details: #' \code{vignette("data", package = "epikinetics")}. diff --git a/R/plot.R b/R/plot.R index cb49ca8..a5366ab 100644 --- a/R/plot.R +++ b/R/plot.R @@ -144,6 +144,61 @@ plot.biokinetics_population_trajectories <- function(x, ..., plot } +#' Plot method for "biokinetics_individual_trajectories" class +#' +#' @param x An object of class "biokinetics_individual_trajectories". These are +#' generated by running biokinetics$simulate_individual_trajectories(). See +#' \href{../../epikinetics/html/biokinetics.html#method-biokinetics-simulate_individaul_trajectories}{\code{biokinetics$simulate_individual_trajectories()}} +#' @param \dots Further arguments passed to the method. +#' @export +plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, + min_date = NULL, + max_date = NULL) { + + # Declare variables to suppress notes when compiling package + # https://github.com/Rdatatable/data.table/issues/850#issuecomment-259466153 + calendar_day <- value <- me <- mu <- titre_type <- lo <- hi <- day <- pid <- NULL + if (is.null(min_date)) { + min_date <- min(x$calendar_day) + } + if (is.null(max_date)) { + max_date <- max(x$calendar_day) + } + if (attr(x, "summarised")) { + plot <- ggplot(x) + + geom_line(aes(x = calendar_day, y = me, group = titre_type, colour = titre_type)) + + geom_ribbon(aes(x = calendar_day, + ymin = lo, + ymax = hi, + group = titre_type), alpha = 0.5) + } else { + plot <- ggplot(x) + + geom_line(aes(x = calendar_day, y = mu, + colour = titre_type, group = pid), alpha = 0.1, linewidth = 0.1) + } + if (!is.null(data)) { + validate_required_cols(data, c("day", "value")) + plot <- plot + + geom_point(data = data, + aes(x = day, + y = value), size = 0.5, alpha = 0.5) + } + plot + + labs(x = "Date", + y = expression(paste("Titre (IC"[50], ")"))) + + geom_smooth( + aes(x = calendar_day, + y = me, + fill = titre_type, + colour = titre_type, + group = titre_type), + alpha = 0.5, span = 0.2) + + scale_x_date(date_labels = "%b %Y", + limits = c(min_date, max_date)) + + guides(colour = guide_legend(title = "Titre type"), + fill = "none") +} + facet_formula <- function(covariates) { paste("~", paste(c("titre_type", covariates), collapse = "+")) } diff --git a/tests/testthat/_snaps/plots/individualtrajectories.svg b/tests/testthat/_snaps/plots/individualtrajectories.svg new file mode 100644 index 0000000..2b3a4c2 --- /dev/null +++ b/tests/testthat/_snaps/plots/individualtrajectories.svg @@ -0,0 +1,96 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +300 +600 +900 + + + + + + + + +Jan 2021 +Jul 2021 +Jan 2022 +Jul 2022 +Date +Titre (IC +50 +) + +Titre type + + + + + + + + + + + + +Alpha +Ancestral +Delta +individualtrajectories + + diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index 1c9fbe0..f5afaee 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -134,3 +134,19 @@ test_that("Can plot population trajectories with log scale input data", { expect_equal(length(plot$scales$scales), 0) vdiffr::expect_doppelganger("populationtrajectories_logscale", plot) }) + +test_that("Can plot summarised individual trajectories", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"),) + mod$fit() + trajectories <- mod$simulate_individual_trajectories(n_draws = 250, + summarise = TRUE) + # because these fits are so bad there are some v high upper values, so just + # create these articially + trajectories[, hi := me + 100] + vdiffr::expect_doppelganger("individualtrajectories", plot(trajectories)) +}) From fcdbe23bde6c3b8b5f9b25dec0bf4d923fc38528 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Fri, 15 Nov 2024 15:08:27 +0000 Subject: [PATCH 02/10] stationary points plot --- R/biokinetics.R | 8 +- R/plot.R | 54 +- .../_snaps/plots/stationarypoints.svg | 2038 +++++++++++++++++ .../plots/stationarypointsnocovariates.svg | 1060 +++++++++ .../plots/stationarypointswithlimit.svg | 1061 +++++++++ tests/testthat/test-plots.R | 43 + 6 files changed, 4262 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/_snaps/plots/stationarypoints.svg create mode 100644 tests/testthat/_snaps/plots/stationarypointsnocovariates.svg create mode 100644 tests/testthat/_snaps/plots/stationarypointswithlimit.svg diff --git a/R/biokinetics.R b/R/biokinetics.R index cf584b2..6bedc89 100644 --- a/R/biokinetics.R +++ b/R/biokinetics.R @@ -408,6 +408,7 @@ biokinetics <- R6::R6Class( logger::log_info("Recovering covariate names") dt_out <- private$recover_covariate_names(dt_out) } + class(dt_out) <- append("biokinetics_population_parameters", class(dt_out)) dt_out }, #' @description Extract fitted individual parameters @@ -445,6 +446,7 @@ biokinetics <- R6::R6Class( logger::log_info("Recovering covariate names") dt_out <- private$recover_covariate_names(dt_out) } + class(dt_out) <- append("biokinetics_individual_parameters", class(dt_out)) dt_out }, #' @description Process the model results into a data table of titre values over time. @@ -541,7 +543,7 @@ biokinetics <- R6::R6Class( } logger::log_info("Calculating medians") - dt_peak_switch[ + dt_out <- dt_peak_switch[ , rel_drop := mu_s / mu_p, by = c(private$all_formula_vars, "titre_type")][ , .( @@ -551,6 +553,10 @@ biokinetics <- R6::R6Class( mu_p_me = quantile(mu_p, 0.5), mu_s_me = quantile(mu_s, 0.5)), by = c(private$all_formula_vars, "titre_type")] + class(dt_out) <- append("biokinetics_population_stationary_points", class(dt_out)) + setattr(dt_out, "covariates", private$all_formula_vars) + setattr(dt_out, "scale", private$scale) + dt_out }, #' @description Simulate individual trajectories from the model. This is #' computationally expensive and may take a while to run if n_draws is large. diff --git a/R/plot.R b/R/plot.R index a5366ab..817d4f1 100644 --- a/R/plot.R +++ b/R/plot.R @@ -199,6 +199,46 @@ plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, fill = "none") } +plot.biokinetics_population_stationary_points <- function(x, ..., upper_detection_limit = NULL) { + covariates <- attr(x, "covariates") + plot <- ggplot(data = x, + aes(x = mu_p, y = mu_s, colour = titre_type)) + + geom_density_2d(aes(group = eval(parse(text = shape_formula(c("titre_type", covariates)))))) + + geom_point(alpha = 0.05, size = 0.2) + + if (length(covariates) > 0) { + plot <- plot + + geom_point(aes(x = mu_p_me, + y = mu_s_me, + shape = eval(parse(text = shape_formula(covariates)))), + colour = "black") + + guides(shape = guide_legend(title = shape_legend_title(covariates), + override.aes = list(alpha = 1, size = 1))) + } + else { + plot <- plot + geom_point(aes(x = mu_p_me, y = mu_s_me), colour = "black") + } + + if (attr(x, "scale") == "natural") { + plot <- plot + + scale_y_continuous(trans = "log2") + + scale_x_continuous(trans = "log2") + } + + if (!is.null(upper_detection_limit)) { + plot <- plot + + geom_vline(xintercept = upper_detection_limit, linetype = "twodash", colour = "gray30") + + geom_hline(yintercept = upper_detection_limit, linetype = "twodash", colour = "gray30") + } + + plot + + geom_path(aes(x = mu_p_me, y = mu_s_me, group = titre_type), colour = "black") + + labs(x = expression(paste("Population-level titre value at peak (IC"[50], ")")), + y = expression(paste("Population-level titre value at set-point (IC"[50], ")"))) + + guides(colour = guide_legend(override.aes = list(alpha = 1, size = 1))) + +} + facet_formula <- function(covariates) { paste("~", paste(c("titre_type", covariates), collapse = "+")) } @@ -227,4 +267,16 @@ add_limits <- function(plot, upper_censoring_limit, lower_censoring_limit) { size = 3) } plot -} \ No newline at end of file +} + +shape_formula <- function(covariates) { + paste0("interaction(", paste(covariates, collapse = ","), ")") +} + +shape_legend_title <- function(covariates) { + if (length(covariates) == 1) { + return(covariates[[1]]) + } else { + return(shape_formula(covariates)) + } +} diff --git a/tests/testthat/_snaps/plots/stationarypoints.svg b/tests/testthat/_snaps/plots/stationarypoints.svg new file mode 100644 index 0000000..38cb437 --- /dev/null +++ b/tests/testthat/_snaps/plots/stationarypoints.svg @@ -0,0 +1,2038 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +16 +128 +1024 + + + + + + + +128 +8192 +524288 +33554432 +Population-level titre value at peak (IC +50 +) +Population-level titre value at set-point (IC +50 +) + +titre_type + + + + + + + + + +Alpha +Ancestral +Delta + +infection_history + + + + +Infection naive +Previously infected (Pre-Omicron) +stationarypoints + + diff --git a/tests/testthat/_snaps/plots/stationarypointsnocovariates.svg b/tests/testthat/_snaps/plots/stationarypointsnocovariates.svg new file mode 100644 index 0000000..a00f412 --- /dev/null +++ b/tests/testthat/_snaps/plots/stationarypointsnocovariates.svg @@ -0,0 +1,1060 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +16 +128 +1024 + + + + + + +32 +512 +8192 +Population-level titre value at peak (IC +50 +) +Population-level titre value at set-point (IC +50 +) + +titre_type + + + + + + + + + +Alpha +Ancestral +Delta +stationarypointsnocovariates + + diff --git a/tests/testthat/_snaps/plots/stationarypointswithlimit.svg b/tests/testthat/_snaps/plots/stationarypointswithlimit.svg new file mode 100644 index 0000000..255dbc4 --- /dev/null +++ b/tests/testthat/_snaps/plots/stationarypointswithlimit.svg @@ -0,0 +1,1061 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +16 +128 +1024 + + + + + + +32 +512 +8192 +Population-level titre value at peak (IC +50 +) +Population-level titre value at set-point (IC +50 +) + +titre_type + + + + + + + + + +Alpha +Ancestral +Delta +stationarypointswithlimit + + diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index f5afaee..f64ea45 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -65,6 +65,10 @@ mock_model <- function(name, package) { list(sample = function(x, ...) readRDS(test_path("testdata", "testdraws.rds"))) } +mock_model_no_covariates <- function(name, package) { + list(sample = function(x, ...) readRDS(test_path("testdata", "testdraws_nocovariates.rds"))) +} + mock_model_multiple_covariates <- function(name, package) { list(sample = function(x, ...) readRDS(test_path("testdata", "testdraws_multiplecovariates.rds"))) } @@ -150,3 +154,42 @@ test_that("Can plot summarised individual trajectories", { trajectories[, hi := me + 100] vdiffr::expect_doppelganger("individualtrajectories", plot(trajectories)) }) + +test_that("Can plot stationary points", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"), + covariate_formula = ~0 + infection_history) + mod$fit() + res <- mod$population_stationary_points() + vdiffr::expect_doppelganger("stationarypoints", plot(res)) +}) + +test_that("Can plot stationary points with no covariates", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model_no_covariates, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"),) + mod$fit() + res <- mod$population_stationary_points() + vdiffr::expect_doppelganger("stationarypointsnocovariates", plot(res)) +}) + + +test_that("Can plot stationary points with upper limit", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model_no_covariates, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"),) + mod$fit() + res <- mod$population_stationary_points() + vdiffr::expect_doppelganger("stationarypointswithlimit", + plot(res, upper_detection_limit = 2560)) +}) From 78a1727e09d6753d86ba79f1852b88a606c69333 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Fri, 15 Nov 2024 16:23:23 +0000 Subject: [PATCH 03/10] unsummarised individuals --- R/biokinetics.R | 15 +- R/plot.R | 35 +- .../plots/individualtrajectories-unsum.svg | 1071 +++++++++++++++++ tests/testthat/test-plots.R | 16 + 4 files changed, 1118 insertions(+), 19 deletions(-) create mode 100644 tests/testthat/_snaps/plots/individualtrajectories-unsum.svg diff --git a/R/biokinetics.R b/R/biokinetics.R index 6bedc89..91487fb 100644 --- a/R/biokinetics.R +++ b/R/biokinetics.R @@ -408,7 +408,6 @@ biokinetics <- R6::R6Class( logger::log_info("Recovering covariate names") dt_out <- private$recover_covariate_names(dt_out) } - class(dt_out) <- append("biokinetics_population_parameters", class(dt_out)) dt_out }, #' @description Extract fitted individual parameters @@ -446,7 +445,7 @@ biokinetics <- R6::R6Class( logger::log_info("Recovering covariate names") dt_out <- private$recover_covariate_names(dt_out) } - class(dt_out) <- append("biokinetics_individual_parameters", class(dt_out)) + dt_out }, #' @description Process the model results into a data table of titre values over time. @@ -533,17 +532,17 @@ biokinetics <- R6::R6Class( by = by] logger::log_info("Recovering covariate names") - dt_peak_switch <- private$recover_covariate_names(dt_peak_switch) + dt_out <- private$recover_covariate_names(dt_peak_switch) if (private$scale == "natural") { - dt_peak_switch <- convert_log2_scale_inverse( - dt_peak_switch, + dt_out <- convert_log2_scale_inverse( + dt_out, vars_to_transform = c("mu_0", "mu_p", "mu_s"), smallest_value = private$smallest_value) } logger::log_info("Calculating medians") - dt_out <- dt_peak_switch[ + dt_out <- dt_out[ , rel_drop := mu_s / mu_p, by = c(private$all_formula_vars, "titre_type")][ , .( @@ -554,8 +553,8 @@ biokinetics <- R6::R6Class( mu_s_me = quantile(mu_s, 0.5)), by = c(private$all_formula_vars, "titre_type")] class(dt_out) <- append("biokinetics_population_stationary_points", class(dt_out)) - setattr(dt_out, "covariates", private$all_formula_vars) - setattr(dt_out, "scale", private$scale) + attr(dt_out, "covariates") <- private$all_formula_vars + attr(dt_out, "scale") <- private$scale dt_out }, #' @description Simulate individual trajectories from the model. This is diff --git a/R/plot.R b/R/plot.R index 817d4f1..1830a55 100644 --- a/R/plot.R +++ b/R/plot.R @@ -150,10 +150,15 @@ plot.biokinetics_population_trajectories <- function(x, ..., #' generated by running biokinetics$simulate_individual_trajectories(). See #' \href{../../epikinetics/html/biokinetics.html#method-biokinetics-simulate_individaul_trajectories}{\code{biokinetics$simulate_individual_trajectories()}} #' @param \dots Further arguments passed to the method. +#' @oaram min_date Optional minimum date +#' @param max_date Optional maximum date +#' @param pid Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used +#' if x has been generated with summarise=FALSE. #' @export plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, min_date = NULL, - max_date = NULL) { + max_date = NULL, + pid = NULL) { # Declare variables to suppress notes when compiling package # https://github.com/Rdatatable/data.table/issues/850#issuecomment-259466153 @@ -165,16 +170,31 @@ plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, max_date <- max(x$calendar_day) } if (attr(x, "summarised")) { + if (!is.null(pid)) { + stop(paste("Trajectories for individuals cannot be extracted if the results are already summarised.", + "Generate un-summarised trajectories with biokinetics$simulate_individual_trajectories(summarise=FALSE)")) + } plot <- ggplot(x) + geom_line(aes(x = calendar_day, y = me, group = titre_type, colour = titre_type)) + geom_ribbon(aes(x = calendar_day, ymin = lo, ymax = hi, - group = titre_type), alpha = 0.5) + group = titre_type), alpha = 0.5) + + geom_smooth( + aes(x = calendar_day, + y = me, + fill = titre_type, + colour = titre_type, + group = titre_type), + alpha = 0.5, span = 0.2) } else { + x <- x[ + !is.nan(mu), .(ind_mu_sum = mean(mu)), + by = c("calendar_day", "pid", "titre_type")] plot <- ggplot(x) + - geom_line(aes(x = calendar_day, y = mu, - colour = titre_type, group = pid), alpha = 0.1, linewidth = 0.1) + geom_line(aes(x = calendar_day, y = ind_mu_sum, + colour = titre_type, group = interaction(titre_type, pid)), + alpha = 0.5, linewidth = 0.1) } if (!is.null(data)) { validate_required_cols(data, c("day", "value")) @@ -186,13 +206,6 @@ plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, plot + labs(x = "Date", y = expression(paste("Titre (IC"[50], ")"))) + - geom_smooth( - aes(x = calendar_day, - y = me, - fill = titre_type, - colour = titre_type, - group = titre_type), - alpha = 0.5, span = 0.2) + scale_x_date(date_labels = "%b %Y", limits = c(min_date, max_date)) + guides(colour = guide_legend(title = "Titre type"), diff --git a/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg b/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg new file mode 100644 index 0000000..a4572c0 --- /dev/null +++ b/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg @@ -0,0 +1,1071 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +500 +1000 +1500 + + + + + + + + +Jan 2021 +Jul 2021 +Jan 2022 +Jul 2022 +Date +Titre (IC +50 +) + +Titre type + + + + + + +Alpha +Ancestral +Delta +individualtrajectories-unsum + + diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index f64ea45..1635992 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -155,6 +155,22 @@ test_that("Can plot summarised individual trajectories", { vdiffr::expect_doppelganger("individualtrajectories", plot(trajectories)) }) +test_that("Can plot un-summarised individual trajectories", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"),) + mod$fit() + trajectories <- mod$simulate_individual_trajectories(n_draws = 250, + summarise = FALSE) + # because these fits are so bad there are some v high upper values, so just + # trunbcate these + trajectories[, mu:= ifelse(mu > 2000, 2000, mu)] + vdiffr::expect_doppelganger("individualtrajectories-unsum", plot(trajectories)) +}) + test_that("Can plot stationary points", { # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good From 9f190cf1959009be796189c216673597efb62fc8 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Mon, 18 Nov 2024 11:52:23 +0000 Subject: [PATCH 04/10] add number of points to plot --- R/plot.R | 26 +- .../plots/individualtrajectories-unsum.svg | 2489 ++++++++++------- .../_snaps/plots/individualtrajectories.svg | 92 +- tests/testthat/test-plots.R | 10 +- 4 files changed, 1512 insertions(+), 1105 deletions(-) diff --git a/R/plot.R b/R/plot.R index 1830a55..4d9f6fb 100644 --- a/R/plot.R +++ b/R/plot.R @@ -179,22 +179,30 @@ plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, geom_ribbon(aes(x = calendar_day, ymin = lo, ymax = hi, - group = titre_type), alpha = 0.5) + - geom_smooth( - aes(x = calendar_day, - y = me, - fill = titre_type, - colour = titre_type, - group = titre_type), - alpha = 0.5, span = 0.2) + group = titre_type), alpha = 0.5) } else { x <- x[ !is.nan(mu), .(ind_mu_sum = mean(mu)), by = c("calendar_day", "pid", "titre_type")] + count <- x[, .(count = data.table::uniqueN(pid)), by = .(calendar_day)] plot <- ggplot(x) + geom_line(aes(x = calendar_day, y = ind_mu_sum, colour = titre_type, group = interaction(titre_type, pid)), - alpha = 0.5, linewidth = 0.1) + alpha = 0.5, linewidth = 0.1) + + geom_smooth( + aes(x = calendar_day, + y = ind_mu_sum, + fill = titre_type, + colour = titre_type, + group = titre_type), + alpha = 0.5, span = 0.2) + + scale_y_continuous(sec.axis = sec_axis(~., name = "Number of data points")) + + geom_bar(data = count, aes(x = calendar_day, y = count), + stat = "identity", alpha = 0.6) + + theme(axis.ticks.y.right = element_line(alpha = 0.6), + axis.text.y.right = element_text(alpha = 0.6), + axis.title.y.right = element_text(alpha = 0.6) + ) } if (!is.null(data)) { validate_required_cols(data, c("day", "value")) diff --git a/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg b/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg index a4572c0..19b452f 100644 --- a/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg +++ b/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg @@ -21,1051 +21,1464 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -500 -1000 -1500 - - - - - - - - -Jan 2021 -Jul 2021 -Jan 2022 -Jul 2022 -Date +0 +500 +1000 +1500 + + + + + + + + +0 +500 +1000 +1500 + + + + + +Jan 2021 +Apr 2021 +Jul 2021 +Oct 2021 +Jan 2022 +Date Titre (IC 50 ) - -Titre type - - - - - - -Alpha -Ancestral -Delta +Number of individuals in study + +Titre type + + + + + + + + + + + + +Alpha +Ancestral +Delta individualtrajectories-unsum diff --git a/tests/testthat/_snaps/plots/individualtrajectories.svg b/tests/testthat/_snaps/plots/individualtrajectories.svg index 2b3a4c2..e334b59 100644 --- a/tests/testthat/_snaps/plots/individualtrajectories.svg +++ b/tests/testthat/_snaps/plots/individualtrajectories.svg @@ -18,59 +18,49 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + -0 -300 -600 -900 - - - - - - - - -Jan 2021 -Jul 2021 -Jan 2022 -Jul 2022 -Date +0 +500 +1000 +1500 + + + + + + + + + +Jan 2021 +Apr 2021 +Jul 2021 +Oct 2021 +Jan 2022 +Date Titre (IC 50 ) @@ -78,19 +68,13 @@ Titre type - - - - - - Alpha Ancestral Delta -individualtrajectories +individualtrajectories diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index 1635992..92d4aa9 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -151,8 +151,9 @@ test_that("Can plot summarised individual trajectories", { summarise = TRUE) # because these fits are so bad there are some v high upper values, so just # create these articially - trajectories[, hi := me + 100] - vdiffr::expect_doppelganger("individualtrajectories", plot(trajectories)) + trajectories[, hi:= ifelse(hi > 2000, me + 100, hi)] + vdiffr::expect_doppelganger("individualtrajectories", plot(trajectories, + max_date = lubridate::ymd("2022/01/01"))) }) test_that("Can plot un-summarised individual trajectories", { @@ -166,9 +167,10 @@ test_that("Can plot un-summarised individual trajectories", { trajectories <- mod$simulate_individual_trajectories(n_draws = 250, summarise = FALSE) # because these fits are so bad there are some v high upper values, so just - # trunbcate these + # truncate these trajectories[, mu:= ifelse(mu > 2000, 2000, mu)] - vdiffr::expect_doppelganger("individualtrajectories-unsum", plot(trajectories)) + vdiffr::expect_doppelganger("individualtrajectories-unsum", plot(trajectories, + max_date = lubridate::ymd("2022/01/01"))) }) test_that("Can plot stationary points", { From 3949d2714943c69feca402512e98c8ce79ecf740 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Mon, 18 Nov 2024 17:23:19 +0000 Subject: [PATCH 05/10] more plots --- R/plot.R | 97 +- ...individualtrajectories-pids-data-alpha.svg | 226 ++ .../individualtrajectories-pids-data.svg | 560 ++++ .../plots/individualtrajectories-pids.svg | 1024 ++++++ .../plots/individualtrajectories-unsum.svg | 2867 ++++++++--------- .../_snaps/plots/individualtrajectories.svg | 46 +- tests/testthat/test-plots.R | 66 +- 7 files changed, 3376 insertions(+), 1510 deletions(-) create mode 100644 tests/testthat/_snaps/plots/individualtrajectories-pids-data-alpha.svg create mode 100644 tests/testthat/_snaps/plots/individualtrajectories-pids-data.svg create mode 100644 tests/testthat/_snaps/plots/individualtrajectories-pids.svg diff --git a/R/plot.R b/R/plot.R index 4d9f6fb..24542e6 100644 --- a/R/plot.R +++ b/R/plot.R @@ -150,73 +150,92 @@ plot.biokinetics_population_trajectories <- function(x, ..., #' generated by running biokinetics$simulate_individual_trajectories(). See #' \href{../../epikinetics/html/biokinetics.html#method-biokinetics-simulate_individaul_trajectories}{\code{biokinetics$simulate_individual_trajectories()}} #' @param \dots Further arguments passed to the method. -#' @oaram min_date Optional minimum date -#' @param max_date Optional maximum date +#' @oaram min_day Optional minimum date +#' @param max_day Optional maximum date #' @param pid Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used #' if x has been generated with summarise=FALSE. +#' @param titre_types Optional vector of titre types to include. #' @export plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, - min_date = NULL, - max_date = NULL, - pid = NULL) { + min_day = NULL, + max_day = NULL, + pids = NULL, + titre_types = NULL) { # Declare variables to suppress notes when compiling package # https://github.com/Rdatatable/data.table/issues/850#issuecomment-259466153 calendar_day <- value <- me <- mu <- titre_type <- lo <- hi <- day <- pid <- NULL - if (is.null(min_date)) { - min_date <- min(x$calendar_day) + if (is.null(min_day)) { + min_day <- min(x$calendar_day) } - if (is.null(max_date)) { - max_date <- max(x$calendar_day) + if (is.null(max_day)) { + max_day <- max(x$calendar_day) + } + if (!is.null(titre_types)) { + x <- x[titre_type %in% titre_types,] } if (attr(x, "summarised")) { - if (!is.null(pid)) { - stop(paste("Trajectories for individuals cannot be extracted if the results are already summarised.", + if (!is.null(pids)) { + stop(paste("Trajectories for specific individuals cannot be extracted if the results are already summarised.", "Generate un-summarised trajectories with biokinetics$simulate_individual_trajectories(summarise=FALSE)")) } - plot <- ggplot(x) + + plot <- ggplot(x[calendar_day >= min_day & calendar_day <= max_day,]) + geom_line(aes(x = calendar_day, y = me, group = titre_type, colour = titre_type)) + geom_ribbon(aes(x = calendar_day, ymin = lo, ymax = hi, + fill = titre_type, group = titre_type), alpha = 0.5) } else { - x <- x[ - !is.nan(mu), .(ind_mu_sum = mean(mu)), - by = c("calendar_day", "pid", "titre_type")] - count <- x[, .(count = data.table::uniqueN(pid)), by = .(calendar_day)] - plot <- ggplot(x) + - geom_line(aes(x = calendar_day, y = ind_mu_sum, - colour = titre_type, group = interaction(titre_type, pid)), - alpha = 0.5, linewidth = 0.1) + - geom_smooth( - aes(x = calendar_day, - y = ind_mu_sum, - fill = titre_type, - colour = titre_type, - group = titre_type), - alpha = 0.5, span = 0.2) + - scale_y_continuous(sec.axis = sec_axis(~., name = "Number of data points")) + - geom_bar(data = count, aes(x = calendar_day, y = count), - stat = "identity", alpha = 0.6) + - theme(axis.ticks.y.right = element_line(alpha = 0.6), - axis.text.y.right = element_text(alpha = 0.6), - axis.title.y.right = element_text(alpha = 0.6) - ) + if (is.null(pids)) { + x <- x[ + !is.nan(mu), .(ind_mu_sum = mean(mu)), + by = c("calendar_day", "pid", "titre_type")] + count <- x[, .(count = data.table::uniqueN(pid)), by = .(calendar_day)] + plot <- ggplot(x[calendar_day >= min_day & calendar_day <= max_day,]) + + geom_line(aes(x = calendar_day, y = ind_mu_sum, + colour = titre_type, group = interaction(titre_type, pid)), + alpha = 0.5, linewidth = 0.1) + + geom_smooth( + aes(x = calendar_day, + y = ind_mu_sum, + fill = titre_type, + colour = titre_type, + group = titre_type), + alpha = 0.5, span = 0.2, show.legend = FALSE) + + scale_y_continuous(sec.axis = sec_axis(~., name = "Number of data points")) + + geom_bar(data = count[calendar_day >= min_day & calendar_day <= max_day,], + aes(x = calendar_day, y = count), + stat = "identity", alpha = 0.6) + } else { + x <- x[pid %in% pids & !is.nan(mu),] + plot <- ggplot(x[calendar_day >= min_day & calendar_day <= max_day,]) + + geom_line(aes(x = calendar_day, y = mu, + colour = titre_type, group = interaction(titre_type, pid, draw)), + linewidth = 0.1, alpha = 0.5 + ) + } } if (!is.null(data)) { validate_required_cols(data, c("day", "value")) + if (!is.null(titre_types)) { + data <- data[titre_type %in% titre_types,] + } + if (!is.null(pids)) { + validate_required_cols(data, "pid") + data <- data[pid %in% pids,] + } plot <- plot + - geom_point(data = data, + geom_point(data = data[day >= min_day & day <= max_day,], aes(x = day, - y = value), size = 0.5, alpha = 0.5) + y = value, + colour = titre_type), size = 0.5) } plot + labs(x = "Date", y = expression(paste("Titre (IC"[50], ")"))) + - scale_x_date(date_labels = "%b %Y", - limits = c(min_date, max_date)) + - guides(colour = guide_legend(title = "Titre type"), + scale_x_date(date_labels = "%b %Y") + + guides(colour = guide_legend(title = "Titre type", override.aes = list(alpha = 1, linewidth = 1)), fill = "none") } diff --git a/tests/testthat/_snaps/plots/individualtrajectories-pids-data-alpha.svg b/tests/testthat/_snaps/plots/individualtrajectories-pids-data-alpha.svg new file mode 100644 index 0000000..c1d2a05 --- /dev/null +++ b/tests/testthat/_snaps/plots/individualtrajectories-pids-data-alpha.svg @@ -0,0 +1,226 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +500 +1000 +1500 +2000 + + + + + + + + + +Apr 2021 +May 2021 +Jun 2021 +Jul 2021 +Date +Titre (IC +50 +) + +Titre type + + + +Alpha +individualtrajectories-pids-data-alpha + + diff --git a/tests/testthat/_snaps/plots/individualtrajectories-pids-data.svg b/tests/testthat/_snaps/plots/individualtrajectories-pids-data.svg new file mode 100644 index 0000000..f3cfb08 --- /dev/null +++ b/tests/testthat/_snaps/plots/individualtrajectories-pids-data.svg @@ -0,0 +1,560 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +500 +1000 +1500 +2000 + + + + + + + + + +Apr 2021 +May 2021 +Jun 2021 +Jul 2021 +Date +Titre (IC +50 +) + +Titre type + + + + + + + + + +Alpha +Ancestral +Delta +individualtrajectories-pids-data + + diff --git a/tests/testthat/_snaps/plots/individualtrajectories-pids.svg b/tests/testthat/_snaps/plots/individualtrajectories-pids.svg new file mode 100644 index 0000000..05974f5 --- /dev/null +++ b/tests/testthat/_snaps/plots/individualtrajectories-pids.svg @@ -0,0 +1,1024 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +500 +1000 +1500 +2000 + + + + + + + +Apr 2021 +Jul 2021 +Date +Titre (IC +50 +) + +Titre type + + + + + + +Alpha +Ancestral +Delta +individualtrajectories-pids + + diff --git a/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg b/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg index 19b452f..28e7e3f 100644 --- a/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg +++ b/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg @@ -21,1414 +21,1401 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 @@ -1439,46 +1426,40 @@ - - - - -0 -500 -1000 -1500 - - - - - -Jan 2021 -Apr 2021 -Jul 2021 -Oct 2021 -Jan 2022 -Date + + + + +0 +500 +1000 +1500 + + + + + +Jan 2021 +Apr 2021 +Jul 2021 +Oct 2021 +Jan 2022 +Date Titre (IC 50 ) -Number of individuals in study - -Titre type - - - - - - - - - - - - -Alpha -Ancestral -Delta +Number of data points + +Titre type + + + + + + +Alpha +Ancestral +Delta individualtrajectories-unsum diff --git a/tests/testthat/_snaps/plots/individualtrajectories.svg b/tests/testthat/_snaps/plots/individualtrajectories.svg index e334b59..2e6f0f5 100644 --- a/tests/testthat/_snaps/plots/individualtrajectories.svg +++ b/tests/testthat/_snaps/plots/individualtrajectories.svg @@ -27,29 +27,29 @@ - - - - - - - - - - - - + + + + + + + + + + + + -0 -500 -1000 -1500 - - - - +0 +500 +1000 +1500 + + + + @@ -67,11 +67,11 @@ Titre type - + - + - + Alpha Ancestral Delta diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index 92d4aa9..f0a9829 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -17,7 +17,7 @@ test_that("Can plot prior prediction with data points", { test_that("Can plot prior predictions from model", { data <- data.table::fread(system.file("delta_full.rds", package = "epikinetics")) priors <- biokinetics_priors(4.1, 11, 65, 0.2, -0.01, 0.01, - 2.0, 2.0, 3.0, 0.01, 0.01, 0.001) + 2.0, 2.0, 3.0, 0.01, 0.01, 0.001) mod <- biokinetics$new(priors = priors, data = data) @@ -151,9 +151,9 @@ test_that("Can plot summarised individual trajectories", { summarise = TRUE) # because these fits are so bad there are some v high upper values, so just # create these articially - trajectories[, hi:= ifelse(hi > 2000, me + 100, hi)] + trajectories[, hi := ifelse(hi > 2000, me + 100, hi)] vdiffr::expect_doppelganger("individualtrajectories", plot(trajectories, - max_date = lubridate::ymd("2022/01/01"))) + max_day = lubridate::ymd("2022/01/01"))) }) test_that("Can plot un-summarised individual trajectories", { @@ -168,9 +168,65 @@ test_that("Can plot un-summarised individual trajectories", { summarise = FALSE) # because these fits are so bad there are some v high upper values, so just # truncate these - trajectories[, mu:= ifelse(mu > 2000, 2000, mu)] + trajectories[, mu := ifelse(mu > 2000, 2000, mu)] vdiffr::expect_doppelganger("individualtrajectories-unsum", plot(trajectories, - max_date = lubridate::ymd("2022/01/01"))) + max_day = lubridate::ymd("2022/01/01"))) +}) + +test_that("Can plot individual trajectories for specific pids", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"),) + mod$fit() + trajectories <- mod$simulate_individual_trajectories(n_draws = 250, + summarise = FALSE) + # because these fits are so bad there are some v high upper values, so just + # truncate these + trajectories[, mu := ifelse(mu > 2000, 2000, mu)] + vdiffr::expect_doppelganger("individualtrajectories-pids", plot(trajectories, + pids = c("1", "2"), + max_day = lubridate::ymd("2022/01/01"))) +}) + +test_that("Can plot individual trajectories for specific pids with data", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"),) + mod$fit() + trajectories <- mod$simulate_individual_trajectories(n_draws = 250, + summarise = FALSE) + # because these fits are so bad there are some v high upper values, so just + # truncate these + trajectories[, mu := ifelse(mu > 2000, 2000, mu)] + vdiffr::expect_doppelganger("individualtrajectories-pids-data", plot(trajectories, + pids = "1", + data = data.table::fread(system.file("delta_full.rds", package = "epikinetics")), + max_day = lubridate::ymd("2022/01/01"))) +}) + +test_that("Can plot individual trajectories for specific pids with data and titre type", { + # note that this is using a pre-fitted model with very few iterations, so the + # fits won't look very good + local_mocked_bindings( + stan_package_model = mock_model, .package = "instantiate" + ) + mod <- biokinetics$new(file_path = system.file("delta_full.rds", package = "epikinetics"),) + mod$fit() + trajectories <- mod$simulate_individual_trajectories(n_draws = 250, + summarise = FALSE) + # because these fits are so bad there are some v high upper values, so just + # truncate these + trajectories[, mu := ifelse(mu > 2000, 2000, mu)] + vdiffr::expect_doppelganger("individualtrajectories-pids-data-alpha", plot(trajectories, + pids = "1", + data = data.table::fread(system.file("delta_full.rds", package = "epikinetics")), + titre_types = "Alpha")) }) test_that("Can plot stationary points", { From c34ecbe2eb7c00e62761a1d35ce0e87962f17619 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Tue, 19 Nov 2024 13:28:11 +0000 Subject: [PATCH 06/10] Update docs, skip some plot tests if R < 4.1 --- NAMESPACE | 8 +++++ R/epikinetics-package.R | 4 ++- R/plot.R | 17 +++++++-- man/biokinetics.Rd | 2 +- ...lot.biokinetics_individual_trajectories.Rd | 35 +++++++++++++++++++ ...iokinetics_population_stationary_points.Rd | 20 +++++++++++ tests/testthat/test-plots.R | 3 ++ 7 files changed, 85 insertions(+), 4 deletions(-) create mode 100644 man/plot.biokinetics_individual_trajectories.Rd create mode 100644 man/plot.biokinetics_population_stationary_points.Rd diff --git a/NAMESPACE b/NAMESPACE index c32925d..8d14a98 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +S3method(plot,biokinetics_individual_trajectories) +S3method(plot,biokinetics_population_stationary_points) S3method(plot,biokinetics_population_trajectories) S3method(plot,biokinetics_priors) export(add_exposure_data) @@ -23,11 +25,17 @@ importFrom(ggplot2,annotate) importFrom(ggplot2,facet_wrap) importFrom(ggplot2,geom_hline) importFrom(ggplot2,geom_line) +importFrom(ggplot2,geom_path) importFrom(ggplot2,geom_point) importFrom(ggplot2,geom_ribbon) importFrom(ggplot2,geom_smooth) +importFrom(ggplot2,geom_vline) importFrom(ggplot2,ggplot) importFrom(ggplot2,guide_legend) importFrom(ggplot2,guides) +importFrom(ggplot2,labs) +importFrom(ggplot2,scale_x_continuous) +importFrom(ggplot2,scale_x_date) importFrom(ggplot2,scale_y_continuous) +importFrom(ggplot2,sec_axis) useDynLib(epikinetics, .registration = TRUE) diff --git a/R/epikinetics-package.R b/R/epikinetics-package.R index bbe2adc..4b8a1ae 100644 --- a/R/epikinetics-package.R +++ b/R/epikinetics-package.R @@ -11,7 +11,9 @@ #' @importFrom data.table .NGRP #' @importFrom data.table .SD #' @importFrom data.table data.table -#' @importFrom ggplot2 aes facet_wrap geom_point geom_ribbon geom_line geom_smooth ggplot guides guide_legend scale_y_continuous geom_hline annotate +#' @importFrom ggplot2 aes annotate facet_wrap geom_point geom_ribbon geom_line geom_smooth +#' geom_vline geom_hline geom_path labs ggplot guides guide_legend scale_y_continuous +#' scale_x_continuous scale_x_date sec_axis #' @useDynLib epikinetics, .registration = TRUE ## usethis namespace: end diff --git a/R/plot.R b/R/plot.R index 24542e6..4caec7a 100644 --- a/R/plot.R +++ b/R/plot.R @@ -150,7 +150,7 @@ plot.biokinetics_population_trajectories <- function(x, ..., #' generated by running biokinetics$simulate_individual_trajectories(). See #' \href{../../epikinetics/html/biokinetics.html#method-biokinetics-simulate_individaul_trajectories}{\code{biokinetics$simulate_individual_trajectories()}} #' @param \dots Further arguments passed to the method. -#' @oaram min_day Optional minimum date +#' @param min_day Optional minimum date #' @param max_day Optional maximum date #' @param pid Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used #' if x has been generated with summarise=FALSE. @@ -164,7 +164,9 @@ plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, # Declare variables to suppress notes when compiling package # https://github.com/Rdatatable/data.table/issues/850#issuecomment-259466153 - calendar_day <- value <- me <- mu <- titre_type <- lo <- hi <- day <- pid <- NULL + calendar_day <- value <- me <- mu <- titre_type <- day <- pid <- NULL + ind_mu_sum <- lo <- hi <- NULL + if (is.null(min_day)) { min_day <- min(x$calendar_day) } @@ -239,7 +241,18 @@ plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, fill = "none") } +#' Plot method for "biokinetics_population_stationary_points" class +#' +#' @param x An object of class "biokinetics_population_stationary_points". These are +#' generated by running biokinetics$population_stationary_points(). See +#' \href{../../epikinetics/html/biokinetics.html#method-biokinetics-population_stationary_points}{\code{biokinetics$population_stationary_points()}} +#' @param \dots Further arguments passed to the method. +#' @param upper_detection_limit Numeric. Optional upper detection limit. Will be plotted as a dotted line. +#' @export plot.biokinetics_population_stationary_points <- function(x, ..., upper_detection_limit = NULL) { + # Declare variables to suppress notes when compiling package + # https://github.com/Rdatatable/data.table/issues/850#issuecomment-259466153 + mu_p <- mu_s <- mu_p_me <- mu_s_me <- titre_type <- NULL covariates <- attr(x, "covariates") plot <- ggplot(data = x, aes(x = mu_p, y = mu_s, colour = titre_type)) + diff --git a/man/biokinetics.Rd b/man/biokinetics.Rd index 7d6a65c..b037694 100644 --- a/man/biokinetics.Rd +++ b/man/biokinetics.Rd @@ -309,7 +309,7 @@ Default TRUE.} \if{html}{\out{}} } \subsection{Returns}{ -A data.table. If summarise = TRUE columns are calendar_date, titre_type, me, lo, hi, time_shift. +A data.table. If summarise = TRUE columns are calendar_day, titre_type, me, lo, hi, time_shift. If summarise = FALSE, columns are pid, draw, time_since_last_exp, mu, titre_type, exposure_day, calendar_day, time_shift and a column for each covariate in the regression model. See the data vignette for details: \code{vignette("data", package = "epikinetics")}. diff --git a/man/plot.biokinetics_individual_trajectories.Rd b/man/plot.biokinetics_individual_trajectories.Rd new file mode 100644 index 0000000..2e188bf --- /dev/null +++ b/man/plot.biokinetics_individual_trajectories.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{plot.biokinetics_individual_trajectories} +\alias{plot.biokinetics_individual_trajectories} +\title{Plot method for "biokinetics_individual_trajectories" class} +\usage{ +\method{plot}{biokinetics_individual_trajectories}( + x, + ..., + data = NULL, + min_day = NULL, + max_day = NULL, + pids = NULL, + titre_types = NULL +) +} +\arguments{ +\item{x}{An object of class "biokinetics_individual_trajectories". These are +generated by running biokinetics$simulate_individual_trajectories(). See +\href{../../epikinetics/html/biokinetics.html#method-biokinetics-simulate_individaul_trajectories}{\code{biokinetics$simulate_individual_trajectories()}}} + +\item{\dots}{Further arguments passed to the method.} + +\item{min_day}{Optional minimum date} + +\item{max_day}{Optional maximum date} + +\item{titre_types}{Optional vector of titre types to include.} + +\item{pid}{Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used +if x has been generated with summarise=FALSE.} +} +\description{ +Plot method for "biokinetics_individual_trajectories" class +} diff --git a/man/plot.biokinetics_population_stationary_points.Rd b/man/plot.biokinetics_population_stationary_points.Rd new file mode 100644 index 0000000..9c096fb --- /dev/null +++ b/man/plot.biokinetics_population_stationary_points.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{plot.biokinetics_population_stationary_points} +\alias{plot.biokinetics_population_stationary_points} +\title{Plot method for "biokinetics_population_stationary_points" class} +\usage{ +\method{plot}{biokinetics_population_stationary_points}(x, ..., upper_detection_limit = NULL) +} +\arguments{ +\item{x}{An object of class "biokinetics_population_stationary_points". These are +generated by running biokinetics$population_stationary_points(). See +\href{../../epikinetics/html/biokinetics.html#method-biokinetics-population_stationary_points}{\code{biokinetics$population_stationary_points()}}} + +\item{\dots}{Further arguments passed to the method.} + +\item{upper_detection_limit}{Numeric. Optional upper detection limit. Will be plotted as a dotted line.} +} +\description{ +Plot method for "biokinetics_population_stationary_points" class +} diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index f0a9829..2509ef5 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -230,6 +230,7 @@ test_that("Can plot individual trajectories for specific pids with data and titr }) test_that("Can plot stationary points", { + skip_if(getRversion() < 4.1) # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( @@ -243,6 +244,7 @@ test_that("Can plot stationary points", { }) test_that("Can plot stationary points with no covariates", { + skip_if(getRversion() < 4.1) # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( @@ -256,6 +258,7 @@ test_that("Can plot stationary points with no covariates", { test_that("Can plot stationary points with upper limit", { + skip_if(getRversion() < 4.1) # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( From 322b7a66da785b2cfe200c763be50e102173043e Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Tue, 19 Nov 2024 13:43:22 +0000 Subject: [PATCH 07/10] fix tests --- tests/testthat/test-plots.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index 2509ef5..19a74f1 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -230,7 +230,7 @@ test_that("Can plot individual trajectories for specific pids with data and titr }) test_that("Can plot stationary points", { - skip_if(getRversion() < 4.1) + skip_if(getRversion() < "4.1") # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( @@ -244,7 +244,7 @@ test_that("Can plot stationary points", { }) test_that("Can plot stationary points with no covariates", { - skip_if(getRversion() < 4.1) + skip_if(getRversion() < "4.1") # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( @@ -258,7 +258,7 @@ test_that("Can plot stationary points with no covariates", { test_that("Can plot stationary points with upper limit", { - skip_if(getRversion() < 4.1) + skip_if(getRversion() < "4.1") # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( From 295e71d321f5d077a6bf8ae9af41184d3b5dd093 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Mon, 2 Dec 2024 12:59:58 +0000 Subject: [PATCH 08/10] update docs --- NAMESPACE | 2 ++ R/epikinetics-package.R | 2 +- R/plot.R | 8 +++++--- man/plot.biokinetics_individual_trajectories.Rd | 8 +++++--- 4 files changed, 13 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8d14a98..620d689 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,8 @@ importFrom(data.table,data.table) importFrom(ggplot2,aes) importFrom(ggplot2,annotate) importFrom(ggplot2,facet_wrap) +importFrom(ggplot2,geom_bar) +importFrom(ggplot2,geom_density_2d) importFrom(ggplot2,geom_hline) importFrom(ggplot2,geom_line) importFrom(ggplot2,geom_path) diff --git a/R/epikinetics-package.R b/R/epikinetics-package.R index 4b8a1ae..77fec4a 100644 --- a/R/epikinetics-package.R +++ b/R/epikinetics-package.R @@ -11,7 +11,7 @@ #' @importFrom data.table .NGRP #' @importFrom data.table .SD #' @importFrom data.table data.table -#' @importFrom ggplot2 aes annotate facet_wrap geom_point geom_ribbon geom_line geom_smooth +#' @importFrom ggplot2 aes annotate facet_wrap geom_point geom_ribbon geom_line geom_smooth geom_bar geom_density_2d #' geom_vline geom_hline geom_path labs ggplot guides guide_legend scale_y_continuous #' scale_x_continuous scale_x_date sec_axis #' @useDynLib epikinetics, .registration = TRUE diff --git a/R/plot.R b/R/plot.R index 4caec7a..b15b595 100644 --- a/R/plot.R +++ b/R/plot.R @@ -150,13 +150,15 @@ plot.biokinetics_population_trajectories <- function(x, ..., #' generated by running biokinetics$simulate_individual_trajectories(). See #' \href{../../epikinetics/html/biokinetics.html#method-biokinetics-simulate_individaul_trajectories}{\code{biokinetics$simulate_individual_trajectories()}} #' @param \dots Further arguments passed to the method. +#' @param data Optional data.table containing raw data as provided to the biokinetics model. #' @param min_day Optional minimum date #' @param max_day Optional maximum date -#' @param pid Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used +#' @param pids Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used #' if x has been generated with summarise=FALSE. #' @param titre_types Optional vector of titre types to include. #' @export -plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, +plot.biokinetics_individual_trajectories <- function(x, ..., + data = NULL, min_day = NULL, max_day = NULL, pids = NULL, @@ -165,7 +167,7 @@ plot.biokinetics_individual_trajectories <- function(x, ..., data = NULL, # Declare variables to suppress notes when compiling package # https://github.com/Rdatatable/data.table/issues/850#issuecomment-259466153 calendar_day <- value <- me <- mu <- titre_type <- day <- pid <- NULL - ind_mu_sum <- lo <- hi <- NULL + ind_mu_sum <- lo <- hi <- draw <- NULL if (is.null(min_day)) { min_day <- min(x$calendar_day) diff --git a/man/plot.biokinetics_individual_trajectories.Rd b/man/plot.biokinetics_individual_trajectories.Rd index 2e188bf..e7a5426 100644 --- a/man/plot.biokinetics_individual_trajectories.Rd +++ b/man/plot.biokinetics_individual_trajectories.Rd @@ -21,14 +21,16 @@ generated by running biokinetics$simulate_individual_trajectories(). See \item{\dots}{Further arguments passed to the method.} +\item{data}{Optional data.table containing raw data as provided to the biokinetics model.} + \item{min_day}{Optional minimum date} \item{max_day}{Optional maximum date} -\item{titre_types}{Optional vector of titre types to include.} - -\item{pid}{Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used +\item{pids}{Optional vector of ids to plot simulated trajectories for a subset of individuals. Can only be used if x has been generated with summarise=FALSE.} + +\item{titre_types}{Optional vector of titre types to include.} } \description{ Plot method for "biokinetics_individual_trajectories" class From 0d6660f9e173374680f8a1d21dab2bbe715214e8 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Mon, 2 Dec 2024 13:17:00 +0000 Subject: [PATCH 09/10] skip diff plot tests on mac --- tests/testthat/test-plots.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-plots.R b/tests/testthat/test-plots.R index 19a74f1..6cc58de 100644 --- a/tests/testthat/test-plots.R +++ b/tests/testthat/test-plots.R @@ -230,7 +230,7 @@ test_that("Can plot individual trajectories for specific pids with data and titr }) test_that("Can plot stationary points", { - skip_if(getRversion() < "4.1") + skip_on_os("mac") # diff fails on CI for macOS # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( @@ -244,7 +244,7 @@ test_that("Can plot stationary points", { }) test_that("Can plot stationary points with no covariates", { - skip_if(getRversion() < "4.1") + skip_on_os("mac") # diff fails on CI for macOS # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( @@ -258,7 +258,7 @@ test_that("Can plot stationary points with no covariates", { test_that("Can plot stationary points with upper limit", { - skip_if(getRversion() < "4.1") + skip_on_os("mac") # diff fails on CI for macOS # note that this is using a pre-fitted model with very few iterations, so the # fits won't look very good local_mocked_bindings( From df50fb571c5bc6117d84d6d0c6e6682e5cd25346 Mon Sep 17 00:00:00 2001 From: "alex.hill@gmail.com" Date: Wed, 4 Dec 2024 11:03:43 +0000 Subject: [PATCH 10/10] fix diagnostic vignette --- vignettes/diagnostics.Rmd | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/vignettes/diagnostics.Rmd b/vignettes/diagnostics.Rmd index 3268e4f..a0a93a9 100644 --- a/vignettes/diagnostics.Rmd +++ b/vignettes/diagnostics.Rmd @@ -59,6 +59,9 @@ mod$plot_model_inputs() ## Interactive data exploration To play around with different priors and visualise input data filtered and disaggregated in different ways, -the function [biokinetics$inspect](reference/biokinetics.html#method-biokinetics-inspect) runs a local RShiny app with interactive plots. +the function [biokinetics$inspect](../reference/biokinetics.html#method-biokinetics-inspect) runs a local RShiny app with interactive plots. -![RShiny demonstration](./shiny.webm) + \ No newline at end of file