diff --git a/R/plot.R b/R/plot.R index 3c9269f..ec38cc9 100644 --- a/R/plot.R +++ b/R/plot.R @@ -124,73 +124,92 @@ plot.biokinetics_population_trajectories <- function(x, ..., data = NULL) { #' 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 01a2b73..47fb73d 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) @@ -139,9 +139,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", { @@ -156,9 +156,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", {