tests/testthat/test-mapping-matrices.R

In bage: Bayesian Estimation and Forecasting of Age-Specific Rates

## 'get_labels_svd' -----------------------------------------------------------

test_that("'get_labels_svd' works - total", {
  prior <- SVD(LFP)
  dimnames_term <- list(region = c("A", "B"),
                        age = poputils::age_labels(type = "five", min = 15, max = 60))
  var_sexgender <- NULL
  ans_obtained <- get_labels_svd(prior,
                                 dimnames_term = dimnames_term,
                                 var_sexgender = var_sexgender)
  ans_expected <- c("comp1", "comp2", "comp3")
  expect_identical(ans_obtained, ans_expected)
})

test_that("'get_labels_svd' works - indep", {
  prior <- SVD(LFP)
  dimnames_term <- list(region = c("A", "B"),
                        sex = c("M", "F"),
                        age = poputils::age_labels(type = "five", min = 15, max = 60))
  var_sexgender <- "sex"
  ans_obtained <- get_labels_svd(prior,
                                 dimnames_term = dimnames_term,
                                 var_sexgender = var_sexgender)
  ans_expected <- c("M.comp1", "M.comp2", "M.comp3",
                    "F.comp1", "F.comp2", "F.comp3")
  expect_identical(ans_obtained, ans_expected)
})

test_that("'get_labels_svd' works - joint", {
  prior <- SVD(LFP, indep = FALSE)
  dimnames_term <- list(region = c("A", "B"),
                        sex = c("M", "F"),
                        age = poputils::age_labels(type = "five", min = 15, max = 60))
  var_sexgender <- "sex"
  ans_obtained <- get_labels_svd(prior,
                                 dimnames_term = dimnames_term,
                                 var_sexgender = var_sexgender)
  ans_expected <- c("comp1", "comp2", "comp3")
  expect_identical(ans_obtained, ans_expected)
})


## 'make_dim_svd' -------------------------------------------------------------

test_that("'make_dim_svd' works - total", {
  prior <- SVD(LFP)
  dimnames_term <- list(region = c("A", "B"),
                        age = poputils::age_labels(type = "five", min = 15, max = 60))
  var_sexgender <- NULL
  var_age <- "age"
  ans_obtained <- make_dim_svd(prior,
                               dimnames_term = dimnames_term,
                               var_sexgender = var_sexgender,
                               var_age = var_age)
  ans_expected <- c(3L, region = 2L)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_dim_svd' works - indep", {
  prior <- SVD(LFP)
  dimnames_term <- list(region = c("A", "B"),
                        sex = c("M", "F"),
                        age = poputils::age_labels(type = "five", min = 15, max = 60))
  var_sexgender <- "sex"
  var_age <- "age"
  ans_obtained <- make_dim_svd(prior,
                               dimnames_term = dimnames_term,
                               var_sexgender = var_sexgender,
                               var_age = var_age)
  ans_expected <- c(6L, region = 2L)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_dim_svd' works - joint", {
  prior <- SVD(LFP, indep = FALSE)
  dimnames_term <- list(region = c("A", "B"),
                        sex = c("M", "F"),
                        age = poputils::age_labels(type = "five", min = 15, max = 60))
  var_sexgender <- "sex"
  var_age <- "age"
  ans_obtained <- make_dim_svd(prior,
                               dimnames_term = dimnames_term,
                               var_sexgender = var_sexgender,
                               var_age = var_age)
  ans_expected <- c(3L, region = 2L)
  expect_identical(ans_obtained, ans_expected)
})


## 'make_i_along_agetime' -----------------------------------------------------

test_that("'make_i_along_agetime' works when age required", {
  prior <- RW2_Infant()
  dimnames_term <- list(age = 1:3,
                        period = 2001:2020)
  var_time <- "period"
  var_age <- "age"
  ans_obtained <- make_i_along_agetime(prior = prior,
                                       dimnames_term = dimnames_term,
                                       var_time = var_time,
                                       var_age = var_age,
                                       agetime = "age")
  ans_expected <- 1L
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_i_along_agetime' works when time required", {
  prior <- SVD_RW(HMD)
  dimnames_term <- list(age = 1:3,
                        period = 2001:2020)
  var_time <- "period"
  var_age <- "age"
  ans_obtained <- make_i_along_agetime(prior = prior,
                                       dimnames_term = dimnames_term,
                                       var_time = var_time,
                                       var_age = var_age,
                                       agetime = "time")
  ans_expected <- 2L
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_i_along_agetime' throws correct error when age/time variable not yet identified", {
  prior <- SVD_RW(HMD)
  dimnames_term <- list(age = 1:3,
                        epoch = 2001:2020)
  var_time <- NULL
  var_age <- "age"
  expect_error(make_i_along_agetime(prior = prior,
                                    dimnames_term = dimnames_term,
                                    var_time = var_time,
                                    var_age = var_age,
                                    agetime = "time"),
               "Using `SVD_RW\\(\\)` prior when time variable not identified.")
})

test_that("'make_i_along_agetime' throws correct error when age/time variable not yet identified", {
  prior <- SVD_RW(HMD)
  dimnames_term <- list(age = 1:3,
                        cohort = 2001:2020)
  var_time <- "time"
  var_age <- "age"
  expect_error(make_i_along_agetime(prior = prior,
                                    dimnames_term = dimnames_term,
                                    var_time = var_time,
                                    var_age = var_age,
                                    agetime = "time"),
               "Using `SVD_RW\\(\\)` prior with a term that does not involve time.")
})





## 'make_i_along_inner' -------------------------------------------------------

