tests/testthat/test-sls_main.R

In Giappo/sls: Likelihood model for diversification processes with single lineage rate shifts

context("sls_main")

is_on_ci <- function() {
  is_it_on_appveyor <- Sys.getenv("APPVEYOR") != ""
  is_it_on_travis <- Sys.getenv("TRAVIS") != ""
  is_it_on_appveyor || is_it_on_travis # nolint internal function
}

test_that("use", {
  sim_pars <- c(0.25, 0.1, 0.6, 0.1)
  cond <- 3
  loglik_functions <- sls::sls_logliks_div()
  loglik_functions <-
    loglik_functions[-which(loglik_functions == "loglik_sls_p2")] # remove this
  crown_age <- 4
  shift_time <- 1.5
  l_2 <- sls::sim_get_standard_l_2(
    crown_age = crown_age,
    shift_time = shift_time
  )
  n_0 <- l_2$n_0[1]
  t_0s <- l_2$birth_time
  optim_ids <- c(TRUE, TRUE, TRUE, TRUE)
  seed_interval <- 6:(6 + 3 * is_on_ci()); seed <- seed_interval[1]
  for (seed in seed_interval) {
    # seed = 6 is critical!
    test <- sls::sls_main(
      seed = seed,
      sim_pars = sim_pars,
      cond = cond,
      crown_age = crown_age,
      shift_time = shift_time,
      start_pars = c(0.2, 0.1, 0.2, 0.1),
      loglik_functions = loglik_functions,
      optim_ids = optim_ids,
      verbose = FALSE,
      max_iterations = 500
    )
    testthat::expect_true(
      is.data.frame(test)
    )
    testthat::expect_true(
      length(test$sim_lambda_m) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$sim_mu_m) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$sim_lambda_s) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$sim_mu_s) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$lambda_m) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$mu_m) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$lambda_s) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$mu_s) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$loglik) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$df) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$conv) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$tips_1) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$tips_2) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$seed) == length(loglik_functions)
    )
    testthat::expect_true(
      length(unique(test$seed)) == 1
    )
    testthat::expect_true(
      length(test$tips_1) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$tips_2) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$cond) == length(loglik_functions)
    )
    testthat::expect_true(
      all(
        is.numeric(test$cond)
      )
    )
    testthat::expect_true(
      all(
        test$n_0 == l_2$n_0[1]
      )
    )
    testthat::expect_true(
      all(
        test$t_0_1 == l_2$birth_time[1]
      )
    )
    testthat::expect_true(
      all(
        test$t_0_2 == l_2$birth_time[2]
      )
    )
    testthat::expect_true(
      length(test$optim_lambda_m) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$optim_mu_m) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$optim_lambda_s) == length(loglik_functions)
    )
    testthat::expect_true(
      length(test$optim_mu_s) == length(loglik_functions)
    )
    testthat::expect_true(
      all(
        c(
          test$optim_lambda_m,
          test$optim_mu_m,
          test$optim_lambda_s,
          test$optim_mu_s
        ) %in% c("TRUE", "FALSE")
      )
    )
    testthat::expect_true(
      length(test$model) == length(loglik_functions)
    )

    # test file saving
    pkg_name <- get_pkg_name() # nolint internal function
    if (.Platform$OS.type == "windows") {
      project_folder <- system.file("extdata", package = pkg_name)
    } else {
      project_folder <- getwd()
    }
    # check data folder existence
    data_folder <- file.path(project_folder, "data")
    testthat::expect_true(
      file.exists(data_folder)
    )
    # check results folder existence
    results_folder <- file.path(project_folder, "results")
    testthat::expect_true(
      file.exists(results_folder)
    )
    # check data file existence
    data_file_name <- create_data_file_name( # nolint internal function
      data_folder = data_folder,
      sim_pars = sim_pars,
      optim_ids = optim_ids,
      cond = cond,
      n_0 = n_0,
      t_0s = t_0s,
      seed = seed
    )
    testthat::expect_true(
      file.exists(data_file_name)
    )
    suppressWarnings(file.remove(data_file_name))
    # check results file existence
    results_file_name <- create_results_file_name( # nolint internal function
      results_folder = results_folder,
      sim_pars = sim_pars,
      optim_ids = optim_ids,
      cond = cond,
      n_0 = n_0,
      t_0s = t_0s,
      seed = seed
    )
    testthat::expect_true(
      file.exists(results_file_name)
    )
    # check if saved results are the right ones
    testthat::expect_equal(
      utils::read.csv(results_file_name)[, -1],
      test
    )
    suppressWarnings(file.remove(results_file_name))
  }
  # test silent mode and character entry for "loglik_functions" input
  seed <- 99
  testthat::expect_silent(
    test <- sls::sls_main(
      seed = seed,
      sim_pars = sim_pars,
      cond = cond,
      crown_age = crown_age,
      shift_time = shift_time,
      start_pars = c(0.2, 0.1, 0.2, 0.1),
      loglik_functions = "loglik_sls_p",
      optim_ids = optim_ids,
      verbose = FALSE,
      max_iterations = 50
    )
  )
  testthat::expect_true(
    is.data.frame(test)
  )
  # check data file existence
  data_file_name <- sls::create_data_file_name( # nolint internal function
    data_folder = data_folder,
    sim_pars = sim_pars,
    optim_ids = optim_ids,
    cond = cond,
    n_0 = n_0,
    t_0s = t_0s,
    seed = seed
  )
  testthat::expect_true(
    file.exists(data_file_name)
  )
  suppressWarnings(file.remove(data_file_name))
  # check results file existence
  results_file_name <- create_results_file_name( # nolint internal function
    results_folder = results_folder,
    sim_pars = sim_pars,
    optim_ids = optim_ids,
    cond = cond,
    n_0 = n_0,
    t_0s = t_0s,
    seed = seed
  )
  testthat::expect_true(
    file.exists(results_file_name)
  )
  # check if saved results are the right ones
  testthat::expect_equal(
    utils::read.csv(results_file_name)[, -1],
    test
  )
  suppressWarnings(file.remove(results_file_name))
})

