tests/testthat/test-basket_test.R

In lbau7/baskexact: Analytical Calculation of Basket Trial Operating Characteristics

test_that("basket_test works", {
  ## Without Pruning
  # Reproduced from Fujikawa et al., 2020, Supplement R Code
  design <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  res1 <- basket_test(design = design, n = 24, r = c(5, 3, 8), lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = exp(1), prune = FALSE))

  # Test if weights are correct
  weights_exp <- c(0.7750081, 0.6661536, 0.3430768)
  weights <- res1$weights[rbind(c(1, 2), c(3, 1), c(3, 2))]
  expect_equal(weights, weights_exp, tolerance = 10e-7)

  # Test if posterior distributions are correct
  shape_exp <- c(15.09542, 48.37479, 11.73774, 43.33247,
    14.36923, 37.87076)
  shape <- as.vector(res1$post_dist_borrow)
  expect_equal(shape, shape_exp, tolerance = 10e-7)

  # Test if posterior probabilities are correct
  prob_exp <- c(0.7524369, 0.5703997, 0.8941389)
  prob <- as.vector(res1$post_prob_borrow)
  expect_equal(prob, prob_exp, tolerance = 10e-7)

  ## With Pruning
  design <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  res2 <- basket_test(design = design, n = 24, r = c(4, 4, 5), lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = exp(1), prune = TRUE))

  # Results are equal when all baskets are pruned
  expect_equal(res2$post_dist_noborrow, res2$post_dist_borrow)
  expect_equal(res2$post_prob_noborrow, res2$post_prob_borrow)

  # With Global Weight
  res3 <- basket_test(design = design, n = 24, r = c(5, 3, 8), lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
      logbase = exp(1), prune = FALSE), globalweight_fun = globalweights_diff,
    globalweight_params = list(eps_global = 2, w = 0.5))

  # Weights are strictly smaller when global weight is used
  expect_true(all(res3$weights[rbind(c(1, 2), c(3, 1), c(3, 2))] <
    res1$weights[rbind(c(1, 2), c(3, 1), c(3, 2))]))

  # Without details
  res4 <- basket_test(design = design, n = 24, r = c(5, 3, 8), lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
      logbase = exp(1), prune = FALSE), globalweight_fun = globalweights_diff,
    globalweight_params = list(eps_global = 2, w = 0.5), details = FALSE)

  expect_equal(unname(res3$post_prob_borrow), res4)

  # Works with 4 baskets
  design4 <- setupOneStageBasket(k = 4, p0 = 0.15)
  r1 <- c(3, 3, 6, 9)
  res5 <- basket_test(design = design4, n = 15, r = c(3, 3, 6, 9),
    lambda = 0.95, weight_fun = weights_mml)

  s11 <- 1 + sum(res5$weights[1, ] * r1)
  s21 <- 1 + sum(res5$weights[1, ] * (15 - r1))
  s12 <- 1 + sum(res5$weights[3, ] * r1)
  s22 <- 1 + sum(res5$weights[3, ] * (15 - r1))

  expect_equal(unname(res5$post_dist_borrow[, 1]), c(s11, s21))
  expect_equal(unname(res5$post_dist_borrow[, 3]), c(s12, s22))
  expect_true(isSymmetric(res5$weights))
  expect_equal(res5$weights[1, ], res5$weights[2, ])

  r2 <- c(7, 5, 1, 10)
  res6 <- basket_test(design = design4, n = 15, r = c(7, 5, 1, 10),
    lambda = 0.95, weight_fun = weights_fujikawa,
    weight_params = list(epsilon = 2, tau = 0.3),
    globalweight_fun = globalweights_fix,
    globalweight_params = list(w = 0.7))

  s13 <- sum(res6$weights[2, ] * (1 + r2))
  s23 <- sum(res6$weights[2, ] * (1 + 15 - r2))
  s14 <- sum(res6$weights[4, ] * (1 + r2))
  s24 <- sum(res6$weights[4, ] * (1 + 15 - r2))

  expect_equal(unname(res6$post_dist_borrow[, 2]), c(s13, s23))
  expect_equal(unname(res6$post_dist_borrow[, 4]), c(s14, s24))
  expect_true(isSymmetric(res6$weights))
})

test_that("errors in basket_test work", {
  design <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)

  expect_error(basket_test(design = design, n = 20, r = c(-1, 10, 10),
    lambda = 0.99, weight_fun = weights_fujikawa, weight_params = list(
    epsilon = 2, tau = 0, logbase = 2, prune = FALSE)))
  expect_error(basket_test(design = design, n = 20, r = c(1, 25, 10),
    lambda = 0.99, weight_fun = weights_fujikawa, weight_params = list(
    epsilon = 2, tau = 0, logbase = 2, prune = FALSE)))
  expect_error(basket_test(design = design, n = 20, r = c(2, 3),
    lambda = 0.99, weight_fun = weights_fujikawa, weight_params = list(
      epsilon = 2, tau = 0, logbase = 2, prune = FALSE)))
})