tests/testthat/test-monotonicity.R

In baskexact: Analytical Calculation of Basket Trial Operating Characteristics

test_that("check_mon_within works", {
  ## Without Pruning
  design1 <- setupOneStageBasket(k = 4, shape1 = 1, shape2 = 1, p0 = 0.2)

  # One outcome violates the within-trial monotonicity condition
  r1 <- check_mon_within(design = design1, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 0.5, tau = 0,
    logbase = 2, prune = FALSE), details = TRUE)$Events

  # Investigate outcomes with similar responses
  r2 <- r3 <- r4 <- r5 <- r1
  r2[1] <- r2[1] - 1
  r3[2] <- r3[2] + 1
  r4[3] <- r4[3] - 1
  r5[4] <- r5[4] + 1

  weights1 <- weights_fujikawa(design = design1, n = 24, epsilon = 0.5,
    tau = 0, logbase = 2, prune = FALSE)
  res1 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r1,
    weight_mat = weights1, globalweight_fun = NULL)
  res2 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r2,
    weight_mat = weights1, globalweight_fun = NULL)
  res3 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r3,
    weight_mat = weights1, globalweight_fun = NULL)
  res4 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r4,
    weight_mat = weights1, globalweight_fun = NULL)
  res5 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r5,
    weight_mat = weights1, globalweight_fun = NULL)

  expect_true(any(res1 != cummax(res1)))
  expect_false(any(res2 != cummax(res2)))
  expect_false(any(res3 != cummax(res3)))
  expect_false(any(res4 != cummax(res4)))
  expect_false(any(res5 != cummax(res5)))

  # Check condition with no details
  res_nodet1 <- check_mon_within(design = design1, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 0.5, tau = 0,
    logbase = 2, prune = FALSE), details = FALSE)

  expect_false(res_nodet1)

  # Compare with mon_within_loop
  res_loop1 <- mon_within_loop(design = design1, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 0.5, tau = 0,
    logbase = 2, prune = FALSE))

  expect_true(all(r1 == res_loop1))

  ## With Pruning
  r <- check_mon_within(design = design1, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 7, tau = 0,
    logbase = 2, prune = TRUE), details = TRUE)

  # Investigate outcomes with similar responses to first violating outcome
  r6 <- r$Events[1, ]
  r7 <- r8 <- r9 <- r6
  r7[3] <- r7[3] + 1
  r8[4] <- r8[4] - 1
  r9[4] <- r9[4] + 1

  weights2 <- weights_fujikawa(design = design1, n = 24, epsilon = 7, tau = 0,
    logbase = 2, prune = FALSE)
  crit_pool <- get_crit_pool(design = design1, n = 24, lambda = 0.99,
    weight_mat = weights2)
  weights2 <- prune_weights(weights2, cut = crit_pool)

  res6 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r6,
    weight_mat = weights2, globalweight_fun = NULL)
  res7 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r7,
    weight_mat = weights2, globalweight_fun = NULL)
  res8 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r8,
    weight_mat = weights2, globalweight_fun = NULL)
  res9 <- bskt_final(design = design1, n = 24, lambda = 0.99, r = r9,
    weight_mat = weights2, globalweight_fun = NULL)

  expect_true(any(res6 != cummax(res6)))
  expect_false(any(res7 != cummax(res7)))
  expect_false(any(res8 != cummax(res8)))
  expect_false(any(res9 != cummax(res9)))

  # Check results of all other violating outcomes
  resall <- t(apply(r$Events, 1, function(x) bskt_final(design = design1,
    n = 24, lambda = 0.99, r = x, weight_mat = weights2,
    globalweight_fun = NULL)))

  expect_true(all(resall == r$Results))

  # Check condition with no details
  res_nodet2 <- check_mon_within(design = design1, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 7, tau = 0,
    logbase = 2, prune = TRUE), details = FALSE)

  expect_false(res_nodet2)

  # Compare with mon_within_loop
  res_loop2 <- mon_within_loop(design = design1, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 7, tau = 0,
    logbase = 2, prune = TRUE))

  expect_true(all(res_loop2 == r$Events))

  ## Compare result when condition holds
  design2 <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)

  res_noviol1 <- check_mon_within(design = design2, n = 20, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE), details = FALSE)
  res_noviol2 <- check_mon_within(design = design2, n = 20, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE), details = TRUE)
  res_noviol3 <- mon_within_loop(design = design2, n = 20, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE))

  expect_equal(res_noviol1, res_noviol2)
  expect_equal(res_noviol1, res_noviol3)

  ## Check vectorized version
  # Compare results
  res_vect <- check_mon_within(design = design1, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = c(0.5, 1),
      tau = 0, logbase = 2, prune = FALSE), details = TRUE)
  res_vectcheck1 <- check_mon_within(design = design1, n = 24,
    lambda = 0.99, weight_fun = weights_fujikawa,
    weight_params = list(epsilon = 0.5, tau = 0, logbase = 2, prune = FALSE),
    details = FALSE)
  res_vectcheck2 <- check_mon_within(design = design1, n = 24,
    lambda = 0.99, weight_fun = weights_fujikawa,
    weight_params = list(epsilon = 1, tau = 0, logbase = 2, prune = FALSE),
    details = FALSE)
  expect_equal(as.vector(res_vect), c(res_vectcheck1, res_vectcheck2))

  # Multidimensional vectorization
  res_vect2 <- check_mon_within(design = design1, n = 12, lambda = 0.99,
    weight_fun = weights_fujikawa,
    weight_params = list(epsilon = c(0.5, 1),  tau = c(0, 0.2)),
    globalweight_fun = globalweights_fix,
    globalweight_params = list(w = c(0.5, 0.7)))
  res_vect3 <- check_mon_within(design = design1, n = 12, lambda = 0.99,
    weight_fun = weights_fujikawa,
    globalweight_fun = globalweights_fix,
    globalweight_params = list(w = c(0.5, 0.7)))

  expect_true(all(dim(res_vect2) == c(2, 2, 2)))
  expect_true(dim(res_vect3) == 2)
})

