tests/testthat/test-weights.R

In baskexact: Analytical Calculation of Basket Trial Operating Characteristics

test_that("weight_fujikawa works", {
  # Single-stage design
  # Reproduced from Fujikawa et al., 2020, Supplement R code
  design1 <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  weight_fuj1 <- weights_fujikawa(design = design1, n = 15, epsilon = 2,
    tau = 0, logbase = exp(1), prune = FALSE)
  r <- c(5, 1, 3)
  elmnts <- all_combs <- t(utils::combn(r, 2)) + 1
  weights <- as.vector(weight_fuj1[elmnts])
  weights_exp <- c(0.3206983, 0.7493639, 0.6509846)

  expect_equal(weights, weights_exp, tolerance = 10e-7)
  expect_s3_class(weight_fuj1, "fujikawa")
  expect_true(isSymmetric(unclass(weight_fuj1)))

  # Two-stage design
  design2 <- setupTwoStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  weight_fuj2 <- weights_fujikawa(design = design2, n = 15, n1 = 7, epsilon = 2,
    tau = 0, logbase = exp(1), prune = FALSE)

  expect_s3_class(weight_fuj2, "fujikawa")
  expect_true(isSymmetric(unclass(weight_fuj2)))

  # Compare single-stage and two-stage weight matrices
  expect_equal(unclass(weight_fuj1), weight_fuj2[-(1:8), -(1:8)])
})

test_that("weight_jsd works", {
  # Single-stage design
  design1 <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)

  weight_jsd1 <- weights_jsd(design = design1, n = 15, epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE)
  weight_fujikawa1 <- weights_fujikawa(design = design1, n = 15, epsilon = 2,
    tau = 0, logbase = 2, prune = FALSE)

  # Weight matrix for weight_fujikawa and weight_jsd is identical,
  # only the class differs
  expect_equal(unclass(weight_jsd1), unclass(weight_fujikawa1))
  expect_s3_class(weight_jsd1, "pp")

  # Two-stage design
  design2 <- setupTwoStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)

  weight_jsd3 <- weights_jsd(design = design2, n = 15, n1 = 7, epsilon = 2,
    tau = 0, logbase = 2, prune = FALSE)
  weight_fujikawa3 <- weights_fujikawa(design = design2, n = 15, n1 = 7,
    epsilon = 2, tau = 0, logbase = 2, prune = FALSE)

  expect_equal(unclass(weight_jsd3), unclass(weight_fujikawa3))
  expect_s3_class(weight_jsd3, "pp")

  # Compare single-stage and two-stage weight matrices
  expect_equal(unclass(weight_jsd1), weight_jsd3[-(1:8), -(1:8)])
})

test_that("weight_cpp works", {
  # Single-stage design
  design1 <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  weight_cpp1 <- weights_cpp(design = design1, n = 20, a = 1, b = 1)

  x11 <- c(rep(0, 7), rep(1, 13))
  x21 <- c(rep(0, 3), rep(1, 17))
  sks1 <- as.numeric(ks.test(x11, x21)$statistic)
  s1 <- 20^(1 / 4) * sks1
  w1 <- 1 / (1 + exp(1 + 1 * log(s1)))

  expect_equal(w1, weight_cpp1[14, 18])
  expect_s3_class(weight_cpp1, "pp")
  expect_true(isSymmetric(unclass(weight_cpp1)))

  # Two-stage design
  design2 <- setupTwoStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  weight_cpp2 <- weights_cpp(design = design2, n = 20, n1 = 10, a = 1, b = 1)

  x12 <- c(rep(0, 6), rep(1, 14))
  x22 <- c(rep(0, 8), rep(1, 2))
  sks2 <- as.numeric(ks.test(x12, x22)$statistic)
  s2 <- 20^(1 / 4) * sks2
  w2 <- 1 / (1 + exp(1 + 1 * log(s2)))

  x13 <- c(rep(0, 5), rep(1, 5))
  x23 <- c(rep(0, 8), rep(1, 2))
  sks3 <- as.numeric(ks.test(x13, x23)$statistic)
  s3 <- 10^(1 / 4) * sks3
  w3 <- 1 / (1 + exp(1 + 1 * log(s3)))

  expect_equal(w2, weight_cpp2[26, 3])
  expect_equal(w3, weight_cpp2[6, 3])
  expect_s3_class(weight_cpp2, "pp")
  expect_true(isSymmetric(unclass(weight_cpp2)))

  # Compare single-stage and two-stage weight matrices
  weight_cpp3 <- weights_cpp(design = design1, n = 10, a = 1, b = 1)

  expect_equal(unclass(weight_cpp1), weight_cpp2[-(1:11), -(1:11)])
  expect_equal(unclass(weight_cpp3), weight_cpp2[1:11, 1:11])
})

