Nothing
context("Test movements")
## test various movements ##
test_that("Movements preserve param structure", {
## skip on CRAN
skip_on_cran()
## generate inputs
data(fake_outbreak)
data <- with(fake_outbreak,
outbreaker_data(dates = onset,
w_dens = w,
dna = dna))
config <- create_config(data = data)
config_no_move <- create_config(
move_alpha = FALSE,
move_t_inf = FALSE,
move_mu = FALSE, move_pi = FALSE,
move_eps = FALSE, move_lambda = FALSE,
move_kappa = FALSE,
move_swap_cases = FALSE, data = data)
data <- add_convolutions(data = data, config = config)
param <- create_param(data = data, config = config)$current
ll <- custom_likelihoods()
priors <- custom_priors()
moves <- bind_moves(config = config, data = data,
likelihoods = ll, priors = priors)
moves_no_move <- bind_moves(config = config_no_move,
likelihoods = ll, priors = priors)
## test moves lists ##
expect_equal(length(moves_no_move), 0L)
expect_equal(length(moves), 6L)
expect_true(all(vapply(moves, is.function, logical(1))))
## test moves ##
for (i in seq_along(moves)) {
## chech closure: data
expect_identical(environment(moves[[i]])$data, data)
## make moves
set.seed(1)
res <- moves[[i]](param = param)
## check that content in param after movements has identical shape
expect_equal(length(param), length(res))
expect_equal(length(unlist(param)), length(unlist(res)))
expect_equal(names(param), names(res))
}
})
test_that("Binding of moves works", {
## skip on CRAN
skip_on_cran()
## generate inputs
data(fake_outbreak)
data <- with(fake_outbreak,
outbreaker_data(dates = onset,
w_dens = w,
dna = dna))
config <- create_config(data = data)
data <- add_convolutions(data = data, config = config)
param <- create_param(data = data, config = config)$current
ll <- custom_likelihoods()
priors <- custom_priors()
## check re-input consistency
expect_identical(custom_moves(),
custom_moves(custom_moves()))
## check custom_moves defaults
moves <- custom_moves()
expect_length(moves, 8L)
expect_true(all(vapply(moves, is.function, FALSE)))
expect_named(moves)
expected_names <- c("mu", "pi", "eps", "lambda", "alpha", "swap_cases", "t_inf", "kappa")
expect_true(all(expected_names %in% names(moves)))
## check binding
moves <- bind_moves(moves, config = config, data = data,
likelihoods = ll, priors = priors)
exp_names <- c("custom_prior", "custom_ll", "config", "data")
expect_true(all(exp_names %in% names(environment(moves$mu))))
exp_names <- c("custom_prior", "custom_ll", "config", "data")
expect_true(all(exp_names %in% names(environment(moves$pi))))
exp_names <- c("list_custom_ll", "data")
expect_true(all(exp_names %in% names(environment(moves$alpha))))
exp_names <- c("list_custom_ll", "data")
expect_true(all(exp_names %in% names(environment(moves$swap_cases))))
exp_names <- c("list_custom_ll", "data")
expect_true(all(exp_names %in% names(environment(moves$t_inf))))
exp_names <- c("list_custom_ll", "config", "data")
expect_true(all(exp_names %in% names(environment(moves$kappa))))
})
test_that("Customisation of moves works", {
## skip on CRAN
skip_on_cran()
## generate inputs
data(fake_outbreak)
data <- with(fake_outbreak,
outbreaker_data(dates = onset,
w_dens = w,
dna = dna))
config <- create_config(data = data, n_iter = 1000,
find_import = FALSE,
sample_every = 10)
data <- add_convolutions(data = data, config = config)
param <- create_param(data = data, config = config)$current
ll <- custom_likelihoods()
priors <- custom_priors()
## check custom movement for mu - outside outbreaker
f <- function(param, data, config = NULL) {
return(param)
}
moves <- bind_moves(list(mu = f), config = config, data = data,
likelihoods = ll, priors = priors)
expect_identical(body(moves$mu), body(f))
expect_identical(names(formals(moves$mu)), "param")
expect_identical(data, environment(moves$mu)$data)
expect_identical(config, environment(moves$mu)$config)
expect_identical(moves$mu(param), param)
## same check, run within outbreaker
out <- outbreaker(data, config, moves = list(mu = f))
expect_true(all(out$mu == 1e-4))
})
## test swapping and temporal ordering ##
test_that("Swap equally likely index cases", {
## skip on CRAN
skip_on_cran()
## generate inputs
data <- outbreaker_data(dates = c(50, 51, 110),
w_dens = rep(1, 100))
config <- create_config(init_kappa = 1,
move_kappa = FALSE,
find_import = FALSE,
data = data)
set.seed(1)
res <- outbreaker(data, config)
table(res$alpha_1)
table(res$alpha_2)
table(res$alpha_3)
})
## test kappa estimates
test_that("Kappa estimates are correct", {
## skip on CRAN
skip_on_cran()
## sequence and onset data that supports kappa = c(3, 1, 1)
dna <- matrix(c("t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t",
"g", "g", "g", "g", "g", "g", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t",
"g", "g", "g", "g", "g", "g", "c", "c", "t", "t", "t", "t", "t", "t", "t", "t", "t", "t",
"g", "g", "g", "g", "g", "g", "c", "c", "a", "a", "t", "t", "t", "t", "t", "t", "t", "t"),
byrow = TRUE, nrow = 4)
dna <- ape::as.DNAbin(dna)
dates <- c(10, 40, 50, 60)
## strong suport for generation time = 10 days
w <- dgamma(1:20, shape = 25, scale = 0.4)
data <- outbreaker_data(dates = dates, dna = dna, w_dens = w)
config <- create_config(prior_pi = c(1, 1), prior_mu = c(0.1),
init_mu = 2/18, sd_mu = 0.1, n_iter = 5e4)
set.seed(2)
res <- outbreaker(data, config)
## function to get most frequent item
get_mode <- function(x) {
as.integer(names(sort(table(x, exclude = NULL), decreasing = TRUE)[1]))
}
kappa <- as.matrix(res[,grep("kappa", names(res))])
kappa <- as.vector(apply(kappa, 2, get_mode))
expect_equal(c(NA, 3, 1, 1), kappa)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.