test_that("'make_i_along_inner' works when 'along' is NULL but 'var_time' supplied", {
  along <- NULL
  dimnames_term <- list(reg = letters,
                        period = 2001:2020)
  var_time <- "period"
  var_age <- "age"
  ans_obtained <- make_i_along_inner(along = along,
                                     dimnames_term = dimnames_term,
                                     var_time = var_time,
                                     var_age = var_age)
  ans_expected <- 2L
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_i_along_inner' works when 'along' is NULL but 'var_age' supplied", {
  along <- NULL
  dimnames_term <- list(reg = letters,
                        age = 0:3)
  var_time <- "period"
  var_age <- "age"
  ans_obtained <- make_i_along_inner(along = along,
                                     dimnames_term = dimnames_term,
                                     var_time = var_time,
                                     var_age = var_age)
  ans_expected <- 2L
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_i_along_inner' throws correct error when 'along' is NULL and 'var_time' nor 'var_age' supplied", {
  along <- NULL
  dimnames_term <- list(reg = letters,
                        sex = c("F", "M"),
                        oldness = 0:3)
  var_time <- NULL
  var_age <- NULL
  expect_error(make_i_along_inner(along = along,
                                  dimnames_term = dimnames_term,
                                  var_time = var_time,
                                  var_age = var_age),
               "Prior for term `reg:sex:oldness` does not have a value for `along`.")
})

test_that("'make_i_along_inner' throws correct error when 'along' has length 2", {
  along <- c("age", "oldness")
  dimnames_term <- list(reg = letters,
                        sex = c("F", "M"),
                        oldness = 0:3)
  var_time <- NULL
  var_age <- NULL
  expect_error(make_i_along_inner(along = along,
                                  dimnames_term = dimnames_term,
                                  var_time = var_time,
                                  var_age = var_age),
               "Internal error: `along` does not have length 1.")
})

test_that("'make_i_along_inner' throws correct error when 'along' has length 2", {
  along <- c("age", "oldness")
  dimnames_term <- list(reg = letters,
                        sex = c("F", "M"),
                        oldness = 0:3)
  var_time <- NULL
  var_age <- NULL
  expect_error(make_i_along_inner(along = along,
                                  dimnames_term = dimnames_term,
                                  var_time = var_time,
                                  var_age = var_age),
               "Internal error: `along` does not have length 1.")
})

test_that("'make_i_along_inner' works when 'along' supplied", {
  along <- "oldness"
  dimnames_term <- list(reg = letters,
                        sex = c("F", "M"),
                        oldness = 0:3)
  var_time <- NULL
  var_age <- NULL
  ans_obtained <- make_i_along_inner(along = along,
                                     dimnames_term = dimnames_term,
                                     var_time = var_time,
                                     var_age = var_age)
  ans_expected <- 3L
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_i_along_inner' throws correct error when 'along' not found", {
  along <- "wrong"
  dimnames_term <- list(reg = letters,
                        sex = c("F", "M"),
                        oldness = 0:3)
  var_time <- "time"
  var_age <- "oldness"
  expect_error(make_i_along_inner(along = along,
                                  dimnames_term = dimnames_term,
                                  var_time = var_time,
                                  var_age = var_age),
               "Prior for `reg:sex:oldness` has invalid value for `along`.")
})


## 'make_matrix_along_by' -----------------------------------------------------

