tests added

Author: audreyyeoCH

R/dbetabinom.R

@@ -210,10 +210,6 @@ qbetaMix <- function(p, par, weights, lower.tail = TRUE) {
   grid <- seq(0, 1, len = 31)
   f_grid <- .pbetaMix(grid, par, weights, lower.tail = lower.tail)
 
-  diff <- f_grid - p
-  pos <- diff > 0
-  grid_interval <- c(grid[!pos][which.max(diff[!pos])], grid[pos][which.min(diff[pos])])
-
   sapply(p, function(p) {
     # special cases
     if (p == 0) {
@@ -229,7 +225,7 @@ qbetaMix <- function(p, par, weights, lower.tail = TRUE) {
 
     uniroot(
       f = function(q) .pbetaMix(q, par, weights, lower.tail = lower.tail) - p,
-      interval = grid_interval,
+      interval = grid_interval, # more precise x-axis for root finding
       f.lower = -p,
       f.upper = 1 - p,
       tol = sqrt(.Machine$double.eps)

tests/testthat/test-ocPostprob.R

@@ -163,92 +163,33 @@ test_that("ocPostprob gives results that are within range to stats::pbinom", {
   expect_true(abs(p.stop - result$oc$PrFutility) < 1e-2)
 })
 
-test_that("hard coded parameters fail and give incorrect results in old_ocPostprob", {
+test_that("two function calls that differ in parE does not give the same result.", {
   set.seed(1989)
-  old_ocPostprob <- function(nnE, truep, p0, p1, tL, tU, parE = c(1, 1),
-                             sim = 50000, wiggle = FALSE, nnF = nnE) {
-    nn <- sort(unique(c(nnF, nnE)))
-    Nmax <- max(nn)
-    assert_number(sim, lower = 1, finite = TRUE)
-    assert_flag(wiggle)
-    if (sim < 50000) {
-      warning("Advise to use sim >= 50000 to achieve convergence")
-    }
-    decision <- vector(length = sim)
-    all_sizes <- vector(length = sim)
-    all_looks <- vector(length = sim)
-    for (k in seq_len(sim)) {
-      if (length(nn) != 1 && wiggle) {
-        dist <- h_get_distance(nn = nn)
-        nnr <- h_get_looks(dist = dist, nnE = nnE, nnF = nnF)
-        nnrE <- nnr$nnrE
-        nnrF <- nnr$nnrF
-        orig_nnE <- nnE
-        orig_nnF <- nnF
-      } else {
-        dist <- 0
-        nnrE <- nnE
-        nnrF <- nnF
-        orig_nnE <- nnrE
-        orig_nnF <- nnrF
-      }
-      nnr <- unique(c(nnrE, nnrF))
-      orig_nnr <- unique(c(orig_nnE, orig_nnF))
-      tmp <- h_get_decision(
-        nnr = nnr,
-        truep = truep,
-        p0 = p0,
-        p1 = p1,
-        parE = c(1,1),
-        nnE = nnrE,
-        nnF = nnrF,
-        tL = tL,
-        tU = tU,
-        orig_nnr = orig_nnr
-      )
-      decision[k] <- tmp$decision
-      all_sizes[k] <- tmp$all_sizes
-      all_looks[k] <- tmp$all_looks
-    }
-    oc <- h_get_oc(all_sizes = all_sizes, Nmax = Nmax, decision = decision)
-    list(
-      oc = oc,
-      Decision = decision,
-      Looks = all_looks,
-      SampleSize = all_sizes,
-      union_nn = nnr,
-      wiggled_nnrE = nnrE,
-      wiggled_nnrF = nnrF,
-      dist = dist,
-      params = as.list(match.call(expand.dots = FALSE))
-    )
-  }
-  expect_warning(result_old <- old_ocPostprob(
+  expect_warning(result_uniform_hard_coded <- ocPostprob(
     nnE = 30,
     truep = 0.4,
-    p0 = 0.2,
-    p1 = 0.5,
-    tL = 0.7,
+    p0 = 0.1,
+    p1 = 0.3,
+    tL = 0.8,
     tU = 0.3,
-    parE = c(4, 24),
+    parE = c(1, 1), # weak prior gives more PrGrayZone
     sim = 100,
     wiggle = TRUE,
-    nnF = 10), "Advise to use sim >= 50000 to achieve convergence")
-  # result_old$oc
-  expect_warning(result_new <- ocPostprob(
+    nnF = 30), "Advise to use sim >= 50000 to achieve convergence")
+  # result_uniform_hard_coded$oc
+  expect_warning(result_no_hard_code <- ocPostprob(
     nnE = 30,
     truep = 0.4,
-    p0 = 0.2,
-    p1 = 0.5,
-    tL = 0.7,
+    p0 = 0.1,
+    p1 = 0.3,
+    tL = 0.8,
     tU = 0.3,
-    parE = c(4, 24),
+    parE = c(4, 10), # stronger prior gives higher PrEfficacy
     sim = 100,
     wiggle = TRUE,
-    nnF = 10), "Advise to use sim >= 50000 to achieve convergence")
-  # result_new$oc
-  expect_true(result_new$oc["PrStopEarly"] != result_old$oc["PrStopEarly"])
-  expect_true(result_old$oc["PrFutility"] < result_new$oc["PrFutility"])
-  expect_true(result_old$oc["PrGrayZone"] < result_new$oc["PrGrayZone"])
+    nnF = 30), "Advise to use sim >= 50000 to achieve convergence")
+  # result_no_hard_code$oc
+  expect_true(result_no_hard_code$oc["PrEfficacy"] > result_uniform_hard_coded$oc["PrEfficacy"])
+  expect_true(result_no_hard_code$oc["PrGrayZone"] < result_uniform_hard_coded$oc["PrGrayZone"])
 }
 )

tests/testthat/test-ocPostprobDist.R

@@ -167,3 +167,38 @@ test_that("the PrEfficacy increases with increase Efficacy looks", {
   expect_true(res_more_eff$oc$PrEfficacy > res_eff$oc$PrEfficacy)
 })
 
+test_that("two function calls that differ in parE does not give the same result.", {
+  set.seed(1989)
+  expect_warning(result_uniform_hard_coded <- ocPostprobDist(
+    nnE = 30,
+    truep = 0.15,
+    deltaE = 0.1,
+    deltaF = -0.1,
+    tL = 0.45,
+    tU = 0.4,
+    parE = c(1, 1), # PrGrayZone higher due to same, weak priors
+    parS = c(1, 1),
+    sim = 100,
+    wiggle = FALSE,
+    nnF = 30
+  ), "Advise to use sim >= 50000 to achieve convergence")
+  result_uniform_hard_coded$oc
+  expect_warning(result_no_hard_code <- ocPostprobDist(
+    nnE = 30,
+    truep = 0.15,
+    deltaE = 0.1,
+    deltaF = -0.1,
+    tL = 0.45,
+    tU = 0.4,
+    parE = c(5, 10), # PrFutility lower due to stronger prior
+    parS = c(1, 1),
+    sim = 100,
+    wiggle = FALSE,
+    nnF = 30
+  ), "Advise to use sim >= 50000 to achieve convergence")
+  result_no_hard_code$oc
+  expect_true(result_no_hard_code$oc["PrFutility"] > result_uniform_hard_coded$oc["PrFutility"])
+  expect_true(result_no_hard_code$oc["PrGrayZone"] < result_uniform_hard_coded$oc["PrGrayZone"])
+}
+)
+

tests/testthat/test-ocRctPostprobDist.R

@@ -226,3 +226,59 @@ test_that("ocRctPostprobDist gives higher PrEfficacy with increased pE", {
   ), "Advise to use sim >= 50000 to achieve convergence")
   expect_true(res_high_truep$oc$PrEfficacy > res_eff$oc$PrEfficacy)
 })
+
+test_that("two function calls that differ in parE does not give the same result.", {
+  set.seed(1989)
+  input <- list(
+    nnE = 30,
+    pE = 0.4,
+    pS = 0.2,
+    deltaE = 0.1,
+    deltaF = 0.1,
+    relativeDelta = FALSE,
+    tL = 0.8,
+    tU = 0.8,
+    parE = c(a = 4, b = 10),
+    parS = c(a = 1, b = 1),
+    nnF = 30,
+    sim = 5,
+    Nmax = 15
+  )
+  expect_warning(result_uniform_hard_coded <- ocRctPostprobDist(
+    nnE = input$nnE,
+    pE = input$pE,
+    pS = input$pS,
+    deltaE = input$deltaE,
+    deltaF = input$deltaF,
+    relativeDelta = TRUE,
+    tL = input$tL,
+    tU = input$tU,
+    parE = c(1, 1),
+    parS = input$parS,
+    randRatio = 1,
+    sim = 50,
+    wiggle = FALSE,
+    nnF = 10
+  ), "Advise to use sim >= 50000 to achieve convergence")
+  result_uniform_hard_coded$oc
+  expect_warning(result_no_hard_code <- ocRctPostprobDist(
+    nnE = input$nnE,
+    pE = input$pE,
+    pS = input$pS,
+    deltaE = input$deltaE,
+    deltaF = input$deltaF,
+    relativeDelta = TRUE,
+    tL = input$tL,
+    tU = input$tU,
+    parE = input$parE, # stronger prior, higher difference needed to pass Go
+    parS = input$parS,
+    randRatio = 1,
+    sim = 50,
+    wiggle = FALSE,
+    nnF = 10
+  ), "Advise to use sim >= 50000 to achieve convergence")
+  result_no_hard_code$oc
+  expect_true(result_no_hard_code$oc["PrEfficacy"] < result_uniform_hard_coded$oc["PrEfficacy"])
+  expect_true(result_no_hard_code$oc["PrGrayZone"] > result_uniform_hard_coded$oc["PrGrayZone"])
+}
+)