tests/testthat/test-utils.R

In BayesFBHborrow: Bayesian Dynamic Borrowing with Flexible Baseline Hazard Function

test_that(".dataframe_fun.R has correct formatting", {
  Y <-  c(9, 13, 13, 18, 23)
  I <- c(1 ,1 ,0, 1, 1)
  X <- NULL
  s_r <- 10
  s <- c(0, sort(s_r), max(Y))
  lambda <- c(0.1, 0.9)
  J <- 1

  order <- c("tstart","id","Y", "I", "lambda")
  
  # Order, no covariates
  df <- .dataframe_fun(Y, I, X, s, lambda, bp = 0, J)
  expect_equal(names(df), order)
  
  # Order, with covariates
  X <- matrix(c(stats::rbinom(length(Y),5,0.5), stats::rbinom(length(Y),5,0.5), 
         stats::rbinom(length(Y),5,0.5)), ncol = 3)
  df <- .dataframe_fun(Y, I, X, s, lambda, bp = 3, J)
  order <- c("tstart","id","X1", "X2", "X3","Y", "I", "lambda")
  expect_equal(names(df), order)
  
  # Data Consistency, number of events is equal before and after split
  expect_equal(1, sum(df[df$tstart == 0,]$I))
  expect_equal(3, sum(df[df$tstart == 10,]$I))
  
  # Events are the same even when data is not ordered
  Y_wrong <-  c(13, 18, 23, 13, 9)
  I_wrong <- c(1 ,1 ,1, 0, 1)
  expect_equal(1, sum(df[df$tstart == 0,]$I))
  expect_equal(3, sum(df[df$tstart == 10,]$I))
  
  # Expect error when s is defined wrong (needs to be >= 2)
  # Written specifically in code, should not occur
  
  # Missing Data Handling
  Y_missing <-  c(9, NA, 13, 18, NA)
  I_missing <- c(1 , NA, 0, 1, NA)
  df_missing <- .dataframe_fun(Y_missing, I_missing, X, s, lambda, bp = 0, J)
  expect_equal(sum(is.na(df_missing$Y)), sum(is.na(Y_missing)))
  
  # there is some weird behavior in survSplit where it will give different values of I
  # (NA or 0) every time you run it, not sure if this interferes with anything [Q]
  
  # Empty dataframe, should not be able to split data
  expect_error(data.frame.fun(c(), c(), c(), s, lambda, bp = 0, J))
  
  # Performance Test
  X_large <- matrix(nrow = 1000, ncol = 1000)
  Y_large <- 1:1000
  I_large <- rbinom(n=1000, size=1, prob=0.5)
  for (ii in 1:1000) {
    X_large[ii,] <- 1:1000
  }
  system.time(df_large <- .dataframe_fun(Y_large, I_large, X_large, s, lambda, bp = ncol(X_large), J))
  expect_true(ncol(df_large) == 5+1000)
})

test_that(".logsumexp operates as it should", {
  
  # Postive values
  input_pos <- c(0.5, 0.4, 0.1, 0.01)
  expected_result <- log(sum(exp(input_pos)))
  expect_equal(.logsumexp(input_pos), expected_result)
  
  # Negative values
  input_neg <- c(-0.5, -0.4, -0.1, -0.01)
  expected_result <- log(sum(exp(input_neg)))
  expect_equal(.logsumexp(input_neg), expected_result)
  
  # All zero
  input_zero <- c(0, 0, 0, 0, 0)
  expected_result <- log(sum(exp(input_zero)))
  expect_equal(.logsumexp(input_zero), expected_result)
  
  # NAs present, should they be ignored? Or checked before? [Q]
  input_NA <- c(0.5, 0.4, NA, 0.01)
  expected_result <- log(sum(exp(input_NA)))
  expect_equal(.logsumexp(input_NA), expected_result)
  
})

test_that(".normalize_prob operates as it should", {
  
  # Postive values
  input_pos <- c(0.5, 0.4, 0.1, 0.01)
  expected_result <- exp(input_pos - .logsumexp(input_pos))
  expect_equal(.normalize_prob(input_pos), expected_result)
  
  # Negative values
  input_neg <- c(-0.5, -0.4, -0.1, -0.01)
  expected_result <- exp(input_neg - .logsumexp(input_neg))
  expect_equal(.normalize_prob(input_neg), expected_result)
  
  # All zero
  input_zero <- c(0, 0, 0, 0, 0)
  expected_result <- exp(input_zero - .logsumexp(input_zero))
  expect_equal(.normalize_prob(input_zero), expected_result)
  
  # NAs present, should they be ignored? Or checked before? [Q]
  input_NA <- c(0.5, 0.4, NA, 0.01)
  expected_result <- exp(input_NA - .logsumexp(input_NA))
  expect_equal(.normalize_prob(input_NA), expected_result)
  
})

