tests/testthat/test_non_exported.R

context("Test non-exported functions")
current_R_version <- gsub("R version ([0-9.]+) .+$", "\\1", R.version.string)

## test .choose_possible_alpha ##
test_that("test: .choose_possible_alpha", {
  ## skip on CRAN
  skip_on_cran()


  ## get data
  ans1 <- outbreaker2:::.choose_possible_alpha(1:10, 1)
  ans2 <- outbreaker2:::.choose_possible_alpha(1:10, 10)
  ans3 <- outbreaker2:::.choose_possible_alpha(1:10, 2)
  ans4 <- outbreaker2:::.are_possible_alpha(1:10, 5)
  ans5 <- outbreaker2:::.are_possible_alpha(c(1:4, 1:3, 1), 2)
  ans6 <- outbreaker2:::.are_possible_alpha(1:10, 1)

  ## check output
  expect_true(is.na(ans1))
  expect_is(ans2, "integer")
  expect_true(ans2<10 || ans2>0)
  expect_equal(ans3, 1L)
  expect_error(.choose_possible_alpha(1:10, NA),
               "missing value where TRUE/FALSE needed")
  expect_equal(ans4, 1:4)
  expect_equal(ans5, c(1,5,8))
  expect_equal(ans6, NA)
})






## ancestry-related functions (R functions)
test_that("Auxiliary functions for ancestries are working", {
  ## skip on CRAN
  skip_on_cran()


  ## generate data
  alpha <- c(2, NA, 1, 3, 3, 1)
  t_inf <- c(2, 1, 3, 4, 4, 3)
  data <- outbreaker_data(dates = t_inf+1, w_dens = rep(1, 100))
  config <- create_config(init_tree = alpha, init_t_inf = t_inf, data = data)
  config2 <- config
  config2$move_alpha <- c(rep(TRUE,4),FALSE, TRUE)
  param <- create_param(config = config, data = data)$current

  ## test can be alpha
  expect_equal(can_move_alpha(param, config), c(TRUE, FALSE,rep(TRUE,4)))
  expect_equal(can_move_alpha(param, config2), c(TRUE, FALSE, TRUE, TRUE, FALSE, TRUE))

  ## test ancestor selection
  suppressWarnings(RNGversion("3.5.2"))
  set.seed(1)
  to_move <- replicate(10, select_alpha_to_move(param,config))
  expect_equal(to_move, c(3,3,4,6,3,6,6,5,5,1))
  to_move2 <- replicate(10, select_alpha_to_move(param,config2))
  expect_equal(to_move2, c(1,1,4,3,6,3,4,6,3,6))
  RNGversion(current_R_version)

})






## Test swapping of ancestries in Cpp
test_that("Ancestries swapping in Rcpp works", {
  skip_on_cran()

  ## make dummy tree
  param_old <- list(alpha = c(NA, 1L, 2L, 3L, 2L),
                    t_inf = c(1L, 2L, 3L, 4L, 3L),
                    kappa = c(1L, 2L, 1L, 1L, 1L))

  ## no swapping exception: i is imported
  param_new <- cpp_swap_cases(param_old, 1L)
  expect_identical(param_old, param_new)

  ## swap even when ancestor is imported
  param_new <- cpp_swap_cases(param_old, 2L)
  expect_equal(param_new$alpha, c(2L, NA, 1L, 3L, 1L))
  expect_equal(param_new$t_inf, c(2L, 1L, 3L, 4L, 3L))
  expect_equal(param_new$kappa, c(2L, 1L, 1L, 1L, 1L))

  ## swap 3 and 2
  param_new <- cpp_swap_cases(param_old, 3L)
  expect_equal(param_new$alpha, c(NA, 3L, 1L, 2L, 3L))
  expect_equal(param_new$t_inf, c(1L, 3L, 2L, 4L, 3L))

})






## test find_descendents ##
test_that("Testing find_descendents", {
  ## skip on CRAN
  skip_on_cran()


  ## generate data
  data <- with(fake_outbreak,
               outbreaker_data(dates = sample, w_dens = w, dna = dna))

  config <- create_config(data = data)
  param <- create_param(data = data, config = config)$current

  ## tests
  expect_equal(find_descendents(param, 1), c(2,4,28))
  expect_equal(find_descendents(param, 30), integer(0))

  ## test cpp version
  expect_equal(cpp_find_descendents(c(NA), 10), integer(0))
  expect_equal(cpp_find_descendents(c(1,NA,2,1), 1), c(1L, 4L))
  expect_equal(cpp_find_descendents(c(NA, 1,1,1,2,2,NA,1,1), 1),
               c(2L, 3L, 4L, 8L, 9L))
})






test_that("Testing add_convolutions", {
  ## skip on CRAN
  skip_on_cran()


  ## generate data
  data(fake_outbreak)
  data <- with(fake_outbreak,
               outbreaker_data(dates = sample,
                               w_dens = w,
                               dna = dna))
  config <- create_config(data = data)

  out <- add_convolutions(data = data, config = config)

  ## tests
  expect_is(out$log_w_dens, "matrix")
  expect_equal(dim(out$log_w_dens), c(5, length(out$w_dens)))
  expect_true(!any(is.na(out$log_w_dens)))

})