test_that("it saves only once", {

  if (!is_on_ci()) {
    skip("This only runs on CI")
  } else {
    seed <- 1
    sim_pars <- c(0.27, 0.15, 0.5, 0.1)
    cond <- 3
    crown_age <- 2.5
    shift_time <- 1.8
    project_folder <- tempdir()
    results_folder <- file.path(
      project_folder,
      "results"
    )

    fn <- create_results_file_name(
      results_folder = results_folder,
      sim_pars = sim_pars,
      optim_ids = rep(TRUE, length(sim_pars)),
      cond = cond,
      n_0 = 2,
      t_0s = c(crown_age, shift_time),
      seed = seed
    ); fn

    test_p <- sls_main(
      seed = seed,
      sim_pars = sim_pars,
      cond = cond,
      start_pars = sim_pars,
      loglik_functions = loglik_sls_p,
      crown_age = crown_age,
      shift_time = shift_time,
      verbose = FALSE,
      project_folder = project_folder,
      max_iterations = 100
    )
    x <- utils::read.csv(
      file = fn
    )[, -1]

    test_p2 <- sls_main(
      seed = seed,
      sim_pars = sim_pars,
      cond = cond,
      start_pars = sim_pars,
      loglik_functions = loglik_sls_p,
      crown_age = crown_age,
      shift_time = shift_time,
      verbose = FALSE,
      project_folder = project_folder,
      max_iterations = 100
    )
    y <- utils::read.csv(
      file = fn
    )[, -1]

    testthat::expect_equal(
      x, y
    )
  }
})

test_that("it works also for a subset of parameters", {

  seed <- 10
  sim_pars <- c(0.3, 0.1, 0.6, 0.1)
  cond <- 3
  crown_age <- 4
  shift_time <- 2
  l_2 <- sls::sim_get_standard_l_2(
    crown_age = crown_age,
    shift_time = shift_time
  )
  n_0 <- l_2$n_0[1]
  t_0s <- l_2$birth_time
  loglik_functions <- sls_logliks_div()
  loglik_functions <-
    loglik_functions[-which(loglik_functions == "loglik_sls_p2")] # remove this
  optim_ids <- c(TRUE, FALSE, FALSE, FALSE)

  test <- sls::sls_main(
    seed = seed,
    sim_pars = sim_pars,
    cond = cond,
    crown_age = crown_age,
    shift_time = shift_time,
    start_pars = c(0.2, 0.1, 0.2, 0.1),
    loglik_functions = loglik_functions,
    verbose = FALSE,
    optim_ids = optim_ids,
    max_iterations = 100
  )
  testthat::expect_true(
    is.data.frame(test)
  )
  testthat::expect_true(
    all(test$sim_mu_m == test$mu_m)
  )
  testthat::expect_true(
    all(test$sim_lambda_s == test$lambda_s)
  )
  testthat::expect_true(
    all(test$sim_mu_s == test$mu_s)
  )
  pkg_name <- get_pkg_name() # nolint internal function
  # test file saving
  if (.Platform$OS.type == "windows") {
    project_folder <- system.file("extdata", package = pkg_name)
  } else {
    project_folder <- getwd()
  }
  # check data folder existence
  data_folder <- file.path(project_folder, "data")
  testthat::expect_true(
    file.exists(data_folder)
  )
  # check results folder existence
  results_folder <- file.path(project_folder, "results")
  testthat::expect_true(
    file.exists(results_folder)
  )
  # check data file existence
  data_file_name <- create_data_file_name( # nolint internal function
    data_folder = data_folder,
    sim_pars = sim_pars,
    optim_ids = optim_ids,
    cond = cond,
    n_0 = n_0,
    t_0s = t_0s,
    seed = seed
  )
  testthat::expect_true(
    file.exists(data_file_name)
  )
  suppressWarnings(file.remove(data_file_name))
  # check results file existence
  results_file_name <- create_results_file_name( # nolint internal function
    results_folder = results_folder,
    sim_pars = sim_pars,
    optim_ids = optim_ids,
    cond = cond,
    n_0 = n_0,
    t_0s = t_0s,
    seed = seed
  )
  testthat::expect_true(
    file.exists(results_file_name)
  )
  suppressWarnings(file.remove(results_file_name))
})

test_that("abuse", {
  seed <- 1
  sim_pars <- c(0.3, 0.2, 0.6, 0.1)
  cond <- 3
  crown_age <- 5
  shift_time <- 2
  testthat::expect_error(
    sls_main(
      seed = seed,
      sim_pars = sim_pars,
      cond = cond,
      crown_age = crown_age,
      shift_time = shift_time,
      start_pars = c(0.2, 0.1, 0.2, 0.1),
      loglik_functions = "nonsense",
      verbose = FALSE
    ),
    paste0(
      "This is not a likelihood function provided by ",
      get_pkg_name(),
      "!"
    )
  )
})