test_that(".log_likelihood operates as it should", {
  Y <-  c(9, 13, 13, 18, 23)
  I <- c(1 ,1 ,0, 1, 1)
  X <- NULL
  s_r <- 10
  s <- c(0, sort(s_r), max(Y))
  lambda <- c(0.1, 0.9)
  J <- 1
  df <- .dataframe_fun(Y, I, X, s, lambda, bp = 0, J)
  
  ## Without covariates
  # Empty data.frames
  expect_error(.log_likelihood(df = c(), beta = NULL))
  
  # NAs present, should it return NA? How should we handle NAs? [Q]
  Y_NA <-  c(NA, 13, 13, 18, 23)
  I_NA <- c(NA , 1, 0, 1, 1)
  df <- .dataframe_fun(Y_NA, I_NA, X, s, lambda, bp = 0, J)
  expect_equal(sum(is.na(.log_likelihood(df, beta = NULL))), 1)
  
  ## With covariates
  X <- matrix(c(stats::rbinom(length(Y),5,0.5), stats::rbinom(length(Y),5,0.5), 
                stats::rbinom(length(Y),5,0.5)), ncol = 3)
  beta = c(-2, 0.5, 1)
  df <- .dataframe_fun(Y, I, X, s, lambda, bp = 3, J)
  
  # NAs present, should it return NA? How should we handle NAs? [Q]
  Y_NA <-  c(NA, 13, 13, 18, 23)
  I_NA <- c(NA , 1, 0, 1, 1)
  df <- .dataframe_fun(Y_NA, I_NA, X, s, lambda, bp = 3, J)
  expect_equal(sum(is.na(.log_likelihood(df, beta = beta))), 1)
  
  # Message for zero/high/low?
  
})

Y <- c(1, 20, 30)
Y_0 <- c(1, 20, 31)
X <- matrix(1, nrow = 3, ncol = 1)
X_0 <- NULL
tuning_parameters <- list("cprop_beta" = 1,
                          "Jmax" = 10,
                          "pi_b" = 0.5,
                          "alpha" = 0.4)
hyper <- list("a_tau" = 1, 
              "b_tau" = 1, 
              "c_tau" = 1, 
              "d_tau" = 1, 
              "p_0" = 0.1, 
              "clam_smooth" = 0.7, 
              "type" = "mix", 
              "a_sigma" = 1, 
              "b_sigma" = 2, 
              "phi" = 2)

initial_values <- list("J" = 2, 
                       "s_r" = c(5, 10), 
                       "mu" = 5, 
                       "sigma2" = 0.5, 
                       "tau" = c(0.1, 0.2, 0.3), 
                       "lambda_0" = c(0.1, 0.2, 0.3), 
                       "lambda" = c(0.1, 0.2, 0.3), 
                       "beta_0" = NULL, 
                       "beta" = -0.5) 

test_that("Input check: valid inputs do not produce errors/warnings", {
 expect_no_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, NULL, hyper))
 expect_no_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper))
})

test_that("Input check: Negative hyperparameter values produce errors", {
  hyper$a_sigma <- -1
  
  expect_error(.input_check(Y, Y_0, X, X_0,  tuning_parameters, NULL, hyper), regexp = "negative")
  expect_error(.input_check(Y, Y_0, X, X_0,  tuning_parameters, initial_values, hyper), regexp = "negative")
})

test_that("Input check: Hyperparameters outside [0, 1] range produce errors", {
  tuning_parameters$pi_b <- 1.3 #error

  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, NULL, hyper), regexp = "range")
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "range")
})

test_that("Input check: borrowing type 'uni' with given c_tau and d_tau produces a warning", {
  hyper$type <- "uni"
    suppressMessages( expect_message(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), "borrow is 'uni'"))
})

test_that("Input check: s_r values greater than maxSj produce errors", {
  initial_values$s_r = c(5, 50)
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, 
                            hyper), regexp = "s_r must be <")
})

test_that("Input check: negative sigma2 value produces an error", {
  initial_values$sigma2 <- -0.5
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "sigma2 must be > 0")
})

test_that("Input check: incorrect dimensions for tau produce error", {
 initial_values$tau = c(0.1, 0.2, 0.3, 0.1)
 expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "dimension")

 initial_values$lambda = c(0.1, 0.2, 0.3, 0.1)
 expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "dimension")
})

test_that("Input check: incorrect dimensions for lambda produce error", {
  initial_values$lambda_0 = c(0.1, 0.2, 0.3, 0.1)
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "dimension")
})

test_that("Input check: Negative lambdas renders error", {
  initial_values$lambda <- c(-0.1, 0.2, 0.3)
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "baseline hazard")
})

