From 140c30b8f90a2647befc6efcb7a3049ade8f9a8d Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 12 Sep 2023 16:52:46 -0400 Subject: [PATCH 1/7] Remove whitespace --- tests/testthat/test-binning.R | 87 +++++++++++++++++------------------ 1 file changed, 43 insertions(+), 44 deletions(-) diff --git a/tests/testthat/test-binning.R b/tests/testthat/test-binning.R index d09c435..0ff273e 100644 --- a/tests/testthat/test-binning.R +++ b/tests/testthat/test-binning.R @@ -1,46 +1,46 @@ test_that("obs bins equal stats bins", { obs_data <- as.data.table(tidyvpc::obs_data) sim_data <- as.data.table(tidyvpc::sim_data) - + ## Subest MDV = 0 obs_data <- obs_data[MDV == 0] sim_data <- sim_data[MDV == 0] - + unique_bins_obs <- as.factor(unique(obs_data$NTIME)) #Assign observed and simulated data to tidyvpc object vpc <- observed(obs_data, x = TIME, y = DV ) - + vpc <- simulated(vpc, sim_data, y = DV) - + vpc <- binning(vpc, bin = NTIME) - + vpc <- vpcstats(vpc) - + unique_bins_vpc <- unique(vpc$stats$bin) #Check that bins match for binning on xvar NTIME expect_equal(unique_bins_obs, unique_bins_vpc) - + }) test_that("cat obs vpcstats is correct", { obs_cat_data <- as.data.table(tidyvpc::obs_cat_data) sim_cat_data <- as.data.table(tidyvpc::sim_cat_data) - + vpc <- observed(obs_cat_data, x = agemonths, y = zlencat ) vpc <- simulated(vpc, sim_cat_data, y = DV) vpc <- binning(vpc, bin = round(agemonths, 0)) vpc <- vpcstats(vpc, vpc.type = "categorical") - + location <- system.file("extdata/Binning","cat_stats.csv",package="tidyvpc") - + stats <- fread(location, colClasses = c(pname = "factor")) stats$bin <- as.factor(stats$bin) - + setkeyv(stats, c("xbin")) - - + + #Check for equality, dispatches to data.table::all.equal method expect_identical(all.equal(vpc$stats, stats), TRUE) @@ -51,24 +51,24 @@ test_that("cat obs vpcstats is correct", { test_that("cat obs strat vpcstats is correct", { obs_cat_data <- as.data.table(tidyvpc::obs_cat_data) sim_cat_data <- as.data.table(tidyvpc::sim_cat_data) - + vpc <- observed(obs_cat_data, x = agemonths, y = zlencat ) vpc <- simulated(vpc, sim_cat_data, y = DV) vpc <- stratify(vpc, ~ Country_ID_code) vpc <- binning(vpc, bin = round(agemonths, 0)) vpc <- vpcstats(vpc, vpc.type = "categorical") - + location <- system.file("extdata/Binning","cat_strat_stats.csv",package="tidyvpc") - + stats <- fread(location, colClasses = c(pname = "factor")) stats$bin <- as.factor(stats$bin) setkeyv(stats, c(names(vpc$strat), "xbin")) - - + + #Check for equality, dispatches to data.table::all.equal method expect_identical(all.equal(vpc$stats, stats), TRUE) - + }) test_that("binning methods are valid", { @@ -76,32 +76,32 @@ test_that("binning methods are valid", { ## Subest MDV = 0 obs <- obs_data[MDV == 0] sim <- sim_data[MDV == 0] - + vpc <- observed(obs, x = TIME, y = DV ) vpc <- simulated(vpc, sim, y = DV) - + centers <- c(0,1,5,8,12) vpc <- binning(vpc, bin = "centers", centers = centers) expect_equal(vpc$xbin$bin, as.factor(centers)) - + vpc <- binning(vpc, bin = "breaks", breaks = c(1,3,6,9,11)) expect_true(length(levels(vpc$xbin$bin)) == 11) - + vpc <- binning(vpc, bin = "breaks", breaks = c(1,3,6,9,11)) expect_true(length(levels(vpc$xbin$bin)) == 11) - + vpc <- binning(vpc, bin = "pam", nbins = 6) expect_true(max(vpc$xbin$xbin) < 12) - + vpc <- binning(vpc, bin = "ntile", nbins = 6) expect_true(nrow(vpc$xbin) == 6) - + vpc <- binning(vpc, bin = "eqcut", nbins = 12) expect_true(nrow(vpc$xbin) == 12) - + vpc <- binning(vpc, bin = "sd", nbins = 4) expect_true(nrow(vpc$xbin) == 6) - + }) @@ -109,51 +109,51 @@ test_that("binning by stratum works", { 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 <- stratify(vpc, ~ GENDER + STUDY) + vpc <- stratify(vpc, ~ GENDER + STUDY) vpc <- binning(vpc, stratum = list(GENDER = "M", STUDY = "Study A"), bin = "jenks", nbins = 5, by.strata = T) vpc <- binning(vpc, stratum = list(GENDER = "F", STUDY = "Study A"), bin = "centers", centers = c(0.5,3,5,10,15), by.strata = T) vpc <- binning(vpc, stratum = list(GENDER = "M", STUDY = "Study B"), bin = "kmeans", by.strata = T) vpc <- binning(vpc, stratum = list(GENDER = "F", STUDY = "Study B"), bin = "pam", nbins = 5, by.strata = T) - vpc <- predcorrect(vpc, pred=PRED) + vpc <- predcorrect(vpc, pred=PRED) vpc <- vpcstats(vpc) - + expect_true(inherits(vpc, "tidyvpcobj") && vpc$bin.by.strata) - + }) - + test_that("binning errors are valid", { - + obs <- obs_data[MDV == 0] sim <- sim_data[MDV == 0] - + vpc <- observed(obs, x = TIME, y = DV ) vpc <- simulated(vpc, sim, y = DV) expect_true(inherits(binning(vpc, xbin = NTIME), "tidyvpcobj")) expect_error(binning(vpc, xbin = c(1:5))) - + }) test_that("binning can be used after predcorrect", { 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 <- stratify(vpc, ~ GENDER) vpc <- predcorrect(vpc, pred = PRED) vpc <- binning(vpc, bin = NTIME) vpc <- vpcstats(vpc) - + location <- system.file("extdata/Binning","predcor_strat_stats.csv",package="tidyvpc") stats <- fread(location, colClasses = c(qname = "factor")) stats[, bin := factor(bin, levels = levels(vpc$stats$bin))] setkeyv(stats, c(names(vpc$strat), "xbin")) - + expect_equal(vpc$stats, stats) }) @@ -161,19 +161,18 @@ test_that("binning can be used before predcorrect", { 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 <- stratify(vpc, ~ GENDER) vpc <- binning(vpc, bin = NTIME) vpc <- predcorrect(vpc, pred = PRED) vpc <- vpcstats(vpc) - + location <- system.file("extdata/Binning","predcor_strat_stats.csv",package="tidyvpc") stats <- fread(location, colClasses = c(qname = "factor")) stats[, bin := factor(bin, levels = levels(vpc$stats$bin))] setkeyv(stats, c(names(vpc$strat), "xbin")) - + expect_equal(vpc$stats, stats) }) - From 5b6c0c43953d7d8b783fe05459e12cea027a66c5 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 12 Sep 2023 16:56:50 -0400 Subject: [PATCH 2/7] Remove whitespace --- R/vpcstats.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/vpcstats.R b/R/vpcstats.R index 5be89cc..2a490bd 100644 --- a/R/vpcstats.R +++ b/R/vpcstats.R @@ -525,7 +525,7 @@ binning.tidyvpcobj <- function(o, bin, data=o$data, xbin="xmedian", centers, bre stop("Invalid xbin") } vpc.method <- list(method = "binning") - + # check if user supplied predcorrect before binning if (!is.null(o$predcor) && o$predcor) { pred <- o$pred @@ -540,7 +540,7 @@ binning.tidyvpcobj <- function(o, bin, data=o$data, xbin="xmedian", centers, bre o$sim[, ypc := ifelse(rep(pred, times = nrow(o$sim) / nrow(o$obs)) == 0, 0, (mpred / pred) * y)] } } - + update(o, xbin=xbin, vpc.method = vpc.method) } @@ -606,13 +606,13 @@ predcorrect.tidyvpcobj <- function(o, pred, data=o$data, ..., log=FALSE) { stratbin <- o$.stratbin # predcorrect after binning, check if binning/binless has already been specified - + if (!is.null(o$vpc.method)) { if(o$vpc.method$method == "binless") { o$vpc.method$loess.ypc <- TRUE } else { #binning specified, perform ypc calculcation mpred <- data.table(stratbin, pred)[, mpred := median(pred), by = stratbin]$mpred - + if (log) { o$obs[, ypc := (mpred - pred) + y] o$sim[, ypc := (mpred - pred) + y] From a5e220fe6cb0d138bc5dd38a5b972622dfd57060 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 12 Sep 2023 17:03:51 -0400 Subject: [PATCH 3/7] Allow classInt binning to work with groups that have a single value (fix #51) --- NEWS.md | 1 + R/vpcstats.R | 51 +++++++++++++++++++---------------- tests/testthat/test-binning.R | 19 +++++++++++++ 3 files changed, 48 insertions(+), 23 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8c2a4df..8c060db 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * `simulated.tidyvpcobj()` detects if the number of simulated rows is not an integer multiple of the number of observed rows and adds the new `xsim` argument to test that x values match between replicated simulations. It will suggest that MDV filtering may not have occurred if either of these fails [#35](https://github.com/certara/tidyvpc/issues/35). * Prevent division by zero in `predcorrect()` transformation [#31](https://github.com/certara/tidyvpc/issues/31). * Usability enhancements for prediction corrected VPC (pcVPC), which include support for `binning.tidyvpcobj()` either before or after usage of `predcorrect.tidyvpcobj()`, and automatically performing LOESS pcVPC when `binless.tidyvpcobj()` is used. As a result, the `loess.ypc` argument is no longer required[#43](https://github.com/certara/tidyvpc/issues/43). +* VPC can work with a single value in a group [#51](https://github.com/certara/tidyvpc/issues/51) # tidyvpc 1.4.0 * Fix for npde calculation fix npde calc [#16](https://github.com/certara/tidyvpc/pull/16) diff --git a/R/vpcstats.R b/R/vpcstats.R index 2a490bd..c461410 100644 --- a/R/vpcstats.R +++ b/R/vpcstats.R @@ -858,32 +858,37 @@ bin_by_classInt <- function(style, nbins=NULL) { nbins <- .check_nbins(nbins) } function(x, ...) { - args <- list(var=x, style=style) - if (!is.null(nbins)) { - nbins <- .resolve_nbins(nbins, ...) - args$n <- nbins - } - args <- c(args, list(...)) - if (style %in% c("kmeans", "hclust", "dpih")) { - # These don't accept '...' arguments - args1 <- args[intersect(names(args), methods::formalArgs(classInt::classIntervals))] - args2 <- if (style == "kmeans") { - args[intersect(names(args), methods::formalArgs(stats::kmeans))] - } else if (style == "hclust") { - args[intersect(names(args), methods::formalArgs(stats::hclust))] - } else if (style == "dpih") { - has_KernSmooth <- requireNamespace("KernSmooth", quietly=TRUE) - if (!has_KernSmooth) { - stop("Package 'KernSmooth' is required to use the binning method. Please install it.") + if (length(unique(x)) > 1) { + args <- list(var=x, style=style) + if (!is.null(nbins)) { + nbins <- .resolve_nbins(nbins, ...) + args$n <- nbins + } + args <- c(args, list(...)) + if (style %in% c("kmeans", "hclust", "dpih")) { + # These don't accept '...' arguments + args1 <- args[intersect(names(args), methods::formalArgs(classInt::classIntervals))] + args2 <- if (style == "kmeans") { + args[intersect(names(args), methods::formalArgs(stats::kmeans))] + } else if (style == "hclust") { + args[intersect(names(args), methods::formalArgs(stats::hclust))] + } else if (style == "dpih") { + has_KernSmooth <- requireNamespace("KernSmooth", quietly=TRUE) + if (!has_KernSmooth) { + stop("Package 'KernSmooth' is required to use the binning method. Please install it.") + } + args[intersect(names(args), methods::formalArgs(KernSmooth::dpih))] + } else { + list() } - args[intersect(names(args), methods::formalArgs(KernSmooth::dpih))] - } else { - list() + args <- c(args1, args2) } - args <- c(args1, args2) + args <- args[!duplicated(args)] + breaks <- do.call(classInt::classIntervals, args)$brks + } else { + # If a group has a single value, `classInt::classIntervals` gives an error + breaks <- rep(1, length(x)) } - args <- args[!duplicated(args)] - breaks <- do.call(classInt::classIntervals, args)$brks cut_at(breaks)(x) } } diff --git a/tests/testthat/test-binning.R b/tests/testthat/test-binning.R index 0ff273e..f209e12 100644 --- a/tests/testthat/test-binning.R +++ b/tests/testthat/test-binning.R @@ -176,3 +176,22 @@ test_that("binning can be used before predcorrect", { expect_equal(vpc$stats, stats) }) + +test_that("binning works with single-value groups (#51)", { + 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") + expect_s3_class(value, "tidyvpcobj") +}) From 27d75fbea05ba742b245be5881d5f9afca94348f Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 12 Sep 2023 17:51:56 -0400 Subject: [PATCH 4/7] Ensure that values show up for single-x-value group plotting (related to #51) --- R/plot.R | 99 +++++++++++++++++++++++++------------- tests/testthat/test-plot.R | 61 ++++++++++++++++------- 2 files changed, 110 insertions(+), 50 deletions(-) diff --git a/R/plot.R b/R/plot.R index 84667ef..2b3a3cc 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" @@ -121,11 +121,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) @@ -133,7 +133,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( @@ -147,7 +147,7 @@ plot.tidyvpcobj <- function(x, show.binning ) } - + if (censoring.type %in% c("both", "alq")) { g_alq <- plot_censored( @@ -161,14 +161,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) @@ -181,6 +181,37 @@ 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$strat possibly with additional rows for +#' single-value groups +#' @noRd +expand_vpc_stats_single_value <- function(vpc, xvar, width = 0.0001) { + d_vpc_stats <- vpc$strat + if (!is.null(vpc$strat)) { + d_vpc_stats <- + dplyr::grouped_df(vpc$stats, vars = names(vpc$strat)) %>% + dplyr::mutate( + n_xvar = length(unique(!!sym(xvar))) + ) + 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 <- + dplyr::bind_rows( + d_vpc_stats[!mask_n1, ], + d_vpc_stats_single_low, + d_vpc_stats_single_high + ) + } + } + d_vpc_stats +} plot_continuous <- function(vpc, @@ -207,15 +238,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, @@ -262,7 +295,7 @@ plot_continuous <- } else { g <- ggplot2::ggplot(vpc$strat) } - + if (show.points) { points.dat <- copy(vpc$obs) if (isTRUE(vpc$predcor) && method == "binless") { @@ -302,7 +335,7 @@ plot_continuous <- ) } } - + if (show.boundaries && method == "binning") { if (!is.null(vpc$strat)) { boundaries <- @@ -328,7 +361,7 @@ plot_continuous <- linewidth = 1 ) } - + if (facet) { if (!is.null(vpc$strat)) { g <- @@ -363,22 +396,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( @@ -429,7 +462,7 @@ plot_categorical <- colour = guide_legend(order = 2), linetype = guide_legend(order = 1) ) - + if (facet) { if (!is.null(vpc$strat)) { g <- @@ -456,9 +489,9 @@ plot_categorical <- g + ggplot2::facet_wrap(names(vpc$strat), scales = facet.scales, label = label_both) } } - + return(g) - + } @@ -471,11 +504,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") { @@ -483,7 +516,7 @@ plot_censored <- } else { xvar <- "x" } - + type <- match.arg(type) df_name <- paste0("pct", type) @@ -496,9 +529,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) @@ -506,7 +539,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", @@ -524,7 +557,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)) { @@ -554,7 +587,7 @@ plot_censored <- alpha = 0 ) } - + # add theme if (is.null(custom.theme)) { g <- g + ggplot2::theme_bw() + tidyvpc_theme(legend.position = legend.position) @@ -565,7 +598,7 @@ plot_censored <- } else if (inherits(custom.theme, "theme")) { g <- g + custom.theme } - + return(g) } 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) +}) From fe49de227bb4d621378695aeffa1019e14856b2c Mon Sep 17 00:00:00 2001 From: certara-jcraig <61294078+certara-jcraig@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:40:57 -0700 Subject: [PATCH 5/7] translate dplyr usage to data.table --- R/plot.R | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/R/plot.R b/R/plot.R index 2b3a3cc..8664aa6 100644 --- a/R/plot.R +++ b/R/plot.R @@ -184,17 +184,13 @@ plot.tidyvpcobj <- function(x, #' 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$strat possibly with additional rows for +#' @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$strat + d_vpc_stats <- vpc$stats if (!is.null(vpc$strat)) { - d_vpc_stats <- - dplyr::grouped_df(vpc$stats, vars = names(vpc$strat)) %>% - dplyr::mutate( - n_xvar = length(unique(!!sym(xvar))) - ) + 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, ] @@ -203,11 +199,11 @@ expand_vpc_stats_single_value <- function(vpc, xvar, width = 0.0001) { d_vpc_stats_single_high[[xvar]] <- d_vpc_stats_single_high[[xvar]] + width/2 d_vpc_stats <- - dplyr::bind_rows( + data.table::rbindlist(list( d_vpc_stats[!mask_n1, ], d_vpc_stats_single_low, d_vpc_stats_single_high - ) + )) } } d_vpc_stats From 65d8300d7514bb0d14af9fe8e6920739f09fd028 Mon Sep 17 00:00:00 2001 From: certara-jcraig <61294078+certara-jcraig@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:41:23 -0700 Subject: [PATCH 6/7] add ref snapshot --- .../_snaps/plot/single-value-group.svg | 218 ++++++++++++++++++ 1 file changed, 218 insertions(+) create mode 100644 tests/testthat/_snaps/plot/single-value-group.svg 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..d696512 --- /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 +Observed/Simulated probabilities and associated 95% CI + +Observed Percentiles +(black lines) + + + + + + +5% +50% +95% + +Simulated Percentiles +Median (lines) 95% CI (areas) + + + + + + + + + +5% +50% +95% +single-value group + + From c91078cef99e2158f1c562d37abed5fe0f62bcd3 Mon Sep 17 00:00:00 2001 From: certara-jcraig <61294078+certara-jcraig@users.noreply.github.com> Date: Wed, 4 Oct 2023 11:07:45 -0700 Subject: [PATCH 7/7] update snapshot given new default ylab --- tests/testthat/_snaps/plot/single-value-group.svg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/_snaps/plot/single-value-group.svg b/tests/testthat/_snaps/plot/single-value-group.svg index d696512..41e5f9a 100644 --- a/tests/testthat/_snaps/plot/single-value-group.svg +++ b/tests/testthat/_snaps/plot/single-value-group.svg @@ -185,7 +185,7 @@ TIME -Observed/Simulated probabilities and associated 95% CI +Percentiles and associated 95% CI Observed Percentiles (black lines)