Allow classInt binning to work with groups that have a single value (fix

certara#51)
billdenney · Sep 12, 2023 · a5e220f · a5e220f
1 parent 5b6c0c4
commit a5e220f
Show file tree

Hide file tree

Showing 3 changed files with 48 additions and 23 deletions.
diff --git 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
@@ -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
@@ -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")
+})