tests/testthat/test-reallocate.R

In MatthewHeun/matsbyname: An Implementation of Matrix Mathematics that Respects Row and Column Names

test_that("reallocate_byname() errors as expected", {
  expect_error(
    reallocate_byname(a = 42, margin = c(1, 2, 3)), 
    "margin must have length 1 or 2 in matsbyname::reallocate_byname\\(\\)"
  )
  expect_error(
    reallocate_byname(a = 42, margin = 4), 
    "margin must be 1, 2, or c\\(1, 2\\) in matsbyname::reallocate_byname\\(\\)"
  )
  expect_error(
    reallocate_byname(a = 42, margin = c(1, 1)), 
    "margin must contain unique integers in matsbyname::reallocate_byname\\(\\)"
  )
})


test_that("reallocate_byname() works with row reallocation", {
  a <- matrix(c(1, 2, 
                3, 4, 
                5, 6), 
              nrow = 3, ncol = 2, byrow = TRUE, 
              dimnames = list(c("r1", "r2", "r3"), 
                              c("c1", "c2")))
  
  res <- reallocate_byname(a, "r3", margin = 1)
  
  expected <- matrix(c(1 + 1/4*5, 2 + 2/6*6, 
                       3 + 3/4*5, 4 + 4/6*6), 
                     nrow = 2, ncol = 2, byrow = TRUE, 
                     dimnames = list(c("r1", "r2"), 
                                     c("c1", "c2")))
  expect_equal(res, expected)
  
  # Redistribute 2 rows into 1, essentially providing a summation
  res2 <- reallocate_byname(a, c("r1", "r3"), margin = 1)
  
  expected2 <- matrix(c(9, 12), 
                      nrow = 1, ncol = 2, byrow = TRUE, 
                      dimnames = list(c("r2"), 
                                      c("c1", "c2")))
  expect_equal(res2, expected2)
  
  # Test with a list
  res3 <- reallocate_byname(list(a, a), "r3", margin = 1)
  expected3 <- list(expected, expected)
  expect_equal(res3, expected3)
})


test_that("reallocate_byname() works with column reallocation", {
  a <- matrix(c(1, 2, 3,
                4, 5, 6), 
              nrow = 2, ncol = 3, byrow = TRUE, 
              dimnames = list(c("r1", "r2"), 
                              c("c1", "c2", "c3")))
  
  res <- reallocate_byname(a, "c3", margin = 2)
  
  expected <- matrix(c(1 + 1/3*3, 2 + 2/3*3, 
                       4 + 4/9*6, 5 + 5/9*6), 
                     nrow = 2, ncol = 2, byrow = TRUE, 
                     dimnames = list(c("r1", "r2"), 
                                     c("c1", "c2")))
  expect_equal(res, expected)
  
  # Redistribute 2 columns into 1, essentially providing a summation
  res2 <- reallocate_byname(a, c("c1", "c2"), margin = 2)
  
  expected2 <- matrix(c(6, 
                        15), 
                      nrow = 2, ncol = 1, byrow = TRUE, 
                      dimnames = list(c("r1", "r2"), 
                                      c("c3")))
  expect_equal(res2, expected2)
  
  # Test with a list
  res3 <- reallocate_byname(list(a, a, a), "c3", margin = 2)
  expected3 <- list(expected, expected, expected)
  expect_equal(res3, expected3)
})


test_that("reallocate_byname() works when allocating multiple rows", {
  a <- matrix(c(1, 2, 
                3, 4, 
                5, 6, 
                7, 8), 
              nrow = 4, ncol = 2, byrow = TRUE, 
              dimnames = list(c("r1", "r2", "r3", "r4"), 
                              c("c1", "c2")))
  expected <- matrix(c(1 + 1/4*12, 2 + 2/6*14, 
                       3 + 3/4*12, 4 + 4/6*14), 
                     nrow = 2, ncol = 2, byrow = TRUE, 
                     dimnames = list(c("r1", "r2"), c("c1", "c2")))
  
  res <- reallocate_byname(a, c("r3", "r4"), margin = 1)
  expect_equal(res, expected)
})