test_that("weight_mml works", {
  design1 <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  weights_mml1 <- weights_mml(design = design1, n = 20)

  design2 <- setupTwoStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)
  weights_mml2 <- weights_mml(design = design2, n = 20, n1 = 10)

  weights_mml3 <- weights_mml(design = design1, n = 10)

  expect_equal(unclass(weights_mml1), weights_mml2[-(1:11), -(1:11)],
    tolerance = 1e-6)
  expect_equal(unclass(weights_mml3), weights_mml2[1:11, 1:11],
    tolerance = 1e-6)
})

test_that("weight_separate works", {
  # Single-stage design
  design <- setupOneStageBasket(k = 3, p0 = 0.2)

  toer1 <- toer(
    design = design,
    n = 20,
    lambda = 0.99,
    weight_fun = weights_separate,
    results = "group"
  )

  toer2 <- 0
  for (i in 0:20) {
    shape <- data.frame(shape = c(1 + i, 1 + 20 - i))
    rej <- post_beta(shape = shape, p0 = 0.2) >= 0.99
    if (rej) toer2 <- toer2 + get_prob(n = 20, r = i, p = 0.2)
  }

  expect_equal(toer1$rejection_probabilities[1], toer2)

  pow1 <- pow(
    design = design,
    p1 = c(0.5, 0.5, 0.5),
    n = 20,
    lambda = 0.99,
    weight_fun = weights_separate,
    results = "group",
  )

  pow2 <- 0
  for (i in 0:20) {
    shape <- data.frame(shape = c(1 + i, 1 + 20 - i))
    rej <- post_beta(shape = shape, p0 = 0.2) >= 0.99
    if (rej) pow2 <- pow2 + get_prob(n = 20, r = i, p = 0.5)
  }

  expect_equal(pow1$rejection_probabilities[1], pow2)

  ecd <- ecd(
    design = design,
    p1 = c(0.5, 0.5, 0.5),
    n = 20,
    lambda = 0.99,
    weight_fun = weights_separate
  )

  expect_equal(ecd, 3 * pow2)

  estim1 <- estim(
    design = design,
    p1 = c(0.4, 0.4, 0.4),
    n = 20,
    weight_fun = weights_separate
  )

  estim2 <- 0
  mse2 <- 0
  for (i in 0:20) {
    shape <- data.frame(shape = c(1 + i, 1 + 20 - i))
    prob <- get_prob(n = 20, r = i, p = 0.4)
    estim2 <- estim2 + mean_beta(shape) * prob
    mse2 <- mse2 + (mean_beta(shape) - 0.4)^2 * prob
  }

  expect_equal(estim1$Mean[1], as.numeric(estim2))
  expect_equal(estim1$MSE[1], as.numeric(mse2))

  # Two-stage design
  design2 <- setupTwoStageBasket(k = 3, p0 = 0.2)
  toer_2stage1 <- toer(
    design = design2,
    n = 14,
    n1 = 7,
    lambda = 0.99,
    interim_fun = interim_posterior,
    interim_params = list(prob_futstop = 0.1, prob_effstop = 0.9),
    weight_fun = weights_separate,
    results = "group"
  )

  toer_2stage2 <- 0
  for (i in 0:7) {
    shape <- data.frame(shape = c(1 + i, 1 + 7 - i))
    pbeta_int <- post_beta(shape = shape, p0 = 0.2)
    rej_interim <- pbeta_int > 0.9
    stop_interim <- pbeta_int < 0.1
    stop_interim <-
    if (rej_interim) {
      toer_2stage2 <- toer_2stage2 + get_prob(n = 7, r = i, p = 0.2)
    } else if (!rej_interim & !stop_interim) {
      for (j in 0:7) {
        shape <- data.frame(shape = c(1 + i + j, 1 + 14 - i - j))
        rej <- post_beta(shape = shape, p0 = 0.2) >= 0.99
        if (rej) {
          toer_2stage2 <- toer_2stage2 +
          get_prob(n = 7, r = i, p = 0.2) * get_prob(n = 7, r = j, p = 0.2)
        }
      }
    }
  }

  expect_equal(toer_2stage1$rejection_probabilities[1], toer_2stage2)
})

test_that("weight_separate works", {
  design1 <- setupOneStageBasket(k = 3, p0 = 0.2)
  weights1 <- weights_pool(design = design1, n = 10)

  expect_true(all(weights1 == 1))

  design2 <- setupTwoStageBasket(k = 3, p0 = 0.2)
  weights2 <- weights_pool(design = design2, n = 10, n1 = 5)

  expect_true(all(weights2 == 1))
})