test_that("Input check: throws error for wrong dimension of beta/beta_0 when adding covariates", {
  X_0 <- matrix(c(1,0, 0), nrow = 3, ncol = 1)
  tuning_parameters$cprop_beta_0 <- 0.5
  initial_values$beta_0 <- NULL
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "dimension")
  
  initial_values$beta = c(1, 2)
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper), regexp = "beta")
  
})


test_that("Input check for cprop_beta dimensions", {
  tuning_parameters$cprop_beta = c(1, 1)
  expect_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper),
               regexp = "dimension mismatch")
})

test_that("group_summary() is working as it should", {
  Y <- stats::rweibull(20, 10, 0.4)
  I <- stats::rbinom(20, 1, 0.2)
  
  #W Without covariates
  X <- NULL
  
  s <- c(0, quantile(Y, probs = c(0.25, 0.75)), max(Y))
  
  # Throws no error for normal input
  expect_no_error(group_no_covariates <- group_summary(Y, I, X, s))
  expect_true(any(!is.na(group_no_covariates)))
  
  # Has correct output
  expect_equal(sum(group_no_covariates$events), sum(I))
  expect_equal(sum(group_no_covariates$num_cnsr), sum(I == 0))
  
  #W With covariates
  X <- stats::rbinom(20, 1, 0.5)
  
  # Throws no error for normal input
  expect_no_error(group <- group_summary(Y, I, X, s))
  expect_true(any(!is.na(group)))
  
  # Has correct output
  expect_equal(sum(group$events_c), sum(I[X == 0])) # control
  expect_equal(sum(group$events_t), sum(I[X == 1])) # treatment
  expect_true(all(group$num_at_risk_c + group$num_at_risk_t == group_no_covariates$num_at_risk))
  
  
})

test_that("init_lambda_hyperparameters() is working as it should", {
  Y <- stats::rweibull(20, 10, 0.4)
  I <- stats::rbinom(20, 1, 0.2)
  
  # Without covariates
  X <- NULL
  
  s <- c(0, quantile(Y, probs = c(0.25, 0.75)), max(Y))
  
  # Throws no error for normal input
  group_data <- group_summary(Y, I, X, s)
  expect_no_error(lambdas <- init_lambda_hyperparameters(group_data, s, w = 0.5))
  
  # Shape is correct:
  expect_length(lambdas$shape, length(s) - 1)
  expect_length(lambdas$rate, length(s) - 1)

})

test_that("Input check runs for only historical/current data (NoBorrow)" ,{
  Y <- c(1, 20, 30)
  Y_0 <- NULL
  X <- matrix(1, nrow = 3, ncol = 1)
  X_0 <- NULL
  tuning_parameters <- list("cprop_beta" = 1,
                            "Jmax" = 10,
                            "pi_b" = 0.5)
  hyper <- list("a_sigma" = 1, 
                "b_sigma" = 2, 
                "phi" = 2)
  
  initial_values <- list("J" = 2, 
                         "s_r" = c(5, 10), 
                         "mu" = 5, 
                         "sigma2" = 0.5, 
                         "lambda" = c(0.1, 0.2, 0.3), 
                         "beta" = -0.5) 
  
  expect_no_error(.input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper))
  
  s <- .input_check(Y, Y_0, X, X_0, tuning_parameters, initial_values, hyper)
  expect_equal(s, "No borrow")
})

test_that("Setting tuning_parameters works" ,{
  # With borrowing, without covariates on historical, everything given
  X <- matrix(1, nrow = 3, ncol = 1)
  X_0 <- NULL
  tuning_parameters <- list("cprop_beta" = 1,
                            "Jmax" = 10,
                            "pi_b" = 0.5,
                            "alpha" = 1)
  
  new_tuning_param <- .set_tuning_parameters(tuning_parameters = tuning_parameters, 
                                             borrow = TRUE, X, X_0)
  
 expect_equal(tuning_parameters, new_tuning_param)
 
 # With borrowing, withcovariates on historical, missing historical cprop
 X <- matrix(1, nrow = 3, ncol = 1)
 X_0 <- matrix(1, nrow = 3, ncol = 1)
 tuning_parameters <- list("cprop_beta" = 1,
                           "Jmax" = 10,
                           "pi_b" = 0.5,
                           "alpha" = 1)
 
  suppressMessages(expect_message( new_tuning_param <- .set_tuning_parameters(tuning_parameters = tuning_parameters, 
                                            borrow = TRUE, X, X_0),
 "The following tuning_parameters were set to default: cprop_beta_0"))
 
 expect_equal(new_tuning_param$cprop_beta_0, 0.5)
 expect_equal(new_tuning_param$cprop_beta, tuning_parameters$cprop_beta)
 
 
 # Without borrowing, without covariates on historical, everything given
 X <- matrix(1, nrow = 3, ncol = 1)
 X_0 <- NULL
 tuning_parameters <- list("cprop_beta" = 1,
                           "Jmax" = 10,
                           "pi_b" = 0.5)
 
 new_tuning_param <- .set_tuning_parameters(tuning_parameters = tuning_parameters, 
                                            borrow = FALSE, X, X_0)
 
 expect_equal(tuning_parameters, new_tuning_param)
 
 # Without borrowing, without covariates on historical, none given
 X <- matrix(1, nrow = 3, ncol = 1)
 X_0 <- NULL
 tuning_parameters_default <- list("Jmax" = 5,
                           "pi_b" = 0.5,
                           "cprop_beta" = 0.5)
 
  suppressMessages(expect_message(new_tuning_param <- .set_tuning_parameters(tuning_parameters = NULL, 
                                            borrow = FALSE, X, X_0),
                                    "The following tuning_parameters were set to default: Jmax, pi_b, cprop_beta"))
 
 expect_equal(new_tuning_param, tuning_parameters_default)
})