test_that("Testing cpp_find_local_cases", {
  ## skip on CRAN
  skip_on_cran()

  expect_equal(cpp_find_local_cases(NA, 1), 1L)
  expect_equal(cpp_find_local_cases(c(NA, 1, 2), 1), c(1L, 2L))
  expect_equal(cpp_find_local_cases(c(NA, 1, 1, 1), 1),
               as.integer(1:4))
  expect_equal(sort(cpp_find_local_cases(c(NA, 1, 1, 1), 2)),
               as.integer(1:4))

  tre <- c(NA, 1, 1, 3, 3, 5, 2)
  expect_equal(cpp_find_local_cases(tre, 1), 1:3)
  expect_equal(sort(cpp_find_local_cases(tre, 2)),
               c(1, 2, 3, 7))
  expect_equal(sort(cpp_find_local_cases(tre, 7)),
               c(2, 7))
  expect_equal(sort(cpp_find_local_cases(tre, 4)),
               c(3, 4, 5))
  expect_equal(sort(cpp_find_local_cases(tre, 5)),
               c(3, 4, 5, 6))
  expect_equal(sort(cpp_find_local_cases(tre, 6)),
               c(5, 6))

})






test_that("Testing cpp_get_n_mutations", {
  ## skip on CRAN
  skip_on_cran()


  ## sequences in natural order

  data <- outbreaker_data(dates = fake_outbreak$onset,
                          dna = fake_outbreak$dna,
                          w_dens = rep(1, 100))
  D <- data$D

  expect_equal(cpp_get_n_mutations(data, 1, 1), 0L)
  expect_equal(cpp_get_n_mutations(data, 11, 3), D[11, 3])
  expect_equal(cpp_get_n_mutations(data, 21, 30), D[21, 30])


  ## sequences in reverse order, named

  dna.rev <- fake_outbreak$dna
  rownames(dna.rev) <- as.character(30:1)

  data.rev <- outbreaker_data(dates = fake_outbreak$onset,
                              dna = dna.rev,
                              w_dens = rep(1, 100))
  D.rev <- data.rev$D

  expect_equal(rownames(D.rev), rownames(dna.rev))
  expect_equal(cpp_get_n_mutations(data.rev, 11, 3), D.rev["11", "3"])
  expect_equal(cpp_get_n_mutations(data.rev, 21, 30), D.rev["21", "30"])


  ## with some sequences
  dna.miss <- fake_outbreak$dna[c(3, 4, 11), ]
  rownames(dna.miss) <- c("3", "4", "11")

  data.miss <- outbreaker_data(dates = fake_outbreak$onset,
                               dna = dna.miss,
                               w_dens = rep(1, 100))
  D.miss <- data.miss$D

  expect_equal(rownames(D.miss), rownames(dna.miss))
  expect_equal(cpp_get_n_mutations(data.miss, 3, 4), D.miss["3", "4"])
  expect_equal(cpp_get_n_mutations(data.miss, 3, 4), D[3, 4])
  expect_equal(cpp_get_n_mutations(data.miss, 11, 3), D.miss["11", "3"])

  msg <- "Trying to get genetic distances between missing sequences."
  expect_error(cpp_get_n_mutations(data.miss, 1, 2), msg)


})






test_that("Look for sequenced ancestors", {

  ## skip on CRAN
  skip_on_cran()


  ## make inputs
  onset <- as.integer(c(0, 1, 2, 3, 2, 1, 2, 3))
  data <- outbreaker_data(dates = onset, w_dens = rep(1, 100))

  has_dna <- as.logical(c(0, 1, 0, 1, 1, 0, 0, 1))
  data$has_dna <- has_dna

  alpha <- as.integer(c(NA, 1, 2, 3, 2, 1, 6, 7))
  kappa <- as.integer(c(NA, 1, 1, 2, 1, 2, 1, 1))
  param <- list(alpha = alpha,
                kappa = kappa)


  ## make tests
  res <- lapply(as.integer(1:8),
                function(i) cpp_lookup_sequenced_ancestor(data, param, i))

  res <- Reduce(rbind, lapply(res, data.frame))
  exp_alpha <- c(NA, NA, NA, 2L, 2L, NA, NA, NA)
  exp_n_generations <- c(NA, NA, NA, 3L, 1L, NA, NA, NA)
  exp_found <- c(FALSE, FALSE, FALSE, TRUE, TRUE, FALSE, FALSE, FALSE)

  expect_equal(res$alpha, exp_alpha)
  expect_equal(res$n_generations, exp_n_generations)
  expect_equal(res$found_sequenced_ancestor, exp_found)

})
reconhub/outbreaker2 documentation built on July 5, 2022, 12:25 p.m.