test_that("check_mon_between works", {
  ## Without Pruning
  design <- setupOneStageBasket(k = 3, shape1 = 1, shape2 = 1, p0 = 0.2)

  ev <- check_mon_between(design = design, n = 15, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE), details = TRUE)
  ev_viol <- t(sapply(ev, function(x) x$Events[1, ]))

  # Check results of first violated outcome
  ev1 <- ev[[1]]
  weights1 <- weights_fujikawa(design = design, n = 15, epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE)

  res1 <- bskt_final(design = design, n = 15, lambda = 0.99,
    r = ev1$Events[1, ], weight_mat = weights1, globalweight_fun = NULL)
  res2 <- t(apply(ev1$Events[-1, ], 1, function(x) bskt_final(design = design,
    n = 15, lambda = 0.99, r = x, weight_mat = weights1,
    globalweight_fun = NULL)))

  expect_equal(res1, ev1$Results[1, ])
  expect_true(any(res1 == 1))
  expect_equal(res2, ev1$Results[-1, ])
  expect_true(all(res2 == 0))

  # Check whether there is a significant basket in each violated outcome
  res3 <- t(apply(ev_viol, 1, function(x) bskt_final(design = design,
    n = 15, lambda = 0.99, r = x, weight_mat = weights1,
    globalweight_fun = NULL)))
  res_sig1 <- apply(res3, 1, function(x) any(x == 1))
  expect_true(all(res_sig1))

  # Check condition with no details
  res_nodet1 <- check_mon_between(design = design, n = 15, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE), details = FALSE)

  expect_false(res_nodet1)

  # Compare with mon_between_loop
  res_slow1 <- mon_between_loop(design = design, n = 15, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = FALSE))

  expect_equal(ev_viol, res_slow1)

  ## With Pruning
  res_nodet2 <- check_mon_between(design = design, n = 15, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = TRUE), details = FALSE)

  expect_true(res_nodet2)

  # Check violating outcomes from no-prune analysis
  crit_pool <- get_crit_pool(design = design, n = 15, lambda = 0.99,
    weight_mat = weights1)
  weights2 <- prune_weights(weights1, cut = crit_pool)

  res4 <- bskt_final(design = design, n = 15, lambda = 0.99,
    r = ev1$Events[1, ], weight_mat = weights2, globalweight_fun = NULL)
  res5 <- t(apply(ev1$Events[-1, ], 1, function(x) bskt_final(design = design,
    n = 15, lambda = 0.99, r = x, weight_mat = weights2,
    globalweight_fun = NULL)))

  res_sig3 <- any(res4 == 1)
  res_sig2 <- apply(res5, 1, function(x) any(x == 1))

  expect_equal(res_sig3, all(res_sig2))

  # Compare with mon_between_slow
  res_slow2 <- mon_between_loop(design = design, n = 15, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2, tau = 0,
    logbase = 2, prune = TRUE))

  expect_equal(res_nodet2, res_slow2)

  ## Check vectorized version
  # Compare results
  res_vect <- check_mon_between(design = design, n = 24, lambda = 0.99,
    weight_fun = weights_fujikawa, weight_params = list(epsilon = 2:3,
      tau = 0.5, logbase = 2, prune = FALSE), details = TRUE)
  res_vectcheck1 <- check_mon_between(design = design, n = 24,
    lambda = 0.99, weight_fun = weights_fujikawa,
    weight_params = list(epsilon = 2, tau = 0.5, logbase = 2, prune = FALSE),
    details = FALSE)
  res_vectcheck2 <- check_mon_between(design = design, n = 24,
    lambda = 0.99, weight_fun = weights_fujikawa,
    weight_params = list(epsilon = 3, tau = 0.5, logbase = 2, prune = FALSE),
    details = FALSE)
  expect_equal(as.vector(res_vect), c(res_vectcheck1, res_vectcheck2))

  # Multidimensional vectorization
  res_vect2 <- check_mon_between(design = design, n = 12, lambda = 0.99,
    weight_fun = weights_fujikawa,
    weight_params = list(epsilon = c(0.5, 1),  tau = c(0, 0.2)),
    globalweight_fun = globalweights_fix,
    globalweight_params = list(w = c(0.5, 0.7)))
  res_vect3 <- check_mon_between(design = design, n = 12, lambda = 0.99,
    weight_fun = weights_fujikawa,
    globalweight_fun = globalweights_fix,
    globalweight_params = list(w = c(0.5, 0.7)))

  expect_true(all(dim(res_vect2) == c(2, 2, 2)))
  expect_true(dim(res_vect3) == 2)
})