From 140c30b8f90a2647befc6efcb7a3049ade8f9a8d Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 12 Sep 2023 16:52:46 -0400 Subject: [PATCH 1/3] 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/3] 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/3] 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") +})