test_that("reallocate_byname() works when allocating multiple columns", {
  a <- matrix(c(1, 2, 3, 5, 
                5, 6, 7, 9), 
              nrow = 2, ncol = 4, byrow = TRUE, 
              dimnames = list(c("r1", "r2"), 
                              c("c1", "c2", "c3", "c4")))
  expected <- matrix(c(1 + 1/6*5, 5 + 5/6*5, 
                       5 + 5/14*13, 9 + 9/14*13), 
                     nrow = 2, ncol = 2, byrow = TRUE, 
                     dimnames = list(c("r1", "r2"), c("c1", "c4")))
  
  res <- reallocate_byname(a, c("c2", "c3"), margin = 2)
  expect_equal(res, expected)
})


test_that("reallocate_byname() works as expected with a 0 column, a degenerate case", {
  # Try reallocating a 0 column.
  a <- matrix(c(1, 2, 3, 0,
                4, 5, 6, 0), 
              nrow = 2, ncol = 4, byrow = TRUE, 
              dimnames = list(c("r1", "r2"), 
                              c("c1", "c2", "c3", "c4")))
  
  res <- reallocate_byname(a, "c4", margin = 2)
  expect_equal(res, select_cols_byname(a, remove_pattern = "c4", fixed = TRUE))
  
  # Try redistributing a non-zero value
  # when all remaining values in a column are zero
  a2 <- matrix(c(1, 0,
                 2, 0, 
                 3, 6), 
               nrow = 3, ncol = 2, byrow = TRUE, 
               dimnames = list(c("r1", "r2", "r3"), 
                               c("c1", "c2")))
  res2 <- reallocate_byname(a2, "r3", margin = 1) |> 
    expect_error("r3 cannot be reallocated due to all zero values remaining in columns: c2")

  expected3 <- matrix(c(2, 0,
                        4, 0), 
                      nrow = 2, ncol = 2, byrow = TRUE, 
                      dimnames = list(c("r1", "r2"), 
                                      c("c1", "c2")))
  res3 <- reallocate_byname(a2, "r3", margin = 1, .zero_behaviour = "warning") |> 
    expect_equal(expected3) |> 
    expect_warning("r3 cannot be reallocated due to all zero values remaining in columns: c2")
  
  # Same result as res3, but no warning.
  res4 <- reallocate_byname(a2, "r3", margin = 1, .zero_behaviour = "zeroes") |> 
    expect_equal(expected3)
  
  # Allocate equally when only zeroes are present.
  expected5 <- matrix(c(2, 3,
                        4, 3), 
                      nrow = 2, ncol = 2, byrow = TRUE, 
                      dimnames = list(c("r1", "r2"), 
                                      c("c1", "c2")))
  res5 <- reallocate_byname(a2, "r3", margin = 1, .zero_behaviour = "allocate equally") |> 
    expect_equal(expected5)
})


test_that("reallocate_byname() works in a data frame and with Matrix objects", {
  a <- Matrix(c(1, 2, 
                5, 6, 
                10, 11), byrow = TRUE, nrow = 3, ncol = 2,
              dimnames = list(c("r1", "r2", "r3"), c("c1", "c2")))
  df <- tibble::tribble(~Country, ~a_mat, 
                        "USA", a, 
                        "GHA", a + 5)
  res <- df |> 
    dplyr::mutate(
      a_reallocated = reallocate_byname(a_mat, "r2", margin = 1)
    )

  expectedUSA <- Matrix(c(1 + 1/11*5, 2 + 2/13*6, 
                          10 + 10/11*5, 11 + 11/13*6), byrow = TRUE, nrow = 2, ncol = 2, 
                        dimnames = list(c("r1", "r3"), c("c1", "c2")))
  expectedGHA <- Matrix(c(6 + 6/21*10, 7 + 7/23*11,
                          15 + 15/21*10, 16 + 16/23*11), byrow = TRUE, nrow = 2, ncol = 2, 
                        dimnames = list(c("r1", "r3"), c("c1", "c2")))

  expected <- df |> 
    dplyr::mutate(
      a_reallocated = list(expectedUSA, expectedGHA)
    )
  expect_equal(res, expected)
})


