# NextBest ---- ## v_next_best_ewoc ---- test_that("v_next_best_ewoc passes for valid object", { object <- .NextBestEWOC() expect_true(v_next_best_ewoc(object)) }) test_that("v_next_best_ewoc returns message for non-valid target", { object <- .NextBestEWOC() object@target <- -0.1 err_msg <- "target must be a probability value from (0, 1) interval" expect_equal(v_next_best_ewoc(object), err_msg) }) test_that("v_next_best_ewoc returns message for non-valid overdose", { object <- .NextBestEWOC() object@overdose <- c(-0.2, 1.2) err_msg <- c( "target must be below the overdose interval", "overdose has to be a probability range" ) expect_equal(v_next_best_ewoc(object), err_msg) }) test_that("v_next_best_ewoc returns message for non-valid max_overdose_prob", { object <- .NextBestEWOC() object@max_overdose_prob <- 1.0 err_msg <- "max_overdose_prob must be a probability value from (0, 1) interval" expect_equal(v_next_best_ewoc(object), err_msg) }) ## v_next_best_mtd ---- test_that("v_next_best_mtd passes for valid object", { object <- h_next_best_mtd() expect_true(v_next_best_mtd(object)) }) test_that("v_next_best_mtd returns message for non-valid target", { err_msg <- "target must be a probability value from (0, 1) interval" object <- h_next_best_mtd() # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_next_best_mtd(object), err_msg) object@target <- 0 expect_equal(v_next_best_mtd(object), err_msg) object@target <- -0.5 expect_equal(v_next_best_mtd(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_next_best_mtd(object), err_msg) }) test_that("v_next_best_mtd returns message for non-valid derive", { object <- h_next_best_mtd() # Changing `derive` so that it has many arguments. object@derive <- function(x, y) 1L expect_equal( v_next_best_mtd(object), "derive must have a single argument" ) # Changing `derive` so that it does not return a number. object@derive <- function(x) c(1, 2) expect_equal( v_next_best_mtd(object), "derive must accept numerical vector as an argument and return a number" ) }) ## v_next_best_ncrm ---- test_that("v_next_best_ncrm passes for valid object", { object <- h_next_best_ncrm() expect_true(v_next_best_ncrm(object)) object <- h_next_best_ncrm(edge_case = TRUE) expect_true(v_next_best_ncrm(object)) }) test_that("v_next_best_ncrm returns message for non-valid target", { err_msg <- "target has to be a probability range" object <- h_next_best_ncrm() # Changing `target` so that it is not an interval. object@target <- 0.6 expect_equal(v_next_best_ncrm(object), err_msg) object@target <- c(0.5, 0.6, 0.8) expect_equal(v_next_best_ncrm(object), err_msg) object@target <- c(0.8, 0.6) expect_equal(v_next_best_ncrm(object), err_msg) # Changing `target` so that one bound is not a valid probability value. object@target <- c(0.4, 1.2) expect_equal(v_next_best_ncrm(object), err_msg) }) test_that("v_next_best_ncrm returns message for non-valid overdose", { err_msg <- "overdose has to be a probability range" object <- h_next_best_ncrm() # Changing `overdose` so that it is not an interval. object@overdose <- 0.6 expect_equal(v_next_best_ncrm(object), err_msg) object@overdose <- c(0.5, 0.6, 0.8) expect_equal(v_next_best_ncrm(object), err_msg) object@overdose <- c(0.8, 0.6) expect_equal(v_next_best_ncrm(object), err_msg) # Changing `overdose` so that one bound is not a valid probability value. object@overdose <- c(0.4, 1.2) expect_equal(v_next_best_ncrm(object), err_msg) }) test_that("v_next_best_ncrm returns message for non-valid max_overdose_prob", { err_msg <- "max_overdose_prob must be a probability value from (0, 1) interval" object <- h_next_best_ncrm() # Changing `max_overdose_prob` so that it does not represent allowed probability value. object@max_overdose_prob <- 1 expect_equal(v_next_best_ncrm(object), err_msg) object@max_overdose_prob <- 0 expect_equal(v_next_best_ncrm(object), err_msg) object@max_overdose_prob <- -0.5 expect_equal(v_next_best_ncrm(object), err_msg) # Changing `max_overdose_prob` so that it is not a scalar. object@max_overdose_prob <- c(0.5, 0.6) expect_equal(v_next_best_ncrm(object), err_msg) }) ## v_next_best_ncrm_loss ---- test_that("v_next_best_ncrm_loss passes for valid object", { object <- h_next_best_ncrm_loss() expect_true(v_next_best_ncrm_loss(object)) object <- h_next_best_ncrm_loss(edge_case = 1L) expect_true(v_next_best_ncrm_loss(object)) object <- h_next_best_ncrm_loss(edge_case = 2L) expect_true(v_next_best_ncrm_loss(object)) }) test_that("v_next_best_ncrm_loss returns message for non-valid target", { err_msg <- "target has to be a probability range excluding 0 and 1" object <- h_next_best_ncrm_loss() # Changing `target` so that it is not an interval. object@target <- 0.6 expect_equal(v_next_best_ncrm_loss(object), err_msg) object@target <- c(0.5, 0.6, 0.8) expect_equal(v_next_best_ncrm_loss(object), err_msg) object@target <- c(0.8, 0.6) expect_equal(v_next_best_ncrm_loss(object), err_msg) # Changing `target` so that one bound is not a valid probability value. object@target <- c(0.4, 1) expect_equal(v_next_best_ncrm_loss(object), err_msg) object@target <- c(0, 0.9) expect_equal(v_next_best_ncrm_loss(object), err_msg) }) test_that("v_next_best_ncrm_loss returns message for non-valid overdose", { err_msg <- "overdose has to be a probability range" object <- h_next_best_ncrm_loss() # Changing `overdose` so that it is not an interval. object@overdose <- 0.6 expect_equal(v_next_best_ncrm_loss(object), err_msg) object@overdose <- c(0.5, 0.6, 0.8) expect_equal(v_next_best_ncrm_loss(object), err_msg) object@overdose <- c(0.8, 0.6) expect_equal(v_next_best_ncrm_loss(object), err_msg) # Changing `overdose` so that one bound is not a valid probability value. object@overdose <- c(-0.5, 0.3) expect_equal(v_next_best_ncrm_loss(object), err_msg) }) test_that("v_next_best_ncrm_loss returns message for non-valid unacceptable", { err_msg <- "unacceptable has to be a probability range" object <- h_next_best_ncrm_loss() # Changing `unacceptable` so that it is not an interval. object@unacceptable <- 0.6 expect_equal(v_next_best_ncrm_loss(object), err_msg) object@unacceptable <- c(0.5, 0.6, 0.8) expect_equal(v_next_best_ncrm_loss(object), err_msg) object@unacceptable <- c(0.8, 0.6) expect_equal(v_next_best_ncrm_loss(object), err_msg) # Changing `unacceptable` so that one bound is not a valid probability value. object@unacceptable <- c(-0.5, 0.3) expect_equal(v_next_best_ncrm_loss(object), err_msg) }) test_that("v_next_best_ncrm_loss returns message for wrong overdose-unacceptable relation", { object <- h_next_best_ncrm_loss() # Changing `unacceptable` so that `overdose[2]` > `unacceptable[1]`. object@unacceptable <- c(0.34, 0.5) expect_equal( v_next_best_ncrm_loss(object), "lower bound of unacceptable has to be >= than upper bound of overdose" ) }) test_that("v_next_best_ncrm_loss returns message for wrong losses", { err_msg <- "losses must be a vector of non-negative numbers of length 3 if unacceptable is c(1, 1), otherwise 4" object <- h_next_best_ncrm_loss() # Changing `losses` so that it contains negative values. object@losses <- c(1, 2, -4, 4) expect_equal(v_next_best_ncrm_loss(object), err_msg) # Changing `losses` so that it is of wrong length. object@losses <- c(1, 2, 4) expect_equal(v_next_best_ncrm_loss(object), err_msg) # Changing `losses` so that it is of wrong length. object@unacceptable <- c(1, 1) object@losses <- c(1, 2, 4, 6) expect_equal(v_next_best_ncrm_loss(object), err_msg) }) ## v_next_best_dual_endpoint ---- test_that("v_next_best_dual_endpoint passes for valid object", { object <- h_next_best_dual_endpoint() expect_true(v_next_best_dual_endpoint(object)) object <- h_next_best_dual_endpoint(target_relative = FALSE) expect_true(v_next_best_dual_endpoint(object)) object <- h_next_best_dual_endpoint(edge_case = TRUE) expect_true(v_next_best_dual_endpoint(object)) }) test_that("v_next_best_dual_endpoint returns message for non-valid target (relative)", { err_msg <- "target has to be a probability range when target_relative is TRUE" object <- h_next_best_dual_endpoint(target_relative = TRUE) # Changing `target` so that it is not an interval. object@target <- 0.6 expect_equal(v_next_best_dual_endpoint(object), err_msg) object@target <- c(0.5, 0.6, 0.8) expect_equal(v_next_best_dual_endpoint(object), err_msg) object@target <- c(0.8, 0.6) expect_equal(v_next_best_dual_endpoint(object), err_msg) # Changing `target` so that one bound is not a valid probability value. object@target <- c(0.4, 1.2) expect_equal(v_next_best_dual_endpoint(object), err_msg) }) test_that("v_next_best_dual_endpoint returns message for non-valid target (absolute)", { err_msg <- "target must be a numeric range" object <- h_next_best_dual_endpoint(target_relative = FALSE) # Changing `target` so that it is not a numeric range. object@target <- 0.6 expect_equal(v_next_best_dual_endpoint(object), err_msg) object@target <- c(1, 5, 7) expect_equal(v_next_best_dual_endpoint(object), err_msg) object@target <- c(0.8, 0.6) expect_equal(v_next_best_dual_endpoint(object), err_msg) }) test_that("v_next_best_dual_endpoint returns message for non-valid target_relative flag", { object <- h_next_best_dual_endpoint() # Changing `target_relative` so that it is not a flag. object@target_relative <- c(TRUE, FALSE) expect_equal( v_next_best_dual_endpoint(object), "target_relative must be a flag" ) }) test_that("v_next_best_dual_endpoint returns message for non-valid overdose", { err_msg <- "overdose has to be a probability range" object <- h_next_best_dual_endpoint() # Changing `overdose` so that it is not an interval. object@overdose <- 0.6 expect_equal(v_next_best_dual_endpoint(object), err_msg) object@overdose <- c(0.5, 0.6, 0.8) expect_equal(v_next_best_dual_endpoint(object), err_msg) object@overdose <- c(0.8, 0.6) expect_equal(v_next_best_dual_endpoint(object), err_msg) # Changing `overdose` so that one bound is not a valid probability value. object@overdose <- c(0.4, 1.2) expect_equal(v_next_best_dual_endpoint(object), err_msg) }) test_that("v_next_best_dual_endpoint returns message for non-valid max_overdose_prob", { err_msg <- "max_overdose_prob must be a probability value from (0, 1) interval" object <- h_next_best_dual_endpoint() # Changing `max_overdose_prob` so that it does not represent allowed probability value. object@max_overdose_prob <- 1 expect_equal(v_next_best_dual_endpoint(object), err_msg) object@max_overdose_prob <- 0 expect_equal(v_next_best_dual_endpoint(object), err_msg) object@max_overdose_prob <- -0.5 expect_equal(v_next_best_dual_endpoint(object), err_msg) # Changing `max_overdose_prob` so that it is not a scalar. object@max_overdose_prob <- c(0.5, 0.6) expect_equal(v_next_best_dual_endpoint(object), err_msg) }) test_that("v_next_best_dual_endpoint returns message for non-valid target_thresh", { err_msg <- "target_thresh must be a probability value from [0, 1] interval" object <- h_next_best_dual_endpoint() # Changing `target_thresh` so that it does not represent allowed probability value. object@target_thresh <- 2 expect_equal(v_next_best_dual_endpoint(object), err_msg) object@target_thresh <- -0.5 expect_equal(v_next_best_dual_endpoint(object), err_msg) # Changing `target_thresh` so that it is not a scalar. object@target_thresh <- c(0.5, 0.6) expect_equal(v_next_best_dual_endpoint(object), err_msg) }) ## v_next_best_min_dist ---- test_that("v_next_best_min_dist passes for valid object", { object <- NextBestMinDist(target = 0.3) expect_true(v_next_best_min_dist(object)) }) test_that("v_next_best_min_dist returns message for non-valid target", { err_msg <- "target must be a probability value from (0, 1) interval" object <- NextBestMinDist(target = 0.3) # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_next_best_min_dist(object), err_msg) object@target <- 0 expect_equal(v_next_best_min_dist(object), err_msg) object@target <- -0.5 expect_equal(v_next_best_min_dist(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_next_best_min_dist(object), err_msg) }) ## v_next_best_inf_theory ---- test_that("v_next_best_inf_theory passes for valid object", { object <- NextBestInfTheory(target = 0.4, asymmetry = 1.5) expect_true(v_next_best_inf_theory(object)) }) test_that("v_next_best_inf_theory returns message for non-valid target", { err_msg <- "target must be a probability value from (0, 1) interval" object <- NextBestInfTheory(target = 0.4, asymmetry = 1.5) # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_next_best_inf_theory(object), err_msg) object@target <- 0 expect_equal(v_next_best_inf_theory(object), err_msg) object@target <- -0.5 expect_equal(v_next_best_inf_theory(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_next_best_inf_theory(object), err_msg) }) test_that("v_next_best_inf_theory returns message for non-valid asymmetry", { err_msg <- "asymmetry must be a number from (0, 2) interval" object <- NextBestInfTheory(target = 0.4, asymmetry = 1.5) # Changing `asymmetry` so that it is outside of (0, 2). object@asymmetry <- 5 expect_equal(v_next_best_inf_theory(object), err_msg) object@asymmetry <- 0 expect_equal(v_next_best_inf_theory(object), err_msg) object@asymmetry <- 2 expect_equal(v_next_best_inf_theory(object), err_msg) # Changing `asymmetry` so that it is not a scalar. object@asymmetry <- c(1, 1.8) expect_equal(v_next_best_inf_theory(object), err_msg) }) ## v_next_best_td ---- test_that("v_next_best_td passes for valid object", { object <- NextBestTD(0.4, 0.35) expect_true(v_next_best_td(object)) }) test_that("v_next_best_td returns message for non-valid prob_target_drt", { err_msg <- "prob_target_drt must be a probability value from (0, 1) interval" object <- NextBestTD(0.4, 0.35) # Changing `prob_target_drt` so that it does not represent allowed probability value. object@prob_target_drt <- 1 expect_equal(v_next_best_td(object), err_msg) object@prob_target_drt <- 0 expect_equal(v_next_best_td(object), err_msg) object@prob_target_drt <- -0.5 expect_equal(v_next_best_td(object), err_msg) # Changing `prob_target_drt` so that it is not a scalar. object@prob_target_drt <- c(0.5, 0.6) expect_equal(v_next_best_td(object), err_msg) }) test_that("v_next_best_td returns message for non-valid prob_target_eot", { err_msg <- "prob_target_eot must be a probability value from (0, 1) interval" object <- NextBestTD(0.4, 0.35) # Changing `prob_target_eot` so that it does not represent allowed probability value. object@prob_target_eot <- 1 expect_equal(v_next_best_td(object), err_msg) object@prob_target_eot <- 0 expect_equal(v_next_best_td(object), err_msg) object@prob_target_eot <- -0.5 expect_equal(v_next_best_td(object), err_msg) # Changing `prob_target_eot` so that it is not a scalar. object@prob_target_eot <- c(0.5, 0.6) expect_equal(v_next_best_td(object), err_msg) }) ## v_next_best_td_samples ---- test_that("v_next_best_td_samples passes for valid object", { object <- h_next_best_tdsamples() expect_true(v_next_best_td_samples(object)) }) test_that("v_next_best_td_samples returns message for non-valid derive", { object <- h_next_best_tdsamples() # Changing `derive` so that it has many arguments. object@derive <- function(x, y) 1L expect_equal( v_next_best_td_samples(object), "derive must have a single argument" ) # Changing `derive` so that it does not return a number. object@derive <- function(x) c(1, 2) expect_equal( v_next_best_td_samples(object), "derive must accept numerical vector as an argument and return a number" ) }) ## v_next_best_max_gain_samples ---- test_that("v_next_best_max_gain_samples passes for valid object", { object <- h_next_best_mgsamples() expect_true(v_next_best_max_gain_samples(object)) }) test_that("v_next_best_max_gain_samples returns message for non-valid derive", { object <- h_next_best_mgsamples() # Changing `derive` so that it has many arguments. object@derive <- function(x, y) 1L expect_equal( v_next_best_max_gain_samples(object), "derive must have a single argument" ) # Changing `derive` so that it does not return a number. object@derive <- function(x) c(1, 2) expect_equal( v_next_best_max_gain_samples(object), "derive must accept numerical vector as an argument and return a number" ) }) test_that("v_next_best_max_gain_samples returns message for non-valid mg_derive", { object <- h_next_best_mgsamples() # Changing `mg_derive` so that it has many arguments. object@mg_derive <- function(x, y) 1L expect_equal( v_next_best_max_gain_samples(object), "mg_derive must have a single argument" ) # Changing `mg_derive` so that it does not return a number. object@mg_derive <- function(x) c(1, 2) expect_equal( v_next_best_max_gain_samples(object), "mg_derive must accept numerical vector as an argument and return a number" ) }) ## v_next_best_prob_mtd_lte ---- test_that("v_next_best_prob_mtd_lte passes for valid object", { object <- NextBestProbMTDLTE(0.3) expect_true(v_next_best_prob_mtd_lte(object)) }) test_that("v_next_best_prob_mtd_lte returns message for non-valid target", { err_msg <- "target must be a probability value from (0, 1) interval" object <- NextBestProbMTDLTE(0.3) # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_next_best_prob_mtd_lte(object), err_msg) object@target <- 0 expect_equal(v_next_best_prob_mtd_lte(object), err_msg) object@target <- -0.5 expect_equal(v_next_best_prob_mtd_lte(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_next_best_prob_mtd_lte(object), err_msg) }) ## v_next_best_prob_mtd_min_dist ---- test_that("v_next_best_prob_mtd_min_dist passes for valid object", { object <- NextBestProbMTDMinDist(0.3) expect_true(v_next_best_prob_mtd_min_dist(object)) }) test_that("v_next_best_prob_mtd_min_dist returns message for non-valid target", { err_msg <- "target must be a probability value from (0, 1) interval" object <- NextBestProbMTDMinDist(0.3) # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_next_best_prob_mtd_min_dist(object), err_msg) object@target <- 0 expect_equal(v_next_best_prob_mtd_min_dist(object), err_msg) object@target <- -0.5 expect_equal(v_next_best_prob_mtd_min_dist(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_next_best_prob_mtd_min_dist(object), err_msg) }) # Increments ---- ## v_increments_relative ---- test_that("v_increments_relative passes for valid object", { object <- IncrementsRelative(intervals = c(0, 2), increments = c(2, 1)) expect_true(v_increments_relative(object)) }) test_that("v_increments_relative returns message for non-valid intervals", { err_msg <- "intervals has to be a numerical vector with unique, finite, non-negative and sorted non-missing values" object <- IncrementsRelative( intervals = c(0, 2, 3), increments = c(2, 1, 1.5) ) # Changing `intervals` so that it contains non-unique values. object@intervals <- c(1, 2, 2) expect_equal(v_increments_relative(object), err_msg) # Changing `intervals` so that it contains non-sorted values. object@intervals <- c(1, 3, 2) expect_equal(v_increments_relative(object), err_msg) # Changing `intervals` so that it contains missing, or infinite negative values. object@intervals <- c(-1, NA, 2, Inf) object@increments <- 1:4 expect_equal(v_increments_relative(object), err_msg) }) test_that("v_increments_relative returns message for non-valid increments", { err_msg <- "increments has to be a numerical vector of the same length as `intervals` with finite values" object <- IncrementsRelative( intervals = c(0, 2, 3), increments = c(2, 1, 1.5) ) # Changing `increments` so that it is of a length different than the length of `intervals`. object@increments <- c(1, 2, 3, 4) expect_equal(v_increments_relative(object), err_msg) # Changing `increments` so that it contains missing, or infinite values. object@increments <- c(NA, 2, Inf) expect_equal(v_increments_relative(object), err_msg) }) ## v_increments_relative_parts ---- test_that("v_increments_relative_parts passes for valid object", { object <- IncrementsRelativeParts(dlt_start = -1L, clean_start = 3L) expect_true(v_increments_relative_parts(object)) }) test_that("v_increments_relative_parts returns message for non-valid dlt_start", { err_msg <- "dlt_start must be an integer number" object <- IncrementsRelativeParts(dlt_start = -1L, clean_start = 3L) # Changing `dlt_start` so that it not a scalar. object@dlt_start <- c(1L, 2L) expect_equal(v_increments_relative_parts(object), err_msg) # Changing `dlt_start` so that it is a missing object. object@dlt_start <- NA_integer_ expect_equal(v_increments_relative_parts(object), err_msg) }) test_that("v_increments_relative_parts returns message for non-valid clean_start", { err_msg <- "clean_start must be an integer number and it must be >= dlt_start" object <- IncrementsRelativeParts(dlt_start = -1L, clean_start = 1L) # Changing `clean_start` so that it not a scalar. object@clean_start <- c(1L, 2L) expect_equal(v_increments_relative_parts(object), err_msg) # Changing `clean_start` so that it is a missing object. object@clean_start <- NA_integer_ expect_equal(v_increments_relative_parts(object), err_msg) # Changing `clean_start` so that it is less than `dlt_start`. object@clean_start <- -2L expect_equal(v_increments_relative_parts(object), err_msg) }) ## v_increments_relative_dlt ---- test_that("v_increments_relative_dlt passes for valid object", { object <- IncrementsRelativeDLT(intervals = c(0, 2), increments = c(2, 1)) expect_true(v_increments_relative_dlt(object)) }) test_that("v_increments_relative_dlt returns message for non-valid intervals", { err_msg <- "intervals has to be an integer vector with unique, finite, non-negative and sorted non-missing values" object <- IncrementsRelativeDLT( intervals = c(0, 2, 3), increments = c(2, 1, 1.5) ) # Changing `intervals` so that it contains non-unique values. object@intervals <- c(1L, 2L, 2L) expect_equal(v_increments_relative_dlt(object), err_msg) # Changing `intervals` so that it contains non-sorted values. object@intervals <- c(1L, 3L, 2L) expect_equal(v_increments_relative_dlt(object), err_msg) # Changing `intervals` so that it contains missing, or negative values. object@intervals <- c(-1L, NA_integer_, 2L) expect_equal(v_increments_relative_dlt(object), err_msg) }) test_that("v_increments_relative_dlt returns message for non-valid increments", { err_msg <- "increments has to be a numerical vector of the same length as `intervals` with finite values" object <- IncrementsRelativeDLT( intervals = c(0, 2, 3), increments = c(2, 1, 1.5) ) # Changing `increments` so that it is of a length different than the length of `intervals`. object@increments <- c(1, 2, 3, 4) expect_equal(v_increments_relative_dlt(object), err_msg) # Changing `increments` so that it contains missing, or infinite values. object@increments <- c(NA, 2, Inf) expect_equal(v_increments_relative_dlt(object), err_msg) }) ## v_increments_dose_levels ---- test_that("v_increments_dose_levels passes for valid object", { object <- IncrementsDoseLevels() expect_true(v_increments_dose_levels(object)) object <- IncrementsDoseLevels(levels = 1, basis_level = "last") expect_true(v_increments_dose_levels(object)) object <- IncrementsDoseLevels(levels = 2, basis_level = "max") expect_true(v_increments_dose_levels(object)) }) test_that("v_increments_dose_levels returns message for non-valid levels", { err_msg <- "levels must be scalar positive integer" object <- IncrementsDoseLevels() # Changing `levels` so that it not a scalar. object@levels <- c(1L, 2L) expect_equal(v_increments_dose_levels(object), err_msg) # Changing `levels` so that it is a missing object. object@levels <- NA_integer_ expect_equal(v_increments_dose_levels(object), err_msg) # Changing `levels` so that it is a negative value. object@levels <- -2L expect_equal(v_increments_dose_levels(object), err_msg) }) test_that("v_increments_dose_levels returns message for non-valid basis_level", { err_msg <- "basis_level must be either 'last' or 'max'" object <- IncrementsDoseLevels() # Changing `basis_level` so that it is neither equal to 'last' nor 'max' object@basis_level <- "last " expect_equal(v_increments_dose_levels(object), err_msg) object@basis_level <- " max " expect_equal(v_increments_dose_levels(object), err_msg) object@basis_level <- c("last", "max") expect_equal(v_increments_dose_levels(object), err_msg) }) ## v_increments_hsr_beta ---- test_that("v_increments_hsr_beta passes for valid object", { object <- IncrementsHSRBeta(target = 0.3, prob = 0.95) expect_true(v_increments_hsr_beta(object)) object <- IncrementsHSRBeta(target = 0.2, prob = 0.9, a = 7, b = 3) expect_true(v_increments_hsr_beta(object)) }) test_that("v_increments_hsr_beta returns expected messages for non-valid target", { err_msg <- "target must be a probability value from (0, 1) interval" object <- IncrementsHSRBeta() # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_increments_hsr_beta(object), err_msg) object@target <- 0 expect_equal(v_increments_hsr_beta(object), err_msg) object@target <- -0.5 expect_equal(v_increments_hsr_beta(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_increments_hsr_beta(object), err_msg) }) test_that("v_increments_hsr_beta returns expected messages for non-valid prob", { err_msg <- "prob must be a probability value from (0, 1) interval" object <- IncrementsHSRBeta() # Changing `prob` so that it does not represent allowed probability value. object@prob <- 1 expect_equal(v_increments_hsr_beta(object), err_msg) object@prob <- 0 expect_equal(v_increments_hsr_beta(object), err_msg) object@prob <- -0.5 expect_equal(v_increments_hsr_beta(object), err_msg) # Changing `prob` so that it is not a scalar. object@prob <- c(0.5, 0.6) expect_equal(v_increments_hsr_beta(object), err_msg) }) test_that("v_increments_hsr_beta returns expected messages for non-valid beta parameters", { err_msg <- c( "Beta distribution shape parameter a must be a positive scalar", "Beta distribution shape parameter b must be a positive scalar" ) object <- IncrementsHSRBeta() # Changing `a` and `b` so that they are not a positive scalars. object@a <- -2 object@b <- 0 expect_equal(v_increments_hsr_beta(object), err_msg) object@a <- c(1, 2) object@b <- c(1, 2) expect_equal(v_increments_hsr_beta(object), err_msg) }) ## v_increments_min ---- test_that("v_increments_min passes for valid object", { object <- IncrementsMin( increments_list = list( IncrementsRelativeDLT(intervals = c(0L, 1L), increments = c(2, 1)), IncrementsRelative(intervals = c(0, 2), increments = c(2, 1)) ) ) expect_true(v_increments_min(object)) }) test_that("v_increments_min returns expected messages for non-valid object", { err_msg <- "all elements in increments_list must be of Increments class" object <- IncrementsMin( increments_list = list( IncrementsRelativeDLT(intervals = c(0L, 1L), increments = c(2, 1)), IncrementsRelative(intervals = c(0, 2), increments = c(2, 1)) ) ) # Changing `increments_list` so that is contains objects other than `Increments`. object@increments_list <- list( IncrementsRelativeDLT(intervals = c(0L, 1L), increments = c(2, 1)), intervals = c(0, 2), increments = c(2, 1) ) expect_equal(v_increments_min(object), err_msg) }) # Stopping ---- ## v_stopping_cohorts_near_dose ---- test_that("v_stopping_cohorts_near_dose passes for valid object", { object <- StoppingCohortsNearDose() expect_true(v_stopping_cohorts_near_dose(object)) object <- StoppingCohortsNearDose(nCohorts = 5L, percentage = 40) expect_true(v_stopping_cohorts_near_dose(object)) object <- StoppingCohortsNearDose(nCohorts = 5L, percentage = 0) expect_true(v_stopping_cohorts_near_dose(object)) object <- StoppingCohortsNearDose(nCohorts = 5L, percentage = 100) expect_true(v_stopping_cohorts_near_dose(object)) }) test_that("v_stopping_cohorts_near_dose returns message for non-valid nCohorts", { err_msg <- "nCohorts must be positive integer scalar" object <- StoppingCohortsNearDose() # Changing `nCohorts` so that it not a scalar. object@nCohorts <- c(1L, 2L) expect_equal(v_stopping_cohorts_near_dose(object), err_msg) # Changing `nCohorts` so that it is NA value. object@nCohorts <- NA_integer_ expect_equal(v_stopping_cohorts_near_dose(object), err_msg) # Changing `nCohorts` so that it is not a positive value. object@nCohorts <- -2L expect_equal(v_stopping_cohorts_near_dose(object), err_msg) }) test_that("v_stopping_cohorts_near_dose returns message for non-valid percentage", { err_msg <- "percentage must be a number between 0 and 100" object <- StoppingCohortsNearDose() # Changing `percentage` so that it not a scalar. object@percentage <- c(1L, 2L) expect_equal(v_stopping_cohorts_near_dose(object), err_msg) # Changing `percentage` so that it is NA value. object@percentage <- NA_integer_ expect_equal(v_stopping_cohorts_near_dose(object), err_msg) # Changing `percentage` so that it is not a percentage. object@percentage <- -1 expect_equal(v_stopping_cohorts_near_dose(object), err_msg) # Changing `percentage` so that it is not a percentage. object@percentage <- 101 expect_equal(v_stopping_cohorts_near_dose(object), err_msg) }) ## v_stopping_patients_near_dose ---- test_that("v_stopping_patients_near_dose passes for valid object", { object <- StoppingPatientsNearDose(nPatients = 10L) expect_true(v_stopping_patients_near_dose(object)) object <- StoppingPatientsNearDose(nPatients = 5L, percentage = 40) expect_true(v_stopping_patients_near_dose(object)) object <- StoppingPatientsNearDose(nPatients = 5L, percentage = 0) expect_true(v_stopping_patients_near_dose(object)) object <- StoppingPatientsNearDose(nPatients = 5L, percentage = 100) expect_true(v_stopping_patients_near_dose(object)) }) test_that("v_stopping_patients_near_dose returns message for non-valid nPatients", { err_msg <- "nPatients must be positive integer scalar" object <- StoppingPatientsNearDose(nPatients = 5L) # Changing `nPatients` so that it not a scalar. object@nPatients <- c(1L, 2L) expect_equal(v_stopping_patients_near_dose(object), err_msg) # Changing `nPatients` so that it is NA value. object@nPatients <- NA_integer_ expect_equal(v_stopping_patients_near_dose(object), err_msg) # Changing `nPatients` so that it is not a positive value. object@nPatients <- -2L expect_equal(v_stopping_patients_near_dose(object), err_msg) }) test_that("v_stopping_patients_near_dose returns message for non-valid percentage", { err_msg <- "percentage must be a number between 0 and 100" object <- StoppingPatientsNearDose(nPatients = 5L) # Changing `percentage` so that it not a scalar. object@percentage <- c(1L, 2L) expect_equal(v_stopping_patients_near_dose(object), err_msg) # Changing `percentage` so that it is NA value. object@percentage <- NA_integer_ expect_equal(v_stopping_patients_near_dose(object), err_msg) # Changing `percentage` so that it is not a percentage. object@percentage <- -1 expect_equal(v_stopping_patients_near_dose(object), err_msg) # Changing `percentage` so that it is not a percentage. object@percentage <- 101 expect_equal(v_stopping_patients_near_dose(object), err_msg) }) ## v_stopping_min_cohorts ---- test_that("v_stopping_min_cohorts passes for valid object", { object <- StoppingMinCohorts(nCohorts = 5L) expect_true(v_stopping_min_cohorts(object)) }) test_that("v_stopping_min_cohorts returns message for non-valid nCohorts", { err_msg <- "nCohorts must be positive integer scalar" object <- StoppingMinCohorts(nCohorts = 5L) # Changing `nCohorts` so that it not a scalar. object@nCohorts <- c(1L, 2L) expect_equal(v_stopping_min_cohorts(object), err_msg) # Changing `nCohorts` so that it is NA value. object@nCohorts <- NA_integer_ expect_equal(v_stopping_min_cohorts(object), err_msg) # Changing `nCohorts` so that it is not a positive value. object@nCohorts <- -2L expect_equal(v_stopping_min_cohorts(object), err_msg) }) ## v_stopping_min_patients ---- test_that("v_stopping_min_patients passes for valid object", { object <- StoppingMinPatients(nPatients = 5L) expect_true(v_stopping_min_patients(object)) }) test_that("v_stopping_min_patients returns message for non-valid nPatients", { err_msg <- "nPatients must be positive integer scalar" object <- StoppingMinPatients(nPatients = 5L) # Changing `nPatients` so that it not a scalar. object@nPatients <- c(1L, 2L) expect_equal(v_stopping_min_patients(object), err_msg) # Changing `nPatients` so that it is NA value. object@nPatients <- NA_integer_ expect_equal(v_stopping_min_patients(object), err_msg) # Changing `nPatients` so that it is not a positive value. object@nPatients <- -2L expect_equal(v_stopping_min_patients(object), err_msg) }) ## v_stopping_target_prob ---- test_that("v_stopping_target_prob passes for valid object", { object <- StoppingTargetProb(target = c(0.2, 0.35), prob = 0.4) expect_true(v_stopping_target_prob(object)) object <- StoppingTargetProb(target = c(0, 1), prob = 0.4) expect_true(v_stopping_target_prob(object)) }) test_that("v_stopping_target_prob returns message for non-valid target", { err_msg <- "target has to be a probability range" object <- StoppingTargetProb(target = c(0.2, 0.35), prob = 0.4) # Changing `target` so that it is not an interval. object@target <- 0.6 expect_equal(v_stopping_target_prob(object), err_msg) object@target <- c(0.5, 0.6, 0.8) expect_equal(v_stopping_target_prob(object), err_msg) object@target <- c(0.8, 0.6) expect_equal(v_stopping_target_prob(object), err_msg) # Changing `target` so that one bound is not a valid probability value. object@target <- c(0.4, 1.2) expect_equal(v_stopping_target_prob(object), err_msg) }) test_that("v_stopping_target_prob returns message for non-valid prob", { err_msg <- "prob must be a probability value from (0, 1) interval" object <- StoppingTargetProb(target = c(0.2, 0.35), prob = 0.4) # Changing `prob` so that it does not represent allowed probability value. object@prob <- 1 expect_equal(v_stopping_target_prob(object), err_msg) object@prob <- 0 expect_equal(v_stopping_target_prob(object), err_msg) object@prob <- -0.5 expect_equal(v_stopping_target_prob(object), err_msg) # Changing `prob` so that it is not a scalar. object@prob <- c(0.5, 0.6) expect_equal(v_stopping_target_prob(object), err_msg) }) ## v_stopping_mtd_distribution ---- test_that("v_stopping_mtd_distribution passes for valid object", { object <- StoppingMTDdistribution(target = 0.33, thresh = 0.5, prob = 0.9) expect_true(v_stopping_mtd_distribution(object)) }) test_that("v_stopping_mtd_distribution returns message for non-valid target", { err_msg <- "target must be a probability value from (0, 1) interval" object <- StoppingMTDdistribution(target = 0.33, thresh = 0.5, prob = 0.9) # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_stopping_mtd_distribution(object), err_msg) object@target <- 0 expect_equal(v_stopping_mtd_distribution(object), err_msg) object@target <- -0.5 expect_equal(v_stopping_mtd_distribution(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_stopping_mtd_distribution(object), err_msg) }) test_that("v_stopping_mtd_distribution returns message for non-valid thresh", { err_msg <- "thresh must be a probability value from (0, 1) interval" object <- StoppingMTDdistribution(target = 0.33, thresh = 0.5, prob = 0.9) # Changing `thresh` so that it does not represent allowed probability value. object@thresh <- 1 expect_equal(v_stopping_mtd_distribution(object), err_msg) object@thresh <- 0 expect_equal(v_stopping_mtd_distribution(object), err_msg) object@thresh <- -0.5 expect_equal(v_stopping_mtd_distribution(object), err_msg) # Changing `thresh` so that it is not a scalar. object@thresh <- c(0.5, 0.6) expect_equal(v_stopping_mtd_distribution(object), err_msg) }) test_that("v_stopping_mtd_distribution returns message for non-valid prob", { err_msg <- "prob must be a probability value from (0, 1) interval" object <- StoppingMTDdistribution(target = 0.33, thresh = 0.5, prob = 0.9) # Changing `prob` so that it does not represent allowed probability value. object@prob <- 1 expect_equal(v_stopping_mtd_distribution(object), err_msg) object@prob <- 0 expect_equal(v_stopping_mtd_distribution(object), err_msg) object@prob <- -0.5 expect_equal(v_stopping_mtd_distribution(object), err_msg) # Changing `prob` so that it is not a scalar. object@prob <- c(0.5, 0.6) expect_equal(v_stopping_mtd_distribution(object), err_msg) }) ## v_stopping_mtd_cv ---- test_that("v_stopping_mtd_cv passes for valid object", { object <- StoppingMTDCV(target = 0.3, thresh_cv = 30) expect_true(v_stopping_mtd_cv(object)) object <- StoppingMTDCV(target = 0.3, thresh_cv = 100) expect_true(v_stopping_mtd_cv(object)) }) test_that("v_stopping_mtd_cv returns message for non-valid target", { err_msg <- "target must be probability value from (0, 1) interval" object <- StoppingMTDCV(target = 0.3, thresh_cv = 30) # Changing `target` so that it does not represent allowed probability value. object@target <- 1 expect_equal(v_stopping_mtd_cv(object), err_msg) object@target <- 0 expect_equal(v_stopping_mtd_cv(object), err_msg) object@target <- -0.5 expect_equal(v_stopping_mtd_cv(object), err_msg) # Changing `target` so that it is not a scalar. object@target <- c(0.5, 0.6) expect_equal(v_stopping_mtd_cv(object), err_msg) }) test_that("v_stopping_mtd_cv returns message for non-valid thresh_cv", { err_msg <- "thresh_cv must be percentage > 0" object <- StoppingMTDCV(target = 0.3, thresh_cv = 30) # Changing `thresh_cv` so that it not a scalar. object@thresh_cv <- c(1L, 2L) expect_equal(v_stopping_mtd_cv(object), err_msg) # Changing `thresh_cv` so that it is NA value. object@thresh_cv <- NA_integer_ expect_equal(v_stopping_mtd_cv(object), err_msg) # Changing `thresh_cv` so that it is not a thresh_cv. object@thresh_cv <- -1 expect_equal(v_stopping_mtd_cv(object), err_msg) object@thresh_cv <- 0 expect_equal(v_stopping_mtd_cv(object), err_msg) object@thresh_cv <- 101 expect_equal(v_stopping_mtd_cv(object), err_msg) }) ## v_stopping_target_biomarker ---- test_that("v_stopping_target_biomarker passes for valid object", { object <- StoppingTargetBiomarker(c(0.85, 1), 0.4) expect_true(v_stopping_target_biomarker(object)) object <- StoppingTargetBiomarker(c(0, 0.6), 0.4) expect_true(v_stopping_target_biomarker(object)) object <- StoppingTargetBiomarker(c(2, 3), 0.4, FALSE) expect_true(v_stopping_target_biomarker(object)) }) test_that("v_stopping_target_biomarker returns expected messages for non-valid target (relative)", { err_msg <- "target has to be a probability range when is_relative flag is 'TRUE'" object <- StoppingTargetBiomarker(c(0.85, 1), 0.4) # Changing `target` so that it is not an interval. object@target <- 0.6 expect_equal(v_stopping_target_biomarker(object), err_msg) object@target <- c(0.5, 0.6, 0.8) expect_equal(v_stopping_target_biomarker(object), err_msg) object@target <- c(0.8, 0.6) expect_equal(v_stopping_target_biomarker(object), err_msg) # Changing `target` so that one bound is not a valid probability value. object@target <- c(0.4, 1.2) expect_equal(v_stopping_target_biomarker(object), err_msg) }) test_that("v_stopping_target_biomarker returns expected messages for non-valid target (absolute)", { err_msg <- "target must be a numeric range" object <- StoppingTargetBiomarker(c(0.85, 1), 0.4, FALSE) # Changing `target` so that it is not an interval. object@target <- 0.6 expect_equal(v_stopping_target_biomarker(object), err_msg) object@target <- c(0.5, 0.6, 0.8) expect_equal(v_stopping_target_biomarker(object), err_msg) object@target <- c(0.8, 0.6) expect_equal(v_stopping_target_biomarker(object), err_msg) }) test_that("v_stopping_target_biomarker returns expected messages for non-valid is_relative", { err_msg <- "is_relative must be a flag" object <- StoppingTargetBiomarker(c(0.85, 1), 0.4) # Changing `is_relative` so that it is not a flag. object@is_relative <- c(TRUE, TRUE) expect_equal(v_stopping_target_biomarker(object), err_msg) object@is_relative <- c(TRUE, FALSE) expect_equal(v_stopping_target_biomarker(object), err_msg) }) test_that("v_stopping_target_biomarker returns expected messages for non-valid prob", { err_msg <- "prob must be a probability value from (0, 1) interval" object <- StoppingTargetBiomarker(c(0.85, 1), 0.4) # Changing `prob` so that it does not represent allowed probability value. object@prob <- 1 expect_equal(v_stopping_target_biomarker(object), err_msg) object@prob <- 0 expect_equal(v_stopping_target_biomarker(object), err_msg) object@prob <- -0.5 expect_equal(v_stopping_target_biomarker(object), err_msg) # Changing `prob` so that it is not a scalar. object@prob <- c(0.5, 0.6) expect_equal(v_stopping_target_biomarker(object), err_msg) }) ## v_stopping_list ---- test_that("v_stopping_list passes for valid object", { object <- h_stopping_list() expect_true(v_stopping_list(object)) }) test_that("v_stopping_list returns expected messages for non-valid stop_list", { err_msg <- "every stop_list element must be of class 'Stopping'" object <- h_stopping_list() # Changing `stop_list` so that not all of its elements are of class `Stopping`. object@stop_list <- list(object@stop_list[[1]], TRUE) expect_equal(v_stopping_list(object), err_msg) object@stop_list <- list(FALSE, TRUE) expect_equal(v_stopping_list(object), err_msg) }) test_that("v_stopping_list returns expected messages for non-valid summary (args)", { err_msg <- "summary must be a function that accepts a single argument, without ..." object <- h_stopping_list() # Changing `summary` so that it has more than 1 or no arguments. object@summary <- function(x, y) { TRUE } expect_equal(v_stopping_list(object), err_msg) object@summary <- function() { TRUE } expect_equal(v_stopping_list(object), err_msg) object@summary <- function(...) { TRUE } expect_equal(v_stopping_list(object), err_msg) }) test_that("v_stopping_list returns expected messages for non-valid summary (output)", { err_msg <- "summary must accept a logical vector of the same length as 'stop_list' and return a boolean value" object <- h_stopping_list() # Changing `summary` so that it does not return a flag. object@summary <- function(x) { c(TRUE, FALSE) } expect_equal(v_stopping_list(object), err_msg) object@summary <- function(x) { c(TRUE, FALSE, TRUE) } expect_equal(v_stopping_list(object), err_msg) }) ## v_stopping_all ---- test_that("v_stopping_all passes for valid object", { object <- StoppingAll( stop_list = list( StoppingMinCohorts(nCohorts = 3), StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5), StoppingMinPatients(nPatients = 20) ) ) expect_true(v_stopping_all(object)) }) test_that("v_stopping_all returns expected messages for non-valid stop_list", { err_msg <- "every stop_list element must be of class 'Stopping'" object <- StoppingAll( stop_list = list( StoppingMinCohorts(nCohorts = 3), StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5), StoppingMinPatients(nPatients = 20) ) ) # Changing `stop_list` so that not all of its elements are of class `Stopping`. object@stop_list <- list(object@stop_list[[1]], TRUE) expect_equal(v_stopping_all(object), err_msg) object@stop_list <- list(FALSE, TRUE) expect_equal(v_stopping_all(object), err_msg) }) ## v_stopping_tdci_ratio ---- test_that("v_stopping_tdci_ratio passes for valid object", { object <- StoppingTDCIRatio(target_ratio = 7, prob_target = 0.2) expect_true(v_stopping_tdci_ratio(object)) object <- StoppingTDCIRatio(target_ratio = 0.2, prob_target = 0) expect_true(v_stopping_tdci_ratio(object)) object <- StoppingTDCIRatio(target_ratio = 6, prob_target = 1) expect_true(v_stopping_tdci_ratio(object)) }) test_that("v_stopping_tdci_ratio returns message for non-valid target_ratio", { err_msg <- "target_ratio must be a positive number" object <- StoppingTDCIRatio(target_ratio = 7, prob_target = 0.2) # Changing `target_ratio` so that it does not a positive number. object@target_ratio <- -0.5 expect_equal(v_stopping_tdci_ratio(object), err_msg) object@target_ratio <- 0 expect_equal(v_stopping_tdci_ratio(object), err_msg) # Changing `target_ratio` so that it is not a scalar. object@target_ratio <- c(0.5, 0.6) expect_equal(v_stopping_tdci_ratio(object), err_msg) }) test_that("v_stopping_tdci_ratio returns message for non-valid prob_target", { err_msg <- "prob_target must be a probability value from [0, 1] interval" object <- StoppingTDCIRatio(target_ratio = 7, prob_target = 0.2) # Changing `prob_target` so that it does not represent allowed probability value. object@prob_target <- 2 expect_equal(v_stopping_tdci_ratio(object), err_msg) object@prob_target <- -0.5 expect_equal(v_stopping_tdci_ratio(object), err_msg) # Changing `prob_target` so that it is not a scalar. object@prob_target <- c(0.5, 0.6) expect_equal(v_stopping_tdci_ratio(object), err_msg) }) # CohortSize ---- ## v_cohort_size_range ---- test_that("v_cohort_size_range passes for valid object", { object <- CohortSizeRange(0, 20) expect_true(v_cohort_size_range(object)) object <- CohortSizeRange(c(0, 30), c(20, 60)) expect_true(v_cohort_size_range(object)) object <- CohortSizeRange(c(20, 40, 90), c(50, 160, 400)) expect_true(v_cohort_size_range(object)) }) test_that("v_cohort_size_range returns message for non-valid intervals", { err_msg <- "intervals must be a numeric vector with non-negative, sorted (asc.) and unique values" object <- CohortSizeRange(c(0, 30), c(20, 60)) # Changing `intervals` so that it contains a non-unique values object@intervals <- c(10, 10) expect_equal(v_cohort_size_range(object), err_msg) # Changing `intervals` so that it contains not allowed elements or it is not sorted. object@intervals <- c(0, -30) expect_equal(v_cohort_size_range(object), err_msg) object@intervals <- c(20, Inf) expect_equal(v_cohort_size_range(object), err_msg) object@intervals <- c(NA, 30) expect_equal(v_cohort_size_range(object), err_msg) object@intervals <- -0.5 object@cohort_size <- 20L expect_equal(v_cohort_size_range(object), err_msg) # Changing `intervals` so that its length is not >= 1. object@intervals <- numeric(0) object@cohort_size <- integer(0) expect_equal(v_cohort_size_range(object), err_msg) }) test_that("v_cohort_size_range returns message for non-valid cohort_size", { errmsg <- "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only" object <- CohortSizeRange(c(0, 30), c(20, 60)) # Changing `cohort_size` so that its length is not equal to the length of `intervals`. object@cohort_size <- c(20L, 60L, 90L) expect_equal(v_cohort_size_range(object), errmsg) # Changing `cohort_size` so that it contains not allowed elements. object@cohort_size <- c(0L, -30L) expect_equal(v_cohort_size_range(object), errmsg) object@cohort_size <- c(NA, 30L) expect_equal(v_cohort_size_range(object), errmsg) object@cohort_size <- -20L object@intervals <- 0 expect_equal(v_cohort_size_range(object), errmsg) }) ## v_cohort_size_dlt ---- test_that("v_cohort_size_dlt passes for valid object", { object <- CohortSizeDLT(0, 20) expect_true(v_cohort_size_dlt(object)) object <- CohortSizeDLT(c(0, 1), c(20, 60)) expect_true(v_cohort_size_dlt(object)) object <- CohortSizeDLT(c(0, 1, 3), c(50, 160, 400)) expect_true(v_cohort_size_dlt(object)) }) test_that("v_cohort_size_dlt returns message for non-valid intervals", { err_msg <- "intervals must be an integer vector with non-negative, sorted (asc.) and unique values" object <- CohortSizeDLT(c(0, 1), c(20, 60)) # Changing `intervals` so that it contains a non-unique values object@intervals <- c(10L, 10L) expect_equal(v_cohort_size_dlt(object), err_msg) # Changing `intervals` so that it contains not allowed elements or it is not sorted. object@intervals <- c(0L, -30L) expect_equal(v_cohort_size_dlt(object), err_msg) object@intervals <- c(NA, 30L) expect_equal(v_cohort_size_dlt(object), err_msg) object@intervals <- -5L object@cohort_size <- 20L expect_equal(v_cohort_size_dlt(object), err_msg) # Changing `intervals` so that its length is not >= 1. object@intervals <- integer(0) object@cohort_size <- integer(0) expect_equal(v_cohort_size_dlt(object), err_msg) }) test_that("v_cohort_size_dlt returns message for non-valid cohort_size", { errmsg <- "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only" object <- CohortSizeDLT(c(0, 1), c(20, 60)) # Changing `cohort_size` so that its length is not equal to the length of `intervals`. object@cohort_size <- c(20L, 60L, 90L) expect_equal(v_cohort_size_dlt(object), errmsg) # Changing `cohort_size` so that it contains not allowed elements. object@cohort_size <- c(0L, -30L) expect_equal(v_cohort_size_dlt(object), errmsg) object@cohort_size <- c(NA, 30L) expect_equal(v_cohort_size_dlt(object), errmsg) object@cohort_size <- -20L object@intervals <- 0L expect_equal(v_cohort_size_dlt(object), errmsg) }) ## v_cohort_size_const ---- test_that("v_cohort_size_const passes for valid object", { object <- CohortSizeConst(0) expect_true(v_cohort_size_const(object)) object <- CohortSizeConst(5) expect_true(v_cohort_size_const(object)) }) test_that("v_cohort_size_const returns message for non-valid size", { err_msg <- "size needs to be a non-negative scalar" object <- CohortSizeConst(5) # Changing `size` so that it is not allowed value. object@size <- -(5L) expect_equal(v_cohort_size_const(object), err_msg) object@size <- NA_integer_ expect_equal(v_cohort_size_const(object), err_msg) # Changing `size` so that it is not a scalar. object@size <- c(2L, 4L) expect_equal(v_cohort_size_const(object), err_msg) }) ## v_cohort_size_parts ---- test_that("v_cohort_size_parts passes for valid object", { object <- CohortSizeParts(c(1, 4)) expect_true(v_cohort_size_parts(object)) object <- CohortSizeParts(c(9, 4)) expect_true(v_cohort_size_parts(object)) }) test_that("v_cohort_size_parts returns message for non-valid cohort_sizes", { err_msg <- "cohort_sizes needs to be an integer vector of length 2 with all elements positive" object <- CohortSizeParts(c(1L, 4L)) # Changing `cohort_sizes` so that it is not of length 2. object@cohort_sizes <- c(1L, 4L, 7L) expect_equal(v_cohort_size_parts(object), err_msg) object@cohort_sizes <- 2L expect_equal(v_cohort_size_parts(object), err_msg) object@cohort_sizes <- integer(0) expect_equal(v_cohort_size_parts(object), err_msg) # Changing `cohort_sizes` so that it contains not allowed elements. object@cohort_sizes <- c(0L, 4L) expect_equal(v_cohort_size_parts(object), err_msg) object@cohort_sizes <- c(1L, -30L) expect_equal(v_cohort_size_parts(object), err_msg) object@cohort_sizes <- c(NA, 30L) expect_equal(v_cohort_size_parts(object), err_msg) object@cohort_sizes <- -20L expect_equal(v_cohort_size_parts(object), err_msg) }) ## v_cohort_size_max ---- test_that("v_cohort_size_max passes for valid object", { object <- CohortSizeMax(h_cohort_sizes()) expect_true(v_cohort_size_max(object)) object <- CohortSizeMax(h_cohort_sizes(three_rules = TRUE)) expect_true(v_cohort_size_max(object)) }) test_that("v_cohort_size_parts returns message for non-valid sizes", { err_msg <- "cohort_sizes must be a list of CohortSize (unique) objects only and be of length >= 2" cohort_sizes <- h_cohort_sizes() object <- CohortSizeMax(cohort_sizes) # Changing `cohort_sizes` so that it does not contain `CohortSize` objects only. object@cohort_sizes <- list(3, 5) expect_equal(v_cohort_size_max(object), err_msg) object@cohort_sizes <- list(cohort_sizes[[1]], 5L) expect_equal(v_cohort_size_max(object), err_msg) object@cohort_sizes <- list(cohort_sizes[[1]], NA) expect_equal(v_cohort_size_max(object), err_msg) object@cohort_sizes <- list() expect_equal(v_cohort_size_max(object), err_msg) # Changing `cohort_sizes` so that it contains non-unique `CohortSize` objects. object@cohort_sizes <- list(cohort_sizes[[1]], cohort_sizes[[1]]) expect_equal(v_cohort_size_max(object), err_msg) # Changing `cohort_sizes` so that it is not of length >=2. object@cohort_sizes <- list(cohort_sizes[[1]]) expect_equal(v_cohort_size_max(object), err_msg) }) # SafetyWindowSize ---- ## v_safety_window_size ---- test_that("v_safety_window_size passes for valid object", { object <- h_safety_window_size() expect_true(v_safety_window_size(object)) object <- h_safety_window_size(three_cohorts = TRUE) expect_true(v_safety_window_size(object)) }) test_that("v_safety_window_size returns message for non-valid gap", { err_msg1 <- "gap must be a list of length >= 1 with integer vectors only" err_msg2 <- "every element in gap list has to be an integer vector with non-negative and non-missing values" object <- h_safety_window_size() # Changing `gap` so that it not a list of integers. object@gap <- c(object@gap[-2], list(c(4, 6))) expect_equal(v_safety_window_size(object), c(err_msg1, err_msg2)) # Changing `gap` so that it not a list of non-negative integers. object@gap <- c(object@gap[-2], list(c(4L, -(5L)))) expect_equal(v_safety_window_size(object), c(err_msg2)) object@gap <- c(object@gap[-2], list(integer(0))) expect_equal(v_safety_window_size(object), c(err_msg2)) object@gap <- c(object@gap[-2], list(NA_integer_)) expect_equal(v_safety_window_size(object), c(err_msg2)) # Changing `gap` so that it not a list of length >= 1. object@gap <- list() object@size <- integer() expect_equal(v_safety_window_size(object), err_msg1) }) test_that("v_safety_window_size returns message for non-valid size", { err_msg <- "size has to be an integer vector, of the same length as gap, with positive, unique and sorted non-missing values" # nolinter object <- h_safety_window_size() # Changing `size` so that it contains not allowed elements. object@size <- c(0L, 4L) expect_equal(v_safety_window_size(object), err_msg) object@size <- c(1L, -30L) expect_equal(v_safety_window_size(object), err_msg) object@size <- c(NA, 30L) expect_equal(v_safety_window_size(object), err_msg) object@size <- c(2L, 1L) expect_equal(v_safety_window_size(object), err_msg) object@size <- c(1L, 1L) expect_equal(v_safety_window_size(object), err_msg) # Changing `size` so that it not of the same length as `gap`. object@size <- 1L expect_equal(v_safety_window_size(object), err_msg) }) test_that("v_safety_window_size returns message for non-valid follow", { err_msg <- "follow has to be a positive integer number" object <- h_safety_window_size() # Changing `follow` so that it is not a valid integer scalar. object@follow <- 0L expect_equal(v_safety_window_size(object), err_msg) object@follow <- -1L expect_equal(v_safety_window_size(object), err_msg) object@follow <- c(1L, 2L) expect_equal(v_safety_window_size(object), err_msg) object@follow <- NA_integer_ expect_equal(v_safety_window_size(object), err_msg) }) test_that("v_safety_window_size returns message for non-valid follow_min", { err_msg <- "follow_min has to be a positive integer number" object <- h_safety_window_size() # Changing `follow_min` so that it is not a valid integer scalar. object@follow_min <- 0L expect_equal(v_safety_window_size(object), err_msg) object@follow_min <- -1L expect_equal(v_safety_window_size(object), err_msg) object@follow_min <- c(1L, 2L) expect_equal(v_safety_window_size(object), err_msg) object@follow_min <- NA_integer_ expect_equal(v_safety_window_size(object), err_msg) }) # SafetyWindowConst ---- ## v_safety_window_const ---- test_that("v_safety_window_const passes for valid object", { object <- SafetyWindowConst(8, 2, 18) expect_true(v_safety_window_const(object)) object <- SafetyWindowConst(0, 2, 18) expect_true(v_safety_window_const(object)) object <- SafetyWindowConst(c(2, 5), 2, 18) expect_true(v_safety_window_const(object)) }) test_that("v_safety_window_const returns message for non-valid gap", { err_msg <- "gap has to be an integer vector with non-negative and non-missing elements" object <- SafetyWindowConst(8, 2, 18) # Changing `gap` so that it is not a valid integer scalar. object@gap <- -1L expect_equal(v_safety_window_const(object), err_msg) object@gap <- c(1L, -2L) expect_equal(v_safety_window_const(object), err_msg) object@gap <- NA_integer_ expect_equal(v_safety_window_const(object), err_msg) object@gap <- c(2L, NA_integer_) expect_equal(v_safety_window_const(object), err_msg) }) test_that("v_safety_window_const returns message for non-valid follow", { err_msg <- "follow has to be a positive integer number" object <- SafetyWindowConst(8, 2, 18) # Changing `follow` so that it is not a valid integer scalar. object@follow <- 0L expect_equal(v_safety_window_const(object), err_msg) object@follow <- -1L expect_equal(v_safety_window_const(object), err_msg) object@follow <- c(1L, 2L) expect_equal(v_safety_window_const(object), err_msg) object@follow <- NA_integer_ expect_equal(v_safety_window_const(object), err_msg) }) test_that("v_safety_window_const returns message for non-valid follow_min", { err_msg <- "follow_min has to be a positive integer number" object <- SafetyWindowConst(8, 2, 18) # Changing `follow_min` so that it is not a valid integer scalar. object@follow_min <- 0L expect_equal(v_safety_window_const(object), err_msg) object@follow_min <- -1L expect_equal(v_safety_window_const(object), err_msg) object@follow_min <- c(1L, 2L) expect_equal(v_safety_window_const(object), err_msg) object@follow_min <- NA_integer_ expect_equal(v_safety_window_const(object), err_msg) }) test_that("v_increments_maxtoxprob validates correctly", { expect_no_error({ x <- IncrementsMaxToxProb(c("DLAE" = 0.3, "DLT" = 0.1)) }) expect_error({ x <- IncrementsMaxToxProb(NA) }) expect_error({ x <- IncrementsMaxToxProb(c(0.3, NA)) }) expect_error({ x <- IncrementsMaxToxProb(c(-1, 0.2)) }) expect_error({ x <- IncrementsMaxToxProb(c(0.2, 3)) }) }) test_that("v_nextbest_ordinal validates correctly", { expect_no_error({ x <- NextBestOrdinal( grade = 1L, rule = NextBestMTD(target = 0.3, derive = mean) ) }) expect_error( { x <- NextBestOrdinal( grade = pi, rule = NextBestMTD(target = 0.3, derive = mean) ) }, "grade must be a positive integer" ) expect_error( { x <- NextBestOrdinal( grade = -2, rule = NextBestMTD(target = 0.3, derive = mean) ) }, "grade must be a positive integer" ) expect_error( { x <- NextBestOrdinal(grade = 1L, rule = CohortSizeConst(3)) }, paste0( "invalid class \"NextBestOrdinal\" object: invalid object for slot \"rule\"", " in class \"NextBestOrdinal\": got class \"CohortSizeConst\", should be or ", "extend class \"NextBest\"" ) ) })