diff --git a/R/plot.R b/R/plot.R index 059c3fc..e4e56c7 100644 --- a/R/plot.R +++ b/R/plot.R @@ -25,7 +25,7 @@ #' are \code{"free", "fixed"}. #' @param custom.theme A custom ggplot2 theme supplied either as a character string, function, or object of class \code{"theme"}. #' @param censoring.type A character string specifying additional blq/alq plots to include. Only applicable if -#' \code{\link{censoring}} was performed. +#' \code{\link{censoring}} was performed. #' @param censoring.output A character string specifying whether to return percentage of blq/alq plots as an #' arranged \code{"grid"} or as elements in a \code{"list"}. Only applicable if \code{censoring.type != "none"}. #' @param ... Additional arguments for \code{\link[egg]{ggarrange}} e.g., \code{ncol} and \code{nrow}. @@ -50,7 +50,7 @@ plot.tidyvpcobj <- function(x, ribbon.alpha = 0.1, legend.position="top", facet.scales="free", - custom.theme = NULL, + custom.theme = NULL, censoring.type = c("none", "both", "blq", "alq"), censoring.output = c("grid", "list"), ...) { @@ -91,7 +91,7 @@ plot.tidyvpcobj <- function(x, point.stroke, point.alpha ) - + } @@ -105,7 +105,7 @@ plot.tidyvpcobj <- function(x, } else if (inherits(custom.theme, "theme")) { g <- g + custom.theme } - + # add labels if (is.null(xlab)) { xlab <- "TIME" @@ -127,11 +127,11 @@ plot.tidyvpcobj <- function(x, paste0(ylab, "\nPrediction Corrected")) } } - + g <- g + ggplot2::xlab(xlab) g <- g + ggplot2::ylab(ylab) - - + + # blq/alq plot censoring.type <- match.arg(censoring.type) censoring.output <- match.arg(censoring.output) @@ -139,7 +139,7 @@ plot.tidyvpcobj <- function(x, if (vpc_type == "continuous" && censoring.type != "none") { g_blq <- g_alq <- NULL - + if (censoring.type %in% c("both", "blq")) { g_blq <- plot_censored( @@ -153,7 +153,7 @@ plot.tidyvpcobj <- function(x, show.binning ) } - + if (censoring.type %in% c("both", "alq")) { g_alq <- plot_censored( @@ -167,14 +167,14 @@ plot.tidyvpcobj <- function(x, show.binning ) } - + grid_list <- c(list(g, g_blq,g_alq), grid_args) grid_list <- grid_list[!sapply(grid_list, function(x) is.null(x) || is.symbol(x))] - + if (censoring.output == "grid") { #Return egg g <- do.call(egg::ggarrange, grid_list) @@ -187,6 +187,33 @@ plot.tidyvpcobj <- function(x, g } +#' Expand single-value vpc groups to a finite width so that they show up with `geom_ribbon()` +#' +#' @param vpc The vpc object +#' @return A data frame of the vpc$stats possibly with additional rows for +#' single-value groups +#' @noRd +expand_vpc_stats_single_value <- function(vpc, xvar, width = 0.0001) { + d_vpc_stats <- vpc$stats + if (!is.null(vpc$strat)) { + d_vpc_stats[, n_xvar := length(unique(get(xvar))), by = names(vpc$strat)] + mask_n1 <- d_vpc_stats$n_xvar == 1 + if (any(mask_n1)) { + d_vpc_stats_single <- d_vpc_stats[mask_n1, ] + d_vpc_stats_single_low <- d_vpc_stats_single_high <- d_vpc_stats_single + d_vpc_stats_single_low[[xvar]] <- d_vpc_stats_single_low[[xvar]] - width/2 + d_vpc_stats_single_high[[xvar]] <- d_vpc_stats_single_high[[xvar]] + width/2 + + d_vpc_stats <- + data.table::rbindlist(list( + d_vpc_stats[!mask_n1, ], + d_vpc_stats_single_low, + d_vpc_stats_single_high + )) + } + } + d_vpc_stats +} plot_continuous <- function(vpc, @@ -213,15 +240,17 @@ plot_continuous <- stop(paste0("point.shape must be one of ", paste0(names(point_shape_vec), collapse = ", "))) point.shape <- as.numeric(point_shape_vec[names(point_shape_vec) == point.shape]) - + if (method == "binning") { xvar <- "xbin" } else { xvar <- "x" } - + if (show.stats) { - g <- ggplot2::ggplot(vpc$stats, ggplot2::aes(x = !!sym(xvar))) + + d_vpc_stats <- expand_vpc_stats_single_value(vpc = vpc, xvar = xvar) + g <- + ggplot2::ggplot(d_vpc_stats, ggplot2::aes(x = !!sym(xvar))) + ggplot2::geom_ribbon( ggplot2::aes( ymin = lo, @@ -268,7 +297,7 @@ plot_continuous <- } else { g <- ggplot2::ggplot(vpc$strat) } - + if (show.points) { points.dat <- copy(vpc$obs) if (isTRUE(vpc$predcor) && method == "binless") { @@ -308,7 +337,7 @@ plot_continuous <- ) } } - + if (show.boundaries && method == "binning") { if (!is.null(vpc$strat)) { boundaries <- @@ -334,7 +363,7 @@ plot_continuous <- linewidth = 1 ) } - + if (facet) { if (!is.null(vpc$strat)) { g <- @@ -369,22 +398,22 @@ plot_categorical <- point.shape, point.stroke, point.alpha) { - + y <- md <- pname <- hi <- lo <- NULL - + method <- vpc$vpc.method$method if (method == "binning") { xvar <- "xbin" } else { xvar <- "x" } - + point_shape_vec <- .get_point_shapes() if (!point.shape %in% names(point_shape_vec)) stop(paste0("point.shape must be one of ", paste0(names(point_shape_vec), collapse = ", "))) point.shape <- as.numeric(point_shape_vec[names(point_shape_vec) == point.shape]) - + g <- ggplot(vpc$stats, aes(x = !!sym(xvar))) + geom_ribbon( aes( @@ -435,7 +464,7 @@ plot_categorical <- colour = guide_legend(order = 2), linetype = guide_legend(order = 1) ) - + if (facet) { if (!is.null(vpc$strat)) { g <- @@ -462,9 +491,9 @@ plot_categorical <- g + ggplot2::facet_wrap(names(vpc$strat), scales = facet.scales, label = label_both) } } - + return(g) - + } @@ -477,11 +506,11 @@ plot_censored <- show.points, show.boundaries, show.binning) { - + stopifnot(inherits(vpc, "tidyvpcobj")) hi <- lo <- md <- xbin <- y <- NULL . <- list - + method <- vpc$vpc.method$method if(method == "binning") { @@ -489,7 +518,7 @@ plot_censored <- } else { xvar <- "x" } - + type <- match.arg(type) df_name <- paste0("pct", type) @@ -502,9 +531,9 @@ plot_censored <- "data." ) } - + g <- ggplot(df) - + if (!is.null(vpc$strat)) { if (length(as.list(vpc$strat.formula)) == 3) { g <- g + ggplot2::facet_grid(vpc$strat.formula, scales = facet.scales) @@ -512,7 +541,7 @@ plot_censored <- g <- g + ggplot2::facet_wrap(names(vpc$strat), scales = facet.scales) } } - + g <- g + geom_ribbon(aes(x = !!sym(xvar), ymin = lo, ymax = hi), fill = "red", @@ -530,7 +559,7 @@ plot_censored <- observed = "black") ) + labs(x = "TIME", y = paste0("% ", toupper(type))) - + # ensure x axis is same scale given options in vpc plot that can affect xmax if (method == "binning" && any(show.binning, show.boundaries, show.points)) { @@ -560,7 +589,7 @@ plot_censored <- alpha = 0 ) } - + # add theme if (is.null(custom.theme)) { g <- g + ggplot2::theme_bw() + tidyvpc_theme(legend.position = legend.position) @@ -571,7 +600,7 @@ plot_censored <- } else if (inherits(custom.theme, "theme")) { g <- g + custom.theme } - + return(g) } diff --git a/tests/testthat/_snaps/plot/single-value-group.svg b/tests/testthat/_snaps/plot/single-value-group.svg new file mode 100644 index 0000000..41e5f9a --- /dev/null +++ b/tests/testthat/_snaps/plot/single-value-group.svg @@ -0,0 +1,218 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Healthy + + + + + + + + + + +Patient + + + + + + + +1 +2 +3 +4 +5 + + + + + +-5.0e-05 +-2.5e-05 +0.0e+00 +2.5e-05 +5.0e-05 +1 +2 +3 +4 +5 + + + + + +6 +7 +8 +9 +10 + + + + + +TIME +Percentiles and associated 95% CI + +Observed Percentiles +(black lines) + + + + + + +5% +50% +95% + +Simulated Percentiles +Median (lines) 95% CI (areas) + + + + + + + + + +5% +50% +95% +single-value group + + diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 72c4e38..890ccdf 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -17,57 +17,57 @@ get_os <- function(){ test_that("plot.tidyvpcobj plots binning without stats", { testthat::skip_if_not(get_os() == "windows") testthat::skip_on_cran() - + obs_data <- obs_data[MDV == 0] sim_data <- sim_data[MDV == 0] obs_data$PRED <- sim_data[REP == 1, PRED] - + vpc <- observed(obs_data, x = TIME, y = DV) vpc <- simulated(vpc, sim_data, y = DV) vpc <- binning(vpc, bin = NTIME) - + options(warn = -1) vdiffr::expect_doppelganger("Bins without stats", plot(vpc)) - + vpc <- predcorrect(vpc, pred = PRED) vdiffr::expect_doppelganger("Bins ypc without stats", plot(vpc)) options(warn = 0) - + }) test_that("plot.tidyvpcobj plots censoring", { testthat::skip_if_not(get_os() == "windows") testthat::skip_on_cran() - + obs_data <- obs_data[MDV == 0] sim_data <- sim_data[MDV == 0] obs_data$LLOQ <- obs_data[, ifelse(STUDY == "Study A", 50, 25)] obs_data$ULOQ <- obs_data[, ifelse(STUDY == "Study A", 125, 100)] - + vpc <- observed(obs_data, x = TIME, y = DV) vpc <- simulated(vpc, sim_data, y = DV) vpc <- censoring(vpc, blq = DV < LLOQ, lloq = LLOQ, alq = DV > ULOQ, uloq = ULOQ) vpc <-stratify(vpc, ~ STUDY) vpc <- binning(vpc, bin = NTIME) vpc <- vpcstats(vpc, qpred = c(0.1, 0.5, 0.9)) - + options(warn = -1) vdiffr::expect_doppelganger("Censored plot with bql", plot(vpc, censoring.type = "blq")) - + vdiffr::expect_doppelganger("Censored plot with aql", plot(vpc, censoring.type = "alq")) - + vdiffr::expect_doppelganger("Censored plot with bql aql", plot(vpc, censoring.type = "both")) plot_list <- plot(vpc, censoring.type = "both", censoring.output = "list") testthat::expect_true(length(plot_list) == 3) testthat::expect_true(all(sapply(plot_list, ggplot2::is.ggplot))) - + plot_grid <- plot(vpc, censoring.type = "both", censoring.output = "grid", nrow = 1, ncol = 3) testthat::expect_true(inherits(plot_grid, "egg")) options(warn = 0) @@ -77,10 +77,10 @@ test_that("plot.tidyvpcobj plots censoring", { test_that("plot.tidyvpcobj plots stratified", { testthat::skip_if_not(get_os() == "windows") testthat::skip_on_cran() - + obs_data <- obs_data[MDV == 0] sim_data <- sim_data[MDV == 0] - + options(warn = -1) #two-sided strat formula vpc <- observed(obs_data, x = TIME, y = DV) @@ -88,19 +88,46 @@ test_that("plot.tidyvpcobj plots stratified", { vpc <- stratify(vpc, GENDER ~ STUDY) vpc <- binning(vpc, bin = NTIME) vpc <- vpcstats(vpc, qpred = c(0.1, 0.5, 0.9), quantile.type = 6) - + vdiffr::expect_doppelganger("Two sided strat formula with facet_grid", plot(vpc)) - + #one-sided strat formula vpc <- observed(obs_data, x = TIME, y = DV) vpc <- simulated(vpc, sim_data, y = DV) vpc <- stratify(vpc, ~ GENDER + STUDY) vpc <- binless(vpc) vpc <- vpcstats(vpc, qpred = c(0.1, 0.5, 0.9), quantile.type = 6) - + vdiffr::expect_doppelganger("One sided strat formula with facet_wrap", plot(vpc)) options(warn = 0) }) - \ No newline at end of file + +test_that("plotting shows a finite width with single-value groups (related to #51)", { + testthat::skip_if_not(get_os() == "windows") + testthat::skip_on_cran() + + d_obs <- + data.frame( + group = rep(c("Patient", "Healthy"), each = 5), + conc = c(rep(0, 5), 1:5), + value = 1:10 + ) + + d_sim <- + d_obs[rep(1:nrow(d_obs), 5), ] + + value <- + observed(d_obs, x = conc, yobs = value) %>% + simulated(d_sim, xsim = conc, ysim = value) %>% + stratify(~group) %>% + binning(bin = "jenks") %>% + vpcstats() + + vdiffr::expect_doppelganger( + "single-value group", + plot(value) + ) + options(warn = 0) +})