Switch to side-by-side view

--- a
+++ b/tests/testthat/test_moves.R
@@ -0,0 +1,235 @@
+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)
+
+})