tests/testthat/test-sas-results-part-2.R

In crmPack: Object-Oriented Implementation of Dose Escalation Designs

test_that("Posterior summaries for probabilities of
          DLT (2-parameter logistic model) and recommended doses (NCRMLoss):
          crmPack vs. SAS - Example 1", {
  skip_on_cran()

  set.seed(0304191413)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 100000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc3 <- c(10, 15, 30, 45, 60, 90, 120, 150, 180, 240)

  data <- Data(
    x = c(rep(15, 3)),
    y = c(rep(0, 2), 1),
    cohort = c(rep(1, 3)),
    doseGrid = dose_grid_sc3,
    ID = 1:3
  )

  model_bcrm_sc3 <- LogisticLogNormal(
    mean = c(-0.8473, -0.0935),
    cov = matrix(c(1.489^2, 0, 0, 1.275^2), nrow = 2),
    ref_dose = 150
  )

  increment1 <- IncrementsRelative(
    intervals = c(0, 60),
    increments = c(1, 0.67)
  )

  increment2 <- IncrementsRelativeDLT(
    intervals = c(0, 1),
    increments = c(1, 0.50)
  )

  combIncrement <- IncrementsMin(increments_list = list(increment1, increment2))

  ncrm_loss_sc3 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )

  ncrm_sc3 <- NextBestNCRM(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  postSamples <- mcmc(data, model_bcrm_sc3, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  dose_rec <- expect_silent(nextBest(
    ncrm_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  rec_dose_loss_sc3 <- dose_rec_loss$value
  rec_dose_sc3 <- dose_rec$value

  prob_samples_mat <- matrix(
    nrow = size(postSamples@options),
    ncol = data@nGrid
  )

  # evaluate the probs, for all samples
  for (i in seq_len(data@nGrid)) {
    prob_samples_mat[, i] <- prob(
      dose = data@doseGrid[i],
      model_bcrm_sc3,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc3 <- cbind(
    LOSS = dose_rec_loss$probs[, "posterior_loss"],
    PTARGET = dose_rec_loss$probs[, "target"],
    POVEREX = dose_rec_loss$probs[, "excessive"],
    POVERUN = dose_rec_loss$probs[, "unacceptable"],
    POVER = rowSums(dose_rec_loss$probs[, c("excessive", "unacceptable")]),
    PMEAN = dose_rec_loss$probs[, "mean"],
    PQ75 = pq75
  )

  # Posterior summaries computed by SAS
  temp <- read.csv2(
    test_path("testdata/sc3_sit1.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc3 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc3) <- temp[, 1]

  # Compare posterior summaries for probabilities of DLT: crmPack vs. SAS
  all_true <- c(FALSE)
  all_true <- all(abs(res_sc3 - sas_sc3) < 0.01)

  expect_true(all_true)

  # Recommended dose computed by SAS
  sas_dose_rec <- 15
  # compare the recommended doses: crmPack vs. SAS
  expect_equal(rec_dose_sc3, sas_dose_rec, tolerance = 0)
})

test_that("Posterior summaries for probabilities of
          DLT (2-parameter logistic model) and recommended doses (NCRMLoss):
          crmPack vs. SAS - Example 2", {
  skip_on_cran()

  set.seed(0304191413)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 100000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc3 <- c(10, 15, 30, 45, 60, 90, 120, 150, 180, 240)

  data <- Data(
    x = c(rep(15, 3), rep(30, 3)),
    y = c(rep(0, 3), rep(0, 2), 1),
    cohort = c(rep(1, 3), rep(2, 3)),
    doseGrid = dose_grid_sc3,
    ID = 1:6
  )

  model_bcrm_sc3 <- LogisticLogNormal(
    mean = c(-0.8473, -0.0935),
    cov = matrix(c(1.489^2, 0, 0, 1.275^2), nrow = 2),
    ref_dose = 150
  )

  increment1 <- IncrementsRelative(
    intervals = c(0, 60),
    increments = c(1, 0.67)
  )

  increment2 <- IncrementsRelativeDLT(
    intervals = c(0, 1),
    increments = c(1, 0.50)
  )

  combIncrement <- IncrementsMin(increments_list = list(increment1, increment2))

  ncrm_loss_sc3 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )

  ncrm_sc3 <- NextBestNCRM(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  postSamples <- mcmc(data, model_bcrm_sc3, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  dose_rec <- expect_silent(nextBest(
    ncrm_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  rec_dose_loss_sc3 <- dose_rec_loss$value
  rec_dose_sc3 <- dose_rec$value

  prob_samples_mat <- matrix(
    nrow = size(postSamples@options),
    ncol = data@nGrid
  )

  # evaluate the probs, for all samples
  for (i in seq_len(data@nGrid)) {
    prob_samples_mat[, i] <- prob(
      dose = data@doseGrid[i],
      model_bcrm_sc3,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc3 <- cbind(
    LOSS = dose_rec_loss$probs[, "posterior_loss"],
    PTARGET = dose_rec_loss$probs[, "target"],
    POVEREX = dose_rec_loss$probs[, "excessive"],
    POVERUN = dose_rec_loss$probs[, "unacceptable"],
    POVER = rowSums(dose_rec_loss$probs[, c("excessive", "unacceptable")]),
    PMEAN = dose_rec_loss$probs[, "mean"],
    PQ75 = pq75
  )

  # Posterior summaries computed by SAS
  temp <- read.csv2(
    test_path("testdata/sc3_sit2.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc3 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc3) <- temp[, 1]

  # compare posterior summaries for probabilities of DLT: crmPack vs. SAS
  all_true <- c(FALSE)
  all_true <- all(abs(res_sc3 - sas_sc3) < 0.01)

  expect_true(all_true)

  # Recommended dose computed by SAS
  sas_dose_rec <- 45
  # compare the recommended doses: crmPack vs. SAS
  expect_equal(rec_dose_sc3, sas_dose_rec, tolerance = 0)
})

test_that("Posterior summaries for probabilities of
          DLT (2-parameter logistic model) and recommended doses (NCRMLoss):
          crmPack vs. SAS - Example 3", {
  skip_on_cran()

  set.seed(0304191413)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 100000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc3 <- c(10, 15, 30, 45, 60, 90, 120, 150, 180, 240)

  data <- Data(
    x = c(rep(15, 3), rep(30, 3), rep(60, 3), rep(90, 3)),
    y = c(rep(0, 3), rep(0, 3), rep(0, 2), 1, rep(0, 2), 1),
    cohort = c(rep(1, 3), rep(2, 3), rep(3, 3), rep(4, 3)),
    doseGrid = dose_grid_sc3,
    ID = 1:12
  )

  model_bcrm_sc3 <- LogisticLogNormal(
    mean = c(-0.8473, -0.0935),
    cov = matrix(c(1.489^2, 0, 0, 1.275^2), nrow = 2),
    ref_dose = 150
  )

  increment1 <- IncrementsRelative(
    intervals = c(0, 60),
    increments = c(1, 0.67)
  )

  increment2 <- IncrementsRelativeDLT(
    intervals = c(0, 1),
    increments = c(1, 0.50)
  )

  combIncrement <- IncrementsMin(increments_list = list(increment1, increment2))

  ncrm_loss_sc3 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )

  ncrm_sc3 <- NextBestNCRM(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  postSamples <- mcmc(data, model_bcrm_sc3, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  dose_rec <- expect_silent(nextBest(
    ncrm_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  rec_dose_loss_sc3 <- dose_rec_loss$value
  rec_dose_sc3 <- dose_rec$value

  prob_samples_mat <- matrix(
    nrow = size(postSamples@options),
    ncol = data@nGrid
  )

  # evaluate the probs, for all samples
  for (i in seq_len(data@nGrid)) {
    prob_samples_mat[, i] <- prob(
      dose = data@doseGrid[i],
      model_bcrm_sc3,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc3 <- cbind(
    LOSS = dose_rec_loss$probs[, "posterior_loss"],
    PTARGET = dose_rec_loss$probs[, "target"],
    POVEREX = dose_rec_loss$probs[, "excessive"],
    POVERUN = dose_rec_loss$probs[, "unacceptable"],
    POVER = rowSums(dose_rec_loss$probs[, c("excessive", "unacceptable")]),
    PMEAN = dose_rec_loss$probs[, "mean"],
    PQ75 = pq75
  )

  # Posterior summaries computed by SAS
  temp <- read.csv2(
    test_path("testdata/sc3_sit3.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc3 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc3) <- temp[, 1]

  # compare posterior summaries for probabilities of DLT: crmPack vs. SAS
  all_true <- c(FALSE)
  all_true <- all(abs(res_sc3 - sas_sc3) < 0.01)

  expect_true(all_true)

  # Recommended dose computed by SAS
  sas_dose_rec <- 90
  # compare the recommended doses: crmPack vs. SAS
  expect_equal(rec_dose_sc3, sas_dose_rec, tolerance = 0)
})

test_that("Posterior summaries for probabilities of
          DLT (2-parameter logistic model) and recommended doses (NCRMLoss):
          crmPack vs. SAS - Example 4", {
  skip_on_cran()

  set.seed(0304191413)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 100000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc3 <- c(10, 15, 30, 45, 60, 90, 120, 150, 180, 240)

  data <- Data(
    x = c(rep(15, 3), rep(30, 3), rep(60, 3)),
    y = c(rep(0, 3), rep(0, 3), rep(0, 3)),
    cohort = c(rep(1, 3), rep(2, 3), rep(3, 3)),
    doseGrid = dose_grid_sc3,
    ID = 1:9
  )

  model_bcrm_sc3 <- LogisticLogNormal(
    mean = c(-0.8473, -0.0935),
    cov = matrix(c(1.489^2, 0, 0, 1.275^2), nrow = 2),
    ref_dose = 150
  )

  increment1 <- IncrementsRelative(
    intervals = c(0, 60),
    increments = c(1, 0.67)
  )

  increment2 <- IncrementsRelativeDLT(
    intervals = c(0, 1),
    increments = c(1, 0.50)
  )

  combIncrement <- IncrementsMin(increments_list = list(increment1, increment2))

  ncrm_loss_sc3 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )

  ncrm_sc3 <- NextBestNCRM(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  postSamples <- mcmc(data, model_bcrm_sc3, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  dose_rec <- expect_silent(nextBest(
    ncrm_sc3,
    doselimit = maxDose(combIncrement, data),
    postSamples,
    model_bcrm_sc3,
    data
  ))

  rec_dose_loss_sc3 <- dose_rec_loss$value
  rec_dose_sc3 <- dose_rec$value

  prob_samples_mat <- matrix(
    nrow = size(postSamples@options),
    ncol = data@nGrid
  )

  # evaluate the probs, for all samples
  for (i in seq_len(data@nGrid)) {
    prob_samples_mat[, i] <- prob(
      dose = data@doseGrid[i],
      model_bcrm_sc3,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc3 <- cbind(
    LOSS = dose_rec_loss$probs[, "posterior_loss"],
    PTARGET = dose_rec_loss$probs[, "target"],
    POVEREX = dose_rec_loss$probs[, "excessive"],
    POVERUN = dose_rec_loss$probs[, "unacceptable"],
    POVER = rowSums(dose_rec_loss$probs[, c("excessive", "unacceptable")]),
    PMEAN = dose_rec_loss$probs[, "mean"],
    PQ75 = pq75
  )

  # Posterior summaries computed by SAS
  temp <- read.csv2(
    test_path("testdata/sc3_sit4.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc3 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc3) <- temp[, 1]

  # Compare posterior summaries for probabilities of DLT: crmPack vs. SAS
  all_true <- c(FALSE)
  all_true <- all(abs(res_sc3 - sas_sc3) < 0.01)

  expect_true(all_true)

  # Recommended dose computed by SAS
  sas_dose_rec <- 90
  # compare the recommended doses: crmPack vs. SAS
  expect_equal(rec_dose_sc3, sas_dose_rec, tolerance = 0)
})