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") +})