tests/testthat/test-sas-results-part-1.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(0504201914)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 200000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc1 <- c(10, 20, 35, 50, 65, 80, 90, 100)

  data <- Data(
    x = c(rep(10, 3)),
    y = c(rep(0, 3)),
    cohort = c(rep(1, 3)),
    doseGrid = dose_grid_sc1,
    ID = 1:3
  )

  model_bcrm_sc1 <- LogisticLogNormal(
    mean = c(-0.708, -0.389),
    cov = matrix(c(1.2^2, 0, 0, 0.9^2), nrow = 2),
    ref_dose = 90
  )

  ncrm_loss_sc1 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.9999,
    losses = c(1, 0, 2, 3)
  )

  postSamples <- mcmc(data, model_bcrm_sc1, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc1,
    doselimit = Inf,
    postSamples,
    model_bcrm_sc1,
    data
  ))

  rec_dose_sc1 <- dose_rec_loss$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_sc1,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc1 <- 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/sc1_sit1.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc1 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc1) <- temp[, 1]

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

  expect_true(all_true)

  # Recommended dose computed by SAS
  sas_dose_rec <- 35
  # compare recommended doses: crmPack vs. SAS
  expect_equal(rec_dose_sc1, 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(0504201914)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 600000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc1 <- c(10, 20, 35, 50, 65, 80, 90, 100)

  data <- Data(
    x = c(rep(10, 3), rep(20, 3)),
    y = c(rep(0, 3), rep(0, 2), 1),
    cohort = c(rep(1, 3), rep(2, 3)),
    doseGrid = dose_grid_sc1,
    ID = 1:6
  )

  model_bcrm_sc1 <- LogisticLogNormal(
    mean = c(-0.708, -0.389),
    cov = matrix(c(1.2^2, 0, 0, 0.9^2), nrow = 2),
    ref_dose = 90
  )

  ncrm_loss_sc1 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.9999,
    losses = c(1, 0, 2, 3)
  )

  postSamples <- mcmc(data, model_bcrm_sc1, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc1,
    doselimit = Inf,
    postSamples,
    model_bcrm_sc1,
    data
  ))

  rec_dose_sc1 <- dose_rec_loss$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_sc1,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc1 <- 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/sc1_sit2.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc1 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc1) <- temp[, 1]

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

  expect_true(all_true)

  # Recommended dose computed by SAS
  sas_dose_rec <- 20
  # compare recommended doses: crmPack vs. SAS
  expect_equal(rec_dose_sc1, 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(0504201914)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 200000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc1 <- c(10, 20, 35, 50, 65, 80, 90, 100)

  data <- Data(
    x = c(
      rep(10, 3),
      rep(20, 3),
      rep(35, 3),
      rep(50, 3)
    ),
    y = c(rep(0, 3 * 4)),
    cohort = c(
      rep(1, 3),
      rep(2, 3),
      rep(3, 3),
      rep(4, 3)
    ),
    doseGrid = dose_grid_sc1,
    ID = 1:12
  )

  model_bcrm_sc1 <- LogisticLogNormal(
    mean = c(-0.708, -0.389),
    cov = matrix(c(1.2^2, 0, 0, 0.9^2), nrow = 2),
    ref_dose = 90
  )

  ncrm_loss_sc1 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.9999,
    losses = c(1, 0, 2, 3)
  )

  postSamples <- mcmc(data, model_bcrm_sc1, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc1,
    doselimit = Inf,
    postSamples,
    model_bcrm_sc1,
    data
  ))

  rec_dose_sc1 <- dose_rec_loss$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_sc1,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc1 <- 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/sc1_sit3.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc1 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc1) <- temp[, 1]

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

  expect_true(all_true)

  # Recommended dose computed by SAS
  sas_dose_rec <- 65
  # compare recommended doses: crmPack vs. SAS
  expect_equal(rec_dose_sc1, 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(0504201914)
  mcmc_options <- McmcOptions(
    burnin = 5000,
    step = 2,
    samples = 200000,
    rng_kind = "Wichmann-Hill",
    rng_seed = 1
  )

  dose_grid_sc1 <- c(10, 20, 35, 50, 65, 80, 90, 100)

  data <- Data(
    x = c(
      rep(10, 3),
      rep(20, 3),
      rep(35, 3),
      rep(50, 3)
    ),
    y = c(rep(0, 3 * 3), rep(0, 2), 1),
    cohort = c(
      rep(1, 3),
      rep(2, 3),
      rep(3, 3),
      rep(4, 3)
    ),
    doseGrid = dose_grid_sc1,
    ID = 1:12
  )

  model_bcrm_sc1 <- LogisticLogNormal(
    mean = c(-0.708, -0.389),
    cov = matrix(c(1.2^2, 0, 0, 0.9^2), nrow = 2),
    ref_dose = 90
  )

  ncrm_loss_sc1 <- NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.9999,
    losses = c(1, 0, 2, 3)
  )

  postSamples <- mcmc(data, model_bcrm_sc1, mcmc_options)

  dose_rec_loss <- expect_silent(nextBest(
    ncrm_loss_sc1,
    doselimit = Inf,
    postSamples,
    model_bcrm_sc1,
    data
  ))

  rec_dose_sc1 <- dose_rec_loss$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_sc1,
      postSamples
    )
  }
  pq75 <- apply(prob_samples_mat, 2, function(x) quantile(x, 0.75))

  res_sc1 <- 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/sc1_sit4.csv"),
    header = TRUE,
    dec = "."
  )
  sas_sc1 <- apply(as.matrix(temp[, -1]), 2, as.numeric)
  rownames(sas_sc1) <- temp[, 1]

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

  expect_true(all_true)

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