test_that("reallocate_byname() works when choosing by pieces of column names", {
  a <- matrix(c(1, 2, 3, 4,
                5, 6, 7, 8), byrow = TRUE, nrow = 2, ncol = 4, 
              dimnames = list(c("r1", "r2"), c("a [from b]", "a [from c]", "d [from b]", "e")))
  # Infers notation
  a_reallocated <- reallocate_byname(a, "a", piece = "noun")
  expected <- matrix(c(3 + 3/7*3, 4 + 4/7*3, 
                       7 + 7/15*11, 8 + 8/15*11), byrow = TRUE, nrow = 2, ncol = 2, 
                     dimnames = list(c("r1", "r2"), c("d [from b]", "e")))
  expect_equal(a_reallocated, expected)

  # Specify a piece
  a_reallocated2 <- reallocate_byname(a, "b", piece = "from")
  expected2 <- matrix(c(2 + 2/6*4, 4 + 4/6*4,
                        6 + 6/14*12, 8 + 8/14*12), byrow = TRUE, nrow = 2, ncol = 2,
                      dimnames = list(c("r1", "r2"), c("a [from c]", "e")))
  expect_equal(a_reallocated2, expected2)
  
  # Specify notation as bracket_notation.
  # Specifying from_notation will not work.
  a_reallocated3 <- reallocate_byname(a, "b", 
                                      piece = "from", 
                                      notation = RCLabels::bracket_notation)
  expected3 <- matrix(c(2 + 2/6*4, 4 + 4/6*4,
                        6 + 6/14*12, 8 + 8/14*12), byrow = TRUE, nrow = 2, ncol = 2,
                      dimnames = list(c("r1", "r2"), c("a [from c]", "e")))
  expect_equal(a_reallocated3, expected3)
})


test_that("reallocate_byname() works when the row or column to be reallocated is missing", {
  a <- Matrix(c(1, 2, 
                5, 6, 
                10, 11), byrow = TRUE, nrow = 3, ncol = 2,
              dimnames = list(c("r1", "r2", "r3"), c("c1", "c2")))
  res <- reallocate_byname(a, "r4")
  expect_equal(res, a)
})


test_that("reallocate_byname() works with different row and column name notations", {
  a <- matrix(c(1, 2, 3, 4,
                5, 6, 7, 8), byrow = TRUE, nrow = 2, ncol = 4, 
              dimnames = list(c("r1", "r2"), c("a [to b]", "a [to c]", "d [to b]", "e")))
  # Infers notation
  a_reallocated <- reallocate_byname(a, "b", piece = "to")
  expected <- matrix(c(2 + 2/6*4, 4 + 4/6*4,
                       6 + 6/14*12, 8 + 8/14*12), byrow = TRUE, nrow = 2, ncol = 2,
                     dimnames = list(c("r1", "r2"), c("a [to c]", "e")))
  expect_equal(a_reallocated, expected)

  a_arrow <- matrix(c(1, 2, 3, 4,
                      5, 6, 7, 8), byrow = TRUE, nrow = 2, ncol = 4, 
                    dimnames = list(c("a -> b", "c -> d"), c("a -> b", "a -> c", "d -> b", "e")))
  a_arrow_reallocated <- reallocate_byname(a_arrow, "b", piece = "suff", margin = 1)
  a_arrow_expected <- matrix(c(6, 8, 10, 12), byrow = TRUE, nrow = 1, ncol = 4, 
                             dimnames = list("c -> d", c("a -> b", "a -> c", "d -> b", "e")))
  expect_equal(a_arrow_reallocated, a_arrow_expected)
})