test_that("'make_matrix_along_by' works when 'i_along' is 1", {
  i_along <- 1L
  dim <- 2:4
  dimnames <- list(a = 1:2, b = 1:3, c = 1:4)
  ans_obtained <- make_matrix_along_by(i_along = i_along,
                                       dim = dim,
                                       dimnames = dimnames)
  ans_expected <- matrix(0:23,
                         nr = 2,
                         dimnames = list(a = 1:2,
                                         b.c = paste(1:3, rep(1:4, each = 3), sep = ".")))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by' works when 'i_along' is 2", {
  i_along <- 2L
  dim <- 2:4
  dimnames <- list(a = 1:2, b = 1:3, c = 1:4)
  ans_obtained <- make_matrix_along_by(i_along = i_along,
                                       dim = dim,
                                       dimnames = dimnames)
  ans_expected <- matrix(c(0L, 2L, 4L,
                           1L, 3L, 5L,
                           6L, 8L, 10L,
                           7L, 9L, 11L,
                           12L, 14L, 16L,
                           13L, 15L, 17L,
                           18L, 20L, 22L,
                           19L, 21L, 23L),
                         nr = 3,
                         dimnames = list(b = 1:3,
                                         a.c = paste(1:2, rep(1:4, each = 2), sep = ".")))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by' works when 'i_along' is 3", {
  i_along <- 3L
  dim <- 2:4
  dimnames <- list(a = 1:2, b = 1:3, c = 1:4)
  ans_obtained <- make_matrix_along_by(i_along = i_along,
                                       dim = dim,
                                       dimnames = dimnames)
  ans_expected <- matrix(c(0L, 6L, 12L, 18L,
                           1L, 7L, 13L, 19L,
                           2L, 8L, 14L, 20L,
                           3L, 9L, 15L, 21L,
                           4L, 10L, 16L, 22L,
                           5L, 11L, 17L, 23L),
                         nrow = 4,
                         dimnames = list(c = 1:4,
                                         a.b = paste(1:2, rep(1:3, each = 2), sep = ".")))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by' works when only one dimension", {
  i_along <- 1L
  dim <- 3L
  dimnames <- list(a = 1:3)
  ans_obtained <- make_matrix_along_by(i_along = i_along,
                                       dim = dim,
                                       dimnames = dimnames)
  ans_expected <- matrix(0:2, nr = 3)
  rownames(ans_expected) <- 1:3
  names(dimnames(ans_expected))[1] <- "a"
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by' works when only one element", {
  i_along <- 1L
  dim <- 1L
  dimnames <- list(a = 1)
  ans_obtained <- make_matrix_along_by(i_along = i_along,
                                       dim = dim,
                                       dimnames = dimnames)
  ans_expected <- matrix(0L, nr = 1)
  rownames(ans_expected) <- 1
  names(dimnames(ans_expected))[1] <- "a"
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by' works when 'i_along' is 1:2", {
  i_along <- 1:2
  dim <- 2:4
  dimnames <- list(a = 1:2, b = 1:3, c = 1:4)
  ans_obtained <- make_matrix_along_by(i_along = i_along,
                                       dim = dim,
                                       dimnames = dimnames)
  ans_expected <- matrix(0:23,
                         nr = 6,
                         dimnames = list(a.b = paste(1:2, rep(1:3, each = 2), sep = "."),
                                         c = 1:4))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by' works when 'i_along' is 1:2", {
  i_along <- c(1L, 3L)
  dim <- 2:4
  dimnames <- list(a = 1:2, b = 1:3, c = 1:4)
  ans_obtained <- make_matrix_along_by(i_along = i_along,
                                       dim = dim,
                                       dimnames = dimnames)
  ans_expected <- matrix(c(0L, 1L, 6L, 7L, 12L, 13L, 18L, 19L,
                           2L, 3L, 8L, 9L, 14L, 15L, 20L, 21L,
                           4L, 5L, 10L, 11L, 16L, 17L, 22L, 23L),
                         nr = 8,
                         dimnames = list(a.c = paste(1:2, rep(1:4, each = 2), sep = "."),
                                         b = 1:3))
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_along_by_effectfree_inner' ------------------------------------

test_that("'make_matrix_along_by_effectfree_inner' works - reg x time interaction, append_zero is TRUE, con is 'by'", {
  prior <- RW(con = "by")
  dimnames_term <- list(reg = 1:4,
                        time = 2001:2010)
  var_age <- "age"
  var_time <- "time"
  var_sexgender <- "sex"
  ans_obtained <- make_matrix_along_by_effectfree_inner(prior = prior,
                                                        dimnames_term = dimnames_term,
                                                        var_time = var_time,
                                                        var_age = var_age,
                                                        var_sexgender = var_sexgender,
                                                        append_zero = TRUE)
  ans_expected <- make_matrix_along_by_inner(i_along = 2L, dim = c(3L, 9L))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_effectfree_inner' works - reg x time interaction, append_zero is FALSE, con is 'none'", {
  prior <- RW()
  dimnames_term <- list(reg = 1:4,
                        time = 2001:2010)
  var_age <- "age"
  var_time <- "time"
  var_sexgender <- "sex"
  ans_obtained <- make_matrix_along_by_effectfree_inner(prior = prior,
                                                        dimnames_term = dimnames_term,
                                                        var_time = var_time,
                                                        var_age = var_age,
                                                        var_sexgender = var_sexgender,
                                                        append_zero = FALSE)
  ans_expected <- make_matrix_along_by_inner(i_along = 2L, dim = c(4L, 10L))
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_along_by_effect' ----------------------------------------------

test_that("'make_matrix_along_by_effect' works with single dimension", {
  prior = RW()
  dimnames_term <- list(age = 0:9)
  var_time <- "time"
  var_age <- "age"
  ans_obtained <- make_matrix_along_by_effect(prior = prior,
                                              dimnames_term = dimnames_term,
                                              var_time = var_time,
                                              var_age = var_age)
  ans_expected <- matrix(0:9,
                         nr = 10,
                         dimnames = list(age = 0:9,
                                         NULL))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_effect' works with two dimensions", {
  prior <- RW()
  dimnames_term <- list(age = 0:9,
                        time = 2001:2002)
  var_time <- "time"
  var_age <- "age"
  ans_obtained <- make_matrix_along_by_effect(prior = prior,
                                              dimnames_term = dimnames_term,
                                              var_time = var_time,
                                              var_age = var_age)
  ans_expected <- t(matrix(0:19, nr = 10))
  dimnames(ans_expected) <- list(time = 2001:2002,
                                 age = 0:9)
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_along_by_inner' -----------------------------------------------

test_that("'make_matrix_along_by_inner' works when 'i_along' is 1", {
  i_along <- 1L
  dim <- 2:4
  ans_obtained <- make_matrix_along_by_inner(i_along = i_along, dim = dim)
  ans_expected <- matrix(0:23, nr = 2)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_inner' works when 'i_along' is 2", {
  i_along <- 2L
  dim <- 2:4
  ans_obtained <- make_matrix_along_by_inner(i_along = i_along, dim = dim)
  ans_expected <- matrix(c(0L, 2L, 4L,
                           1L, 3L, 5L,
                           6L, 8L, 10L,
                           7L, 9L, 11L,
                           12L, 14L, 16L,
                           13L, 15L, 17L,
                           18L, 20L, 22L,
                           19L, 21L, 23L),
                         nr = 3)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_inner' works when 'i_along' is 3", {
  i_along <- 3L
  dim <- 2:4
  ans_obtained <- make_matrix_along_by_inner(i_along = i_along, dim = dim)
  ans_expected <- matrix(c(0L, 6L, 12L, 18L,
                           1L, 7L, 13L, 19L,
                           2L, 8L, 14L, 20L,
                           3L, 9L, 15L, 21L,
                           4L, 10L, 16L, 22L,
                           5L, 11L, 17L, 23L),
                         nrow = 4)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_inner' works when only one dimension", {
  i_along <- 1L
  dim <- 3L
  ans_obtained <- make_matrix_along_by_inner(i_along = i_along, dim = dim)
  ans_expected <- matrix(0:2, nr = 3)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_inner' works when only one element", {
  i_along <- 1L
  dim <- 1L
  ans_obtained <- make_matrix_along_by_inner(i_along = i_along, dim = dim)
  ans_expected <- matrix(0L, nr = 1)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_inner' works when 'i_along' is 1:2", {
  i_along <- 1:2
  dim <- 2:4
  ans_obtained <- make_matrix_along_by_inner(i_along = i_along, dim = dim)
  ans_expected <- matrix(0:23,
                         nr = 6)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_inner' works when 'i_along' is 1:2", {
  i_along <- c(1L, 3L)
  dim <- 2:4
  ans_obtained <- make_matrix_along_by_inner(i_along = i_along, dim = dim)
  ans_expected <- matrix(c(0L, 1L, 6L, 7L, 12L, 13L, 18L, 19L,
                           2L, 3L, 8L, 9L, 14L, 15L, 20L, 21L,
                           4L, 5L, 10L, 11L, 16L, 17L, 22L, 23L),
                         nr = 8)
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_along_by_svddynamic' ------------------------------------------

test_that("'make_matrix_along_by_svddynamic' works - age, sex, time", {
  prior <- SVD_AR(HMD, n_comp = 4)
  ans_obtained <- make_matrix_along_by_svddynamic(prior = prior,
                                                  dimnames_term = list(sex = c("f", "m"),
                                                                       age = c(0:99,
                                                                               "100+"),
                                                                       time = 1:10),
                                                  var_time = "time",
                                                  var_age = "age",
                                                  var_sexgender = "sex",
                                                  dim = c(2L, 101L, 10L))
  ans_expected <- make_matrix_along_by_inner(2L, c(8L, 10L))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_along_by_svddynamic' works - time, age", {
  prior <- SVD_AR(HMD, n_comp = 4)
  ans_obtained <- make_matrix_along_by_svddynamic(prior = prior,
                                                  dimnames_term = list(time = 1:10,
                                                                       age = c(0:99,
                                                                               "100+")),
                                                  var_time = "time",
                                                  var_age = "age",
                                                  var_sexgender = "sex",
                                                  dim = c(10L, 101L))
  ans_expected <- make_matrix_along_by_inner(2L, c(4L, 10L))
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_append_zero' --------------------------------------------------

test_that("'make_matrix_append_zero' works", {
  m <- make_matrix_append_zero(c(3L, 5L))
  ans_obtained <- matrix(m %*% (1:10), nr = 3)
  ans_expected <- rbind(0, matrix(1:10, nr = 2))
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_con_by' -------------------------------------------------------

test_that("'make_matrix_con_by' works with one 'by' dimension, along first", {
  m <- make_matrix_con_by(i_along = 1L, dim = c(4, 3))
  ans <- m %*% rnorm(12)
  expect_equal(rowMeans(matrix(ans, nr = 4)), rep(0, 4))
})

test_that("'make_matrix_con_by' works with one 'by' dimension, along second", {
  m <- make_matrix_con_by(i_along = 2L, dim = c(4, 3))
  ans <- m %*% rnorm(12)
  expect_equal(colMeans(matrix(ans, nr = 4)), rep(0, 3))
})

test_that("'make_matrix_con_by' works with two 'by' dimensions, along first", {
  m <- make_matrix_con_by(i_along = 1L, dim = c(4, 3, 2))
  ans <- array(m %*% rnorm(24), dim = 4:2)
  expect_equal(as.numeric(apply(ans, 1:2, mean)), rep(0, 12))
  expect_equal(as.numeric(apply(ans, c(1, 3), mean)), rep(0, 8))
})

test_that("'make_matrix_con_by' works with two 'by' dimensions, along second", {
  m <- make_matrix_con_by(i_along = 2L, dim = c(4, 3, 2))
  ans <- array(m %*% rnorm(24), dim = 4:2)
  expect_equal(as.numeric(apply(ans, 1:2, mean)), rep(0, 12))
  expect_equal(as.numeric(apply(ans, c(2, 3), mean)), rep(0, 6))
})


## 'make_matrix_constraints' --------------------------------------------------

test_that("'make_matrix_constraints' works", {
  ans_obtained <- make_matrix_constraints(c(2, 3))
  ans_expected <- matrix(c(1, 1, 0, 0, 0, 0,
                           0, 0, 1, 1, 0, 0,
                           0, 0, 0, 0, 1, 1,
                           1, 0, 1, 0, 1, 0,
                           0, 1, 0, 1, 0, 1),
                         byrow = TRUE,
                         nrow = 5)
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_draws_svd_appendzero' ---------------------------------------------

test_that("'make_matrix_draws_svd_appendzero' works - age and time", {
  prior <- SVD(HMD)
  dimnames_term <- list(age = poputils::age_labels(type = "lt", max = 60),
                        time = 2001:2005)
  ans_obtained <- make_matrix_draws_svd_appendzero(prior = prior,
                                                   dimnames_term = dimnames_term,
                                                   var_time = "time",
                                                   var_age = "age",
                                                   var_sexgender = "sex")
  ans_expected <- Matrix::kronecker(rbind(0, Matrix::.sparseDiagonal(4)),
                                    Matrix::.sparseDiagonal(3))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_draws_svd_appendzero' works - time and age", {
  prior <- SVD(HMD)
  dimnames_term <- list(time = 2001:2005,
                        age = poputils::age_labels(type = "lt", max = 60))
  ans_obtained <- make_matrix_draws_svd_appendzero(prior = prior,
                                                   dimnames_term = dimnames_term,
                                                   var_time = "time",
                                                   var_age = "age",
                                                   var_sexgender = "sex")
  ans_expected <- Matrix::kronecker(rbind(0, Matrix::.sparseDiagonal(4)),
                                    Matrix::.sparseDiagonal(3))
  expect_identical(ans_obtained, ans_expected)
})


test_that("'make_matrix_draws_svd_appendzero' works - region, time, sex and age", {
  prior <- SVD(HMD)
  dimnames_term <- list(reg = 1:2,
                        time = 2001:2005,
                        sex = c("f", "m"),
                        age = poputils::age_labels(type = "lt", max = 60))
  m <- make_matrix_draws_svd_appendzero(prior = prior,
                                        dimnames_term = dimnames_term,
                                        var_time = "time",
                                        var_age = "age",
                                        var_sexgender = "sex")
  x <- array(1:48, dim = c(6, 2, 4))
  ans_obtained <- array(m %*% as.integer(x), dim = c(6, 2, 5))
  ans_expected <- array(0L, dim = c(6, 2, 5))
  ans_expected[,,2:5] <- 1 * x
  expect_identical(ans_obtained, ans_expected)
})




## 'make_matrix_draws_svd_nozero' ---------------------------------------------

test_that("'make_matrix_draws_svd_nozero' works", {
  prior <- SVD(HMD)
  dimnames_term <- list(age = poputils::age_labels(type = "lt", max = 60))
  ans_obtained <- make_matrix_draws_svd_nozero(prior = prior,
                                               dimnames_term = dimnames_term,
                                               var_time = "time",
                                               var_age = "age",
                                               var_sexgender = "sex")
  ans_expected <- Matrix::.sparseDiagonal(3)
  expect_identical(ans_obtained, ans_expected)
})


## 'make_matrix_effectfree_effect_inner' --------------------------------------

test_that("'make_matrix_effectfree_effect_inner' works - con is 'by', along first", {
  dimnames_term <- list(time = 2001:2003, age = 0:4)
  prior <- AR1(con = "by")
  m <- make_matrix_effectfree_effect_inner(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = "time",
                                           var_age = "age",
                                           var_sexgender = "sex",
                                           append_zero = FALSE)
  expect_equal(rowSums(matrix(m %*% (1:12), nrow = 3)), rep(0, 3))
})

test_that("'make_matrix_effectfree_effect_inner' works - con is 'by', along second", {
  prior <- AR1(con = "by")
  dimnames_term <- list(age = 0:2, time = 2001:2005)
  m <- make_matrix_effectfree_effect_inner(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = "time",
                                           var_age = "age",
                                           var_sexgender = "sex",
                                           append_zero = FALSE)
  ans_obtained <- colSums(matrix(m %*% rnorm(10), nrow = 3))
  ans_expected <- rep(0, 5)
  expect_equal(ans_obtained, ans_expected)
})

test_that("'make_matrix_effectfree_effect_inner' works - append zero, along first", {
  set.seed(0)
  prior <- AR1()  
  dimnames_term <- list(time = 2001:2003, age = 0:4)
  m <- make_matrix_effectfree_effect_inner(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = "time",
                                           var_age = "age",
                                           var_sexgender = var_sexgender,
                                           append_zero = TRUE)
  x <- rnorm(10)
  ans_obtained <- matrix(m %*% x, nr = 3)
  ans_expected <- rbind(0, matrix(x, nr = 2))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_effectfree_effect_inner' works - append zero, along second", {
  set.seed(0)
  prior <- RW()
  dimnames_term <- list(age = 0:4, time = 2001:2003)
  m <- make_matrix_effectfree_effect_inner(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = "time",
                                           var_age = "age",
                                           var_sexgender = "sex",
                                           append_zero = TRUE)
  x <- rnorm(10)
  ans_obtained <- matrix(m %*% x, nr = 5)
  ans_expected <- cbind(0, matrix(x, nr = 5))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_effectfree_effect_inner' works - append column and append zero, along first", {
  set.seed(0)
  prior <- RW(con = "by")
  dimnames_term <- list(time = 2001:2003, age = 0:4)
  m <- make_matrix_effectfree_effect_inner(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = "time",
                                           var_age = "age",
                                           var_sexgender = var_sexgender,
                                           append_zero = TRUE)
  expect_identical(dim(m), c(15L, 8L))
  ans <- m %*% rnorm(8)
  ans <- matrix(ans, nrow = 3)
  expect_true(all(ans[1,] == 0))
  expect_equal(rowSums(ans), rep(0, 3))
})

test_that("'make_matrix_effectfree_effect_inner' works - append column and append zero, along second", {
  set.seed(0)
  prior <- AR1(con = "by")
  dimnames_term <- list(age = 0:4, time = 2001:2003)
  m <- make_matrix_effectfree_effect_inner(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = "time",
                                           var_age = "age",
                                           var_sexgender = "sex",
                                           append_zero = TRUE)
  expect_identical(dim(m), c(15L, 8L))
  ans <- m %*% rnorm(8)
  ans <- matrix(ans, nrow = 5)
  expect_true(all(ans[,1] == 0))
  expect_equal(colSums(ans), rep(0, 3))
})

test_that("'make_matrix_effectfree_effect' works with SVD-based matrix_sub_orig", {
  dimnames_term <- list(age = poputils::age_labels(type = "five", max = 60),
                        time = 2001:2005)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  prior <- SVD_RW(HMD)
  ans <- make_matrix_effectfree_effect_inner(prior = prior,
                                             dimnames_term = dimnames_term,
                                             var_time = var_time,
                                             var_age = var_age,
                                             var_sexgender = var_sexgender,
                                             append_zero = TRUE)
  expect_equal(dim(ans), c(5 * 13, 4 * 3))
})

test_that("'make_matrix_effectfree_effect' works with SVD-based matrix_sub_orig, con is 'by'", {
  dimnames_term <- list(age = poputils::age_labels(type = "five", max = 60),
                        time = 2001:2005)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  prior <- SVD_RW(HMD, con = "by")
  ans <- make_matrix_effectfree_effect_inner(prior = prior,
                                             dimnames_term = dimnames_term,
                                             var_time = var_time,
                                             var_age = var_age,
                                             var_sexgender = var_sexgender,
                                             append_zero = TRUE)
  expect_equal(dim(ans), c(prod(lengths(dimnames_term)), 4L * 3L))
})


## 'make_matrix_perm_agesex_from_font' ----------------------------------------

test_that("'make_matrix_perm_agesex_from_front' works - age and sex", {
  i_age <- 2L
  i_sexgender <- 3L
  dim_after <- c(4L, 5L, 2L)
  m <- make_matrix_perm_agesex_from_front(i_age = i_age,
                                          i_sexgender = i_sexgender,
                                          dim_after = dim_after)
  a_orig <- array(1:40, dim = c(4, 5, 2))
  a_perm <- aperm(a_orig, perm = c(2, 3, 1))
  expect_identical(as.integer(m %*% as.integer(a_perm)), as.integer(a_orig))
})

test_that("'make_matrix_perm_agesex_from_front' works - just age", {
  i_age <- 2L
  i_sexgender <- 0L
  dim_after <- c(4L, 5L)
  m <- make_matrix_perm_agesex_from_front(i_age = i_age,
                                          i_sexgender = i_sexgender,
                                          dim_after = dim_after)
  a_orig <- array(1:20, dim = c(4, 5))
  a_perm <- t(a_orig)
  expect_identical(as.integer(m %*% as.integer(a_perm)), as.integer(a_orig))
})

test_that("'make_matrix_perm_agesex_from_front' works - just age, age first", {
  i_age <- 1L
  i_sexgender <- 0L
  dim_after <- c(4L, 5L)
  m <- make_matrix_perm_agesex_from_front(i_age = i_age,
                                          i_sexgender = i_sexgender,
                                          dim_after = dim_after)
  expect_identical(as.matrix(m), diag(20))
})


## 'make_matrix_perm_along_from_front' ----------------------------------------

test_that("'make_matrix_perm_along_from_front' reverses effects of 'make_matrix_perm_along_to_front'", {
  m1 <- make_matrix_perm_along_to_front(dim_after = c(4L, 2:3), i_along = 3L)
  m2 <- make_matrix_perm_along_from_front(dim_after = 2:4, i_along = 3L)
  expect_identical(as.matrix(m2 %*% m1), diag(24L))
  m1 <- make_matrix_perm_along_to_front(dim_after = c(3L, 2L, 4L), i_along = 2L)
  m2 <- make_matrix_perm_along_from_front(dim_after = 2:4, i_along = 2L)
  expect_identical(as.matrix(m2 %*% m1), diag(24L))
  m1 <- make_matrix_perm_along_to_front(dim_after = 2:4, i_along = 1L)
  m2 <- make_matrix_perm_along_from_front(dim_after = 2:4, i_along = 1L)
  expect_identical(as.matrix(m2 %*% m1), diag(24L))
})


## 'make_matrix_perm_along_to_front' ------------------------------------------

test_that("'make_matrix_perm_along_to_front' works with 2 dimensions, along first", {
  ans_obtained <- make_matrix_perm_along_to_front(i_along = 1L, dim_after = 3:2)
  ans_expected <- Matrix::.sparseDiagonal(6)
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_matrix_perm_along_to_front' works with 2 dimensions, along second", {
  m <- make_matrix_perm_along_to_front(i_along = 2L, dim_after = 2:3)
  x <- matrix(1:6, nr = 3)
  expect_identical(matrix(m %*% as.integer(x), nr = 2),
                   1 * t(x))
  expect_identical(as.matrix(crossprod(m)), diag(6))
})

test_that("'make_matrix_perm_along_to_front' works with 3 dimensions, along second", {
  m <- make_matrix_perm_along_to_front(i_along = 2L, dim_after = c(2L, 3L, 2L))
  x <- array(1:12, dim = c(3, 2, 2))
  expect_identical(array(m %*% as.integer(x), dim = c(2, 3, 2)),
                   1 * aperm(x, perm = c(2, 1, 3)))
  expect_identical(as.matrix(crossprod(m)), diag(12))
})


## 'make_matrix_spline' -------------------------------------------------------

test_that("'make_matrix_spline' works", {
    set.seed(0)
    m <- make_matrix_spline(n_along = 10, n_comp = 5)
    expect_equal(dim(m), c(10L, 5L))
    expect_equal(colSums(as.matrix(m)), rep(0, times = 5))
})


## 'make_matrix_sub_orig_svd' -------------------------------------------------

test_that("'make_matrix_sub_orig_svd' works with bage_prior_svd_ar - time x age interaction, con is 'none'", {
  prior <- SVD_RW(HMD)
  dimnames_term <- list(time = 2001:2005,
                        age = poputils::age_labels(type = "five", max = 60))
  var_age <- "age"
  var_sexgender <- "sex"
  dim_after <- c(4L, 13L)
  ans <- make_matrix_sub_orig_svd(prior = prior,
                                  dimnames_term = dimnames_term,
                                  var_age = var_age,
                                  var_sexgender = var_sexgender,
                                  dim_after = dim_after,
                                  con = "none")
  expect_equal(dim(ans), c(prod(dim_after), 12L))
})

test_that("'make_matrix_sub_orig_svd' works with bage_prior_svd_ar - time x age interaction, con is 'none'", {
  prior <- SVD_RW(HMD)
  dimnames_term <- list(time = 2001:2005,
                        age = poputils::age_labels(type = "five", max = 60))
  var_age <- "age"
  var_sexgender <- "sex"
  dim_after <- c(4L, 12L)
  ans <- make_matrix_sub_orig_svd(prior = prior,
                                  dimnames_term = dimnames_term,
                                  var_age = var_age,
                                  var_sexgender = var_sexgender,
                                  dim_after = dim_after,
                                  con = "by")
  expect_equal(dim(ans), c(prod(dim_after), 12L))
})

test_that("'make_matrix_sub_orig_svd' works with bage_prior_svd_ar - sex x time x age interaction, con is 'none'", {
  prior <- SVD_RW(HMD)
  dimnames_term <- list(sex = c("f", "m"),
                        time = 2001:2005,
                        age = poputils::age_labels(type = "five", max = 60))
  var_age <- "age"
  var_sexgender <- "sex"
  dim_after <- c(1L, 4L, 12L)
  ans <- make_matrix_sub_orig_svd(prior = prior,
                                  dimnames_term = dimnames_term,
                                  var_age = var_age,
                                  var_sexgender = var_sexgender,
                                  dim_after = dim_after,
                                  con = "by")
  expect_equal(dim(ans), c(prod(dim_after), 24L))
})


## 'make_matrix_unconstr_constr' ----------------------------------------------

test_that("'make_matrix_unconstr_constr' works when array representation of constrained vector has dimension 4", {
  set.seed(0)
  m <- make_matrix_unconstr_constr(4)
  x <- rnorm(3)
  y <- m %*% x
  expect_identical(length(y), 4L)
  expect_equal(sum(y), 0)
})


## 'make_matrix_unconstr_constr_along' ----------------------------------------

test_that("'make_matrix_unconstr_constr_along' works when array representation of unconstrained vector has dimension 3 x 2", {
  set.seed(0)
  m <- make_matrix_unconstr_constr_along(c(3L, 2L))
  x <- rnorm(3)
  y <- matrix(m %*% x, nr = 3)
  expect_equal(dim(y), c(3L, 2L))
  expect_equal(rowSums(y), rep(0, 3))
})

test_that("'make_matrix_unconstr_constr_along' works when array representation of unconstrained vector has dimension 4 x 3", {
  set.seed(0)
  m <- make_matrix_unconstr_constr_along(c(4L, 3L))
  x <- rnorm(8)
  y <- matrix(m %*% x, nr = 4)
  expect_equal(dim(y), c(4L, 3L))
  expect_equal(rowSums(y), rep(0, 4))
})

test_that("'make_matrix_unconstr_constr_along' works when array representation of unconstrained vector has dimension 1 x 3", {
  set.seed(0)
  m <- make_matrix_unconstr_constr_along(c(1L, 3L))
  x <- rnorm(2)
  y <- matrix(m %*% x, nr = 1)
  expect_equal(dim(y), c(1L, 3L))
  expect_equal(rowSums(y), 0)
})

test_that("'make_matrix_unconstr_constr_along' works when array representation of constrained vector has dimension 2 x 3 x 4", {
  set.seed(0)
  m <- make_matrix_unconstr_constr_along(2:4)
  x <- rnorm(12)
  y <- array(m %*% x, dim = 2:4)
  expect_equal(rowSums(y[1,,]), rep(0, 3))
  expect_equal(colSums(y[1,,]), rep(0, 4))
  expect_equal(rowSums(y[2,,]), rep(0, 3))
  expect_equal(colSums(y[2,,]), rep(0, 4))
})

test_that("'make_matrix_unconstr_constr_along' works when array representation of constrained vector has dimension 3 x 4 x 5 x 6", {
  set.seed(0)
  m <- make_matrix_unconstr_constr_along(3:6)
  x <- rnorm(3 * prod(3:5))
  y <- array(m %*% x, dim = 3:6)
  expect_equal(rowSums(y[1,,,1]), rep(0, 4))
  expect_equal(rowSums(y[1,1,,]), rep(0, 5))
  expect_equal(rowSums(y[1,2,,]), rep(0, 5))
  expect_equal(rowSums(y[1,,,4]), rep(0, 4))
  expect_equal(colSums(y[1,,1,]), rep(0, 6))
  expect_equal(colSums(y[1,,2,]), rep(0, 6))
  expect_equal(rowSums(y[2,,,1]), rep(0, 4))
  expect_equal(rowSums(y[2,1,,]), rep(0, 5))
  expect_equal(colSums(y[2,,1,]), rep(0, 6))
})


## 'make_offset_effectfree_effect_svd' ----------------------------------------

test_that("'make_offset_effectfree_effect_svd' works with bage_prior_svd - age effect", {
  prior <- SVD(HMD)
  dimnames_term <- list(age = poputils::age_labels(type = "lt", max = 60))
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  ans <- make_offset_effectfree_effect_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = var_time,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender)
  expect_identical(length(ans), length(dimnames_term[[1]]))
})

test_that("'make_offset_effectfree_effect_svd' works with bage_prior_svd_RW - age x time interaction, con is 'none'", {
  prior <- SVD_RW(HMD)
  dimnames_term <- list(age = poputils::age_labels(type = "lt", max = 60),
                        time = 2001:2010)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  ans <- make_offset_effectfree_effect_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = var_time,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender)
  expect_equal(length(ans), prod(lengths(dimnames_term)))
})

test_that("'make_offset_effectfree_effect_svd' works with bage_prior_svd_RW - age x time interaction, con is 'by'", {
  prior <- SVD_RW(HMD, con = "by")
  dimnames_term <- list(age = poputils::age_labels(type = "lt", max = 60),
                        time = 2001:2010)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  ans <- make_offset_effectfree_effect_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_time = var_time,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender)
  expect_equal(length(ans), prod(lengths(dimnames_term)))
})


## 'make_offset_sub_orig_svd' ----------------------------------------

test_that("'make_offset_sub_orig_svd' works with bage_prior_svd - age x time interaction", {
  s <- sim_ssvd()
  prior <- SVD(ssvd = s, n_comp = 2)
  dimnames_term <- list(age = c("0-4", "5-9"),
                        time = 2001:2003)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  ans_obtained <- make_offset_sub_orig_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender,
                                           dim_after = c(2L, 3L),
                                           con = "none")
  ans_expected <- s$data$offset[s$data$type == "total"][[1L]]
  ans_expected <- unname(rep(ans_expected, 3))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_offset_sub_orig_svd' works with bage_prior_svd - age x time interaction, con is 'none'", {
  s <- sim_ssvd()
  prior <- SVD_AR1(ssvd = s, n_comp = 2)
  dimnames_term <- list(age = c("0-4", "5-9"),
                        time = 2001:2003)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  levels_effect = c("0-4.2001", "5-9.2001", "0-4.2002", "5-9.2002", "0-4.2003", "5-9.2003")
  ans_obtained <- make_offset_sub_orig_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender,
                                           dim_after = c(2L, 3L),
                                           con = "none")
  ans_expected <- s$data$offset[s$data$type == "total"][[1L]]
  ans_expected <- unname(rep(ans_expected, 3))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_offset_sub_orig_svd' works with bage_prior_svd_ar - age x time interaction, con is 'by'", {
  s <- sim_ssvd()
  prior <- SVD_AR1(ssvd = s, n_comp = 2)
  dimnames_term <- list(age = c("0-4", "5-9"),
                        time = 2001:2003)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  ans_obtained <- make_offset_sub_orig_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender,
                                           dim_after = c(1L, 3L),
                                           con = "by")
  ans_expected <- s$data$offset[s$data$type == "total"][[1L]]
  ans_expected <- unname(rep(sqrt(0.5), 3))
  expect_equal(ans_obtained, ans_expected)
})

test_that("'make_offset_sub_orig_svd' works with bage_prior_svd_rw - age x time interaction", {
  s <- sim_ssvd()
  prior <- SVD_RW(ssvd = s, n_comp = 2)
  dimnames_term <- list(age = c("0-4", "5-9"),
                        time = 2001:2003)
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  levels_effect = c("0-4.2001", "5-9.2001", "0-4.2002", "5-9.2002", "0-4.2003", "5-9.2003")
  ans_obtained <- make_offset_sub_orig_svd(prior = prior,
                                                    dimnames_term = dimnames_term,
                                                    var_age = var_age,
                                           var_sexgender = var_sexgender,
                                           dim_after = c(2L, 3L),
                                           con = "none")
  ans_expected <- s$data$offset[s$data$type == "total"][[1L]]
  ans_expected <- unname(rep(ans_expected, 3))
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_offset_sub_orig_svd' works with bage_prior_svd - sex x age interaction, n = 2", {
  s <- sim_ssvd()
  prior <- SVD(ssvd = s, n_comp = 2)
  levels_effect = c("F.0-4", "M.0-4", "F.5-9", "M.5-9")
  dimnames_term <- list(sex = c("F", "M"),
                        age = c("0-4", "5-9"))
  var_age <- "age"
  var_sexgender <- "sex"
  ans_obtained <- make_offset_sub_orig_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender,
                                           dim_after = c(2L, 2L),
                                           con = "none")
  ans_expected <- unname(s$data$offset[s$data$type == "indep"][[1L]][c(1,3,2,4)])
  expect_identical(ans_obtained, ans_expected)
})

test_that("'make_offset_sub_orig_svd' works with bage_prior_svd - sex x age interaction, indep", {
  s <- sim_ssvd()
  prior <- SVD(ssvd = s, n_comp = 2, indep = FALSE)
  levels_effect = c("F.0-4", "M.0-4", "F.5-9", "M.5-9")
  dimnames_term <- list(sex = c("F", "M"),
                        age = c("0-4", "5-9"))
  var_time <- "time"
  var_age <- "age"
  var_sexgender <- "sex"
  ans_obtained <- make_offset_sub_orig_svd(prior = prior,
                                           dimnames_term = dimnames_term,
                                           var_age = var_age,
                                           var_sexgender = var_sexgender,
                                           dim_after = c(2L, 2L),
                                           con = "none")
  ans_expected <- unname(s$data$offset[s$data$type == "joint"][[1L]][c(1,3,2,4)])
  expect_identical(ans_obtained, ans_expected)
})