test_that("Setting hyperparameters works" ,{
  # mix, everything given
  hyperparameters_mix_default <- list(
    "a_tau" = 1,
    "b_tau" = 0.001,
    "c_tau" = 1,
    "d_tau" = 1,
    "type" = "mix",
    "p_0" = 0.8,
    "a_sigma" = 1,
    "b_sigma" = 1,
    "phi" = 3, 
    "clam_smooth" = 0.8)
  
  suppressMessages(
  new_hyperparameters <- .set_hyperparameters(hyperparameters = hyperparameters_mix_default, model_choice = "mix"))
  
  expect_equal(new_hyperparameters, hyperparameters_mix_default)
  
  # all, everything given
  hyperparameters <- list(
    "a_tau" = 1,
    "b_tau" = 0.001,
    "c_tau" = 1,
    "d_tau" = 1,
    "type" = "all",
    "p_0" = 0.8,
    "a_sigma" = 1,
    "b_sigma" = 1,
    "phi" = 3, 
    "clam_smooth" = 0.8)
  
  suppressMessages(
  new_hyperparameters <- .set_hyperparameters(hyperparameters = hyperparameters, model_choice = "all"))
  
  expect_equal(new_hyperparameters, hyperparameters)
  
  
  # uni, everything given
  hyperparameters <- list(
    "a_tau" = 1,
    "b_tau" = 0.001,
    "type" = "uni",
    "a_sigma" = 1,
    "b_sigma" = 1,
    "phi" = 3, 
    "clam_smooth" = 0.8)
  
  suppressMessages(
  new_hyperparameters <- .set_hyperparameters(hyperparameters = hyperparameters, model_choice = "uni"))
  
  expect_equal(new_hyperparameters, hyperparameters)
  
  
  # no_borrow, everything given
  hyperparameters_default <- list(
    "a_sigma" = 1,
    "b_sigma" = 1,
    "phi" = 3, 
    "clam_smooth" = 0.8)
  
  suppressMessages(
  new_hyperparameters <- .set_hyperparameters(hyperparameters = hyperparameters_default, model_choice = "no_borrow"))
  
  expect_equal(new_hyperparameters, hyperparameters_default)
  # mix, bits missing
  hyperparameters <- list(
    "a_tau" = 1,
    "b_tau" = 0.001,
    "type" = "mix",
    "p_0" = 0.8,
    "a_sigma" = 1,
    "b_sigma" = 1,
    "phi" = 3)
  
  suppressMessages(expect_message(  new_hyperparameters <- .set_hyperparameters(hyperparameters = hyperparameters, model_choice = "mix"),
  "The following hyperparameters were set to default: c_tau, d_tau, clam_smooth"))
  
  expect_equal(new_hyperparameters[order(names(new_hyperparameters))], 
               hyperparameters_mix_default[order(names(hyperparameters_mix_default))])
  
  hyperparameters <- list(
    "a_tau" = 1,
    "b_tau" = 0.001,
    "type" = "mix",
    "p_0" = 0.8,
    "a_sigma" = 10,
    "b_sigma" = 1,
    "phi" = 3)
  
  suppressMessages(
    expect_message(new_hyperparameters <- .set_hyperparameters(hyperparameters = hyperparameters, model_choice = "mix"),
                   "The following hyperparameters were set to default: c_tau, d_tau, clam_smooth"))
  
  suppressMessages(
  expect_equal(hyperparameters$a_sigma, new_hyperparameters$a_sigma))
  
  # no_borow, bits missing
  suppressMessages(
    expect_message(new_hyperparameters <- .set_hyperparameters(hyperparameters = NULL, model_choice = "no_borrow"),
  "The following hyperparameters were set to default: a_sigma, b_sigma, phi, clam_smooth"))
  
  expect_equal(new_hyperparameters[order(names(new_hyperparameters))], 
               hyperparameters_default[order(names(hyperparameters_default))])
})