tests/testthat/test-binning.R

In tidyvpc: VPC Percentiles and Prediction Intervals

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)

})



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", {

  ## 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)

})


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

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

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