diff --git a/NAMESPACE b/NAMESPACE index bf71c64..b500fc9 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) @@ -21,15 +23,23 @@ 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) 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) importFrom(ggplot2,theme) importFrom(ggplot2,unit) useDynLib(epikinetics, .registration = TRUE) diff --git a/R/biokinetics.R b/R/biokinetics.R index cadd028..885223f 100644 --- a/R/biokinetics.R +++ b/R/biokinetics.R @@ -451,6 +451,7 @@ biokinetics <- R6::R6Class( logger::log_info("Recovering covariate names") dt_out <- private$recover_covariate_names(dt_out) } + dt_out }, #' @description Process the model results into a data table of titre values over time. @@ -537,17 +538,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_peak_switch[ + dt_out <- dt_out[ , rel_drop := mu_s / mu_p, by = c(private$all_formula_vars, "titre_type")][ , .( @@ -557,10 +558,14 @@ 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)) + 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 #' 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/epikinetics-package.R b/R/epikinetics-package.R index ee9f4ae..67e10e3 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 annotate facet_wrap geom_hline geom_point geom_ribbon geom_line geom_smooth ggplot guides guide_legend scale_y_continuous theme unit +#' @importFrom ggplot2 aes annotate facet_wrap geom_point geom_ribbon geom_line geom_smooth geom_bar +#' geom_vline geom_hline geom_path labs ggplot guides guide_legend scale_y_continuous theme unit +#' geom_density_2d 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 dcd788c..83f59c9 100644 --- a/R/plot.R +++ b/R/plot.R @@ -144,6 +144,156 @@ 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. +#' @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 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, + 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 <- day <- pid <- NULL + ind_mu_sum <- lo <- hi <- draw <- NULL + + if (is.null(min_day)) { + min_day <- min(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(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[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 { + 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[day >= min_day & day <= max_day,], + aes(x = day, + 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") + + guides(colour = guide_legend(title = "Titre type", override.aes = list(alpha = 1, linewidth = 1)), + 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)) + + 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 = "+")) } @@ -172,4 +322,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/man/biokinetics.Rd b/man/biokinetics.Rd index 778a11a..e0db6fa 100644 --- a/man/biokinetics.Rd +++ b/man/biokinetics.Rd @@ -322,7 +322,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..e7a5426 --- /dev/null +++ b/man/plot.biokinetics_individual_trajectories.Rd @@ -0,0 +1,37 @@ +% 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{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{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 +} 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/_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 new file mode 100644 index 0000000..28e7e3f --- /dev/null +++ b/tests/testthat/_snaps/plots/individualtrajectories-unsum.svg @@ -0,0 +1,1465 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +500 +1000 +1500 + + + + + + + + +0 +500 +1000 +1500 + + + + + +Jan 2021 +Apr 2021 +Jul 2021 +Oct 2021 +Jan 2022 +Date +Titre (IC +50 +) +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 new file mode 100644 index 0000000..2e6f0f5 --- /dev/null +++ b/tests/testthat/_snaps/plots/individualtrajectories.svg @@ -0,0 +1,80 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +500 +1000 +1500 + + + + + + + + + +Jan 2021 +Apr 2021 +Jul 2021 +Oct 2021 +Jan 2022 +Date +Titre (IC +50 +) + +Titre type + + + + + + +Alpha +Ancestral +Delta +individualtrajectories + + 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 1c9fbe0..6cc58de 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) @@ -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"))) } @@ -134,3 +138,135 @@ 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 := ifelse(hi > 2000, me + 100, hi)] + vdiffr::expect_doppelganger("individualtrajectories", plot(trajectories, + max_day = lubridate::ymd("2022/01/01"))) +}) + +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 + # truncate these + trajectories[, mu := ifelse(mu > 2000, 2000, mu)] + vdiffr::expect_doppelganger("individualtrajectories-unsum", plot(trajectories, + 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", { + 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( + 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", { + 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( + 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", { + 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( + 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)) +}) 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