--- a +++ b/tests/testthat/test_likelihoods.R @@ -0,0 +1,645 @@ +context("Test likelihood functions") + + +test_that("Test ll_timing_infections", { + ## skip on CRAN + skip_on_cran() + + ## generate data + times <- 0:4 + alpha <- c(NA,rep(1,4)) + w <- c(.1, .2, .5, .2, .1) + data <- outbreaker_data(dates = times, w_dens = w) + config <- create_config(data = data, init_tree = alpha) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 3, replace = FALSE)) + + + ## tests + out <- cpp_ll_timing_infections(data, param) + out_few_cases <- cpp_ll_timing_infections(data, param, few_cases) + out_rnd_cases <- cpp_ll_timing_infections(data, param, rnd_cases) + ref <- .ll_timing_infections(data, param) + ref_few_cases <- .ll_timing_infections(data, param, few_cases) + ref_rnd_cases <- .ll_timing_infections(data, param, rnd_cases) + + expect_is(out, "numeric") + expect_equal(out, -6.59584881763949) + expect_equal(out_few_cases, -2.4932054526027) + + ## test against reference + expect_equal(out, ref) + expect_equal(out_few_cases, ref_few_cases) + expect_equal(out_rnd_cases, ref_rnd_cases) + +}) + + + + + + +test_that("Test cpp_ll_timing_sampling", { + ## skip on CRAN + skip_on_cran() + + + ## generate data + times <- 0:4 + alpha <- c(NA,rep(1,4)) + samp_times <- times + c(1, 1, 2, 3, 4) + f <- c(.1, .2, .5, .2, .1) + data <- outbreaker_data(dates = samp_times, w_dens = f, f_dens = f) + config <- create_config(data = data, + init_t_inf = times, + init_tree = alpha) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 3, replace = FALSE)) + + + ## tests + out <- cpp_ll_timing_sampling(data, param) + out_few_cases <- cpp_ll_timing_sampling(data, param, few_cases) + out_rnd_cases <- cpp_ll_timing_sampling(data, param, rnd_cases) + ref <- .ll_timing_sampling(data, param) + ref_few_cases <- .ll_timing_sampling(data, param, few_cases) + ref_rnd_cases <- .ll_timing_sampling(data, param, rnd_cases) + + expect_is(out, "numeric") + expect_equal(out, -8.99374409043786) + expect_equal(out_few_cases, -4.89110072540107) + + ## test against reference + expect_equal(out, ref) + expect_equal(out_few_cases, ref_few_cases) + expect_equal(out_rnd_cases, ref_rnd_cases) + +}) + + + + + + +test_that("Test cpp_ll_genetic", { + ## 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, init_mu = 0.543e-4) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 5, replace = FALSE)) + + + ## tests ## + ## expected values + + out <- cpp_ll_genetic(data, param) + out_few_cases <- cpp_ll_genetic(data, param, few_cases) + out_rnd_cases <- cpp_ll_genetic(data, param, rnd_cases) + ref <- .ll_genetic(data, param) + ref_few_cases <- .ll_genetic(data, param, few_cases) + ref_rnd_cases <- .ll_genetic(data, param, rnd_cases) + + expect_is(out, "numeric") + expect_equal(out, -997.840630501522) + expect_equal(out_few_cases, -266.251194283819) + + + ## test against R reference + + expect_equal(out, ref) + expect_equal(out_few_cases, ref_few_cases) + expect_equal(out_rnd_cases, ref_rnd_cases) + + + ## test with random sequence order + + dna_resort <- fake_outbreak$dna + rownames(dna_resort) <- as.character(1:30) + dna_resort <- dna_resort[sample(1:30), ] + data_resort <- outbreaker_data(dates = fake_outbreak$sample, + w_dens = fake_outbreak$w, + dna = dna_resort) + expect_equal(cpp_ll_genetic(data, param), + cpp_ll_genetic(data_resort, param)) + + + ## randoms sequence order, missing sequences + + dna_miss <- fake_outbreak$dna[1:10, ] + rownames(dna_miss) <- as.character(1:10) + dna_miss <- dna_miss[sample(1:10), ] + data_miss <- outbreaker_data(dates = fake_outbreak$sample, + w_dens = fake_outbreak$w, + dna = dna_miss) + param_star <- param + param_star$alpha <- c(NA, rep(1L, 29)) + + expect_equal(which(data_miss$has_dna), 1:10) + expect_equal(cpp_ll_genetic(data, param_star, 1:10), + cpp_ll_genetic(data_miss, param_star)) + + + ## Test that mu values outside range [0,1] give -Inf + param$mu <- -.12 + expect_equal(-Inf, cpp_ll_genetic(data, param)) + param$mu <- 1.89 + expect_equal(-Inf, cpp_ll_genetic(data, param)) + +}) + + + + + + +test_that("Test cpp_ll_genetic with some missing sequences", { + + ## skip on CRAN + + skip_on_cran() + + + ## create data + + alpha <- as.integer(c(NA, 1, 2, 3, 2, 5)) + kappa <- as.integer(c(NA, 1, 2, 1, 2, 1)) + onset <- as.integer(c(0, 1, 2, 3, 2, 3)) + mu <- 0.001231 + w <- c(0, 1, 2, 1, .5) + dna <- matrix("a", ncol = 50, nrow = 3) + rownames(dna) <- c("3", "6", "2") + dna["3", 1:4] <- "t" + dna["6", 9:10] <- "t" + dna <- ape::as.DNAbin(dna) + data <- outbreaker_data(dates = onset, + dna = dna, + w_dens = w) + param <- list(alpha = alpha, + kappa = kappa, + mu = mu) + + ## tests + + n_mut_1 <- 4 + n_mut_2 <- 2 + kappa_1 <- 2 + kappa_2 <- 3 + + exp_ll <- n_mut_1*log(mu*kappa_1) + + (50 - n_mut_1)*log(1 - kappa_1*mu) + + n_mut_2*log(mu*kappa_2) + + (50 - n_mut_2)*log(1 - kappa_2*mu) + + ## Need to add_convolutions so that cpp_ll_genetic can extract max_kappa + ## from nrow(w_dens) - otherwise w_dens is a vector + data <- add_convolutions(data, create_config()) + expect_equal(cpp_ll_genetic(data, param), + exp_ll) + +}) + + + + + + + +test_that("Test cpp_ll_reporting", { + ## 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, init_mu = 0.543e-4) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 3, replace = FALSE)) + + + ## tests + out <- cpp_ll_reporting(data, param) + out_few_cases <- cpp_ll_reporting(data, param, few_cases) + out_rnd_cases <- cpp_ll_reporting(data, param, rnd_cases) + ref <- .ll_reporting(data, param) + ref_few_cases <- .ll_reporting(data, param, few_cases) + ref_rnd_cases <- .ll_reporting(data, param, rnd_cases) + + expect_is(out, "numeric") + expect_equal(out, -3.05545495407696) + expect_equal(out_few_cases, -0.210721031315653) + + ## test against reference + expect_equal(out, ref) + expect_equal(out_few_cases, ref_few_cases) + expect_equal(out_rnd_cases, ref_rnd_cases) + +}) + + + + + + +test_that("Test cpp_ll_timing", { + ## 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) + param <- create_param(data = data, config = config)$current + + ## compute likelihoods + out <- cpp_ll_timing(data, param) + + ## test expected values + expect_is(out, "numeric") + expect_equal(out, -135.36151006767) + + ## test that likelihoods add up + expect_equal(out, cpp_ll_timing_sampling(data, param) + + cpp_ll_timing_infections(data, param)) + +}) + + + + + + +test_that("Test cpp_ll_all", { + ## 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) + param <- create_param(data = data, config = config)$current + + ## compute likelihoods + out <- cpp_ll_all(data, param = param) + out_timing <- cpp_ll_timing(data, param = param) + out_genetic <- cpp_ll_genetic(data, param = param) + out_reporting <- cpp_ll_reporting(data, param = param) + + ## test expected values + expect_is(out, "numeric") + expect_equal(out, -1088.442451816) + + ## test that likelihoods add up + expect_equal(out_timing + out_genetic + out_reporting, out) + +}) + + + + + + + +test_that("Test cpp_ll_all", { + ## 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) + param <- create_param(data = data, config = config)$current + + ## compute local likelihoods + sum_local_timing_sampling <- sum(sapply(seq_len(data$N), + function(i) cpp_ll_timing_sampling(data, param, i))) + + sum_local_timing_infections <- sum(sapply(seq_len(data$N), + function(i) cpp_ll_timing_infections(data, param, i))) + + sum_local_timing <- sum(sapply(seq_len(data$N), + function(i) cpp_ll_timing(data, param, i))) + + sum_local_genetic <- sum(sapply(seq_len(data$N), + function(i) cpp_ll_genetic(data, param, i))) + + sum_local_reporting <- sum(sapply(seq_len(data$N), + function(i) cpp_ll_reporting(data, param, i))) + + sum_local_all <- sum(sapply(seq_len(data$N), + function(i) cpp_ll_all(data, param, i))) + + out_timing <- cpp_ll_timing(data, param = param) + out_timing_sampling <- cpp_ll_timing_sampling(data, param = param) + out_timing_infections <- cpp_ll_timing_infections(data, param = param) + out_genetic <- cpp_ll_genetic(data, param = param) + out_reporting <- cpp_ll_reporting(data, param = param) + out_all <- cpp_ll_all(data, param = param) + + ## tests sum of local against global + expect_equal(sum_local_timing_sampling, out_timing_sampling) + expect_equal(sum_local_timing_infections, out_timing_infections) + expect_equal(sum_local_timing, out_timing) + expect_equal(sum_local_genetic, out_genetic) + expect_equal(sum_local_reporting, out_reporting) + expect_equal(sum_local_all, out_all) + + ## test internal sums add up + expect_equal(sum_local_timing_sampling + sum_local_timing_infections, sum_local_timing) + expect_equal(sum_local_timing + sum_local_genetic + sum_local_reporting, sum_local_all) + +}) + + + + + + +test_that("likelihood functions return -Inf when needed", { + ## skip on CRAN + skip_on_cran() + + ## generate data + times <- 4:0 + alpha <- c(NA,rep(1,4)) + w <- c(.1, .2, .5, .2, .1) + data <- outbreaker_data(dates = times, w_dens = w) + config <- create_config(data = data, init_tree = alpha) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 3, replace = FALSE)) + + + ## test cpp_ll_timing_infection ## + out_infections <- cpp_ll_timing_infections(data, param) + out_infections_few_cases <- cpp_ll_timing_infections(data, param, few_cases) + out_infections_rnd_cases <- cpp_ll_timing_infections(data, param, rnd_cases) + ref <- .ll_timing_infections(data, param) + ref_few_cases <- .ll_timing_infections(data, param, few_cases) + ref_rnd_cases <- .ll_timing_infections(data, param, rnd_cases) + + ## test values + expect_is(out_infections, "numeric") + expect_equal(out_infections, -Inf) + expect_equal(out_infections_few_cases, -Inf) + + ## test against reference + expect_equal(out_infections, ref) + expect_equal(out_infections_few_cases, ref_few_cases) + expect_equal(out_infections_rnd_cases, ref_rnd_cases) + + + + + ## test cpp_ll_timing_sampling ## + old_t_inf <- param$t_inf + param$t_inf <- times + out_sampling <- cpp_ll_timing_sampling(data, param) + out_sampling_few_cases <- cpp_ll_timing_sampling(data, param, few_cases) + out_sampling_rnd_cases <- cpp_ll_timing_sampling(data, param, rnd_cases) + ref <- .ll_timing_sampling(data, param) + ref_few_cases <- .ll_timing_sampling(data, param, few_cases) + ref_rnd_cases <- .ll_timing_sampling(data, param, rnd_cases) + param$t_inf <- old_t_inf + + ## test values + expect_is(out_sampling, "numeric") + expect_equal(out_sampling, -Inf) + expect_equal(out_sampling_few_cases, -Inf) + + ## test against reference + expect_equal(out_sampling, ref) + expect_equal(out_sampling_few_cases, ref_few_cases) + expect_equal(out_sampling_rnd_cases, ref_rnd_cases) + + + + + ## test cpp_ll_timing ## + out_timing <- cpp_ll_timing(data, param) + out_timing_few_cases <- cpp_ll_timing(data, param, few_cases) + out_timing_rnd_cases <- cpp_ll_timing(data, param, rnd_cases) + + ## test values + expect_is(out_timing, "numeric") + expect_equal(out_timing, -Inf) + expect_equal(out_timing_few_cases, -Inf) + + + + ## test cpp_ll_all ## + out_all <- cpp_ll_all(data, param) + out_all_few_cases <- cpp_ll_all(data, param, few_cases) + out_all_rnd_cases <- cpp_ll_all(data, param, rnd_cases) + + ## test values + expect_is(out_all, "numeric") + expect_equal(out_all, -Inf) + expect_equal(out_all_few_cases, -Inf) + + ## test against reference + expect_equal(out_all, ref) + expect_equal(out_all_few_cases, ref_few_cases) + expect_equal(out_all_rnd_cases, ref_rnd_cases) + +}) + + + + + + +test_that("Customisation with identical functions works", { + + ## skip on CRAN + skip_on_cran() + + ## check custom_likelihoods + expect_identical(custom_likelihoods(), + custom_likelihoods(custom_likelihoods())) + + ## generate data + data(fake_outbreak) + data <- with(fake_outbreak, + outbreaker_data(dates = sample, + w_dens = w, + dna = dna)) + config <- create_config(data = data, init_mu = 0.543e-4) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 5, replace = FALSE)) + + + ## generate custom functions with 2 arguments + f_genetic <- function(data, param) cpp_ll_genetic(data, param) + f_timing_infections <- function(data, param) cpp_ll_timing_infections(data, param) + f_timing_sampling <- function(data, param) cpp_ll_timing_sampling(data, param) + f_contact <- function(data, param) cpp_ll_contact(data, param) + f_reporting <- function(data, param) cpp_ll_reporting(data, param) + + list_functions <- custom_likelihoods(genetic = f_genetic, + timing_infections = f_timing_infections, + timing_sampling = f_timing_sampling, + contact = f_contact, + reporting = f_reporting) + + + ## tests + expect_equal(cpp_ll_genetic(data, param), + cpp_ll_genetic(data, param, , list_functions[['genetic']])) + + expect_equal(cpp_ll_timing_infections(data, param), + cpp_ll_timing_infections(data, param, , list_functions[['timing_infections']])) + + + expect_equal(cpp_ll_timing_sampling(data, param), + cpp_ll_timing_sampling(data, param, , list_functions[['timing_sampling']])) + + expect_equal(cpp_ll_contact(data, param), + cpp_ll_contact(data, param, , list_functions[['contact']])) + + expect_equal(cpp_ll_reporting(data, param), + cpp_ll_reporting(data, param, , list_functions[['reporting']])) + + expect_equal(cpp_ll_timing(data, param), + cpp_ll_timing(data, param, , list_functions)) + + expect_equal(cpp_ll_all(data, param), + cpp_ll_all(data, param, , list_functions)) + +}) + + + + + + +test_that("Customisation with pi-returning functions works", { + + ## 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, init_mu = 0.543e-4) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 5, replace = FALSE)) + + + ## generate custom functions with 2 arguments + f <- function(data, param) return(pi); + + list_functions <- custom_likelihoods(genetic = f, + timing_infections = f, + timing_sampling = f, + reporting = f) + + + ## tests + expect_equal(pi, + cpp_ll_genetic(data, param, , list_functions[['genetic']])) + + expect_equal(pi, + cpp_ll_timing_infections(data, param, , list_functions[['timing_infections']])) + + expect_equal(pi, + cpp_ll_timing_sampling(data, param, , list_functions[['timing_sampling']])) + + expect_equal(pi, + cpp_ll_reporting(data, param, , list_functions[['reporting']])) + + expect_equal(2 * pi, + cpp_ll_timing(data, param, , list_functions)) + + expect_equal(4 * pi, + cpp_ll_all(data, param, , list_functions)) + +}) + + + + + +test_that("Arity of custom likelihood functions is passed, and they are called + with the correct number of parameters", { + + ## Generate data ## + data(fake_outbreak) + data <- with(fake_outbreak, + outbreaker_data(dates = sample, + w_dens = w, + dna = dna)) + config <- create_config(data = data, init_mu = 0.543e-4) + param <- create_param(data = data, config = config)$current + few_cases <- as.integer(c(1,3,4)) + rnd_cases <- sample(sample(seq_len(data$N), 5, replace = FALSE)) + + + ## Generate custom functions with 2 arguments + f2 <- function(data, param) return(2); + + arity_two <- custom_likelihoods(genetic = f2, + timing_infections = f2, + timing_sampling = f2, + reporting = f2) + + ## Generate custom functions with 3 arguments. Make sure the i parameter + ## is passed to the custom function if arity is 3. + f3 <- function(data, param, i=-1) return(i); + + arity_three <- custom_likelihoods(genetic = f3, + timing_infections = f3, + timing_sampling = f3, + reporting = f3) + + + ## Tests + expect_equal(2, + cpp_ll_genetic(data, param, , arity_two[['genetic']])) + + expect_equal(3, + cpp_ll_genetic(data, param, 3, arity_three[['genetic']])) + + expect_equal(2, + cpp_ll_timing_infections(data, param, , arity_two[['timing_infections']])) + + expect_equal(3, + cpp_ll_timing_infections(data, param, 3, arity_three[['timing_infections']])) + + expect_equal(2, + cpp_ll_timing_sampling(data, param, , arity_two[['timing_sampling']])) + + expect_equal(3, + cpp_ll_timing_sampling(data, param, 3, arity_three[['timing_sampling']])) + + expect_equal(2, + cpp_ll_reporting(data, param, , arity_two[['reporting']])) + + expect_equal(3, + cpp_ll_reporting(data, param, 3, arity_three[['reporting']])) + +})