tests/testthat/test-group_dilution.R

In rmsBMA: Reduced Model Space Bayesian Model Averaging

test_that("group_dilution returns 1 for all models when there are no groups", {
  Reg_ID <- rbind(
    c(0, 0, 0),
    c(1, 0, 1),
    c(1, 1, 1)
  )
  Nar_vec <- c(0, 0, 0)

  out <- group_dilution(Reg_ID, Nar_vec, p = 0.7)

  expect_type(out, "double")
  expect_length(out, nrow(Reg_ID))
  expect_equal(out, rep(1, nrow(Reg_ID)))
})

test_that("group_dilution works with scalar p (same for all groups)", {
  # K=5, groups: 1 for cols 1:3, 2 for cols 4:5
  Nar_vec <- c(1, 1, 1, 2, 2)

  Reg_ID <- rbind(
    c(0,0,0,0,0),  # null: D=0 -> 1
    c(1,0,0,0,0),  # one from g1: D=0 -> 1
    c(1,1,0,0,0),  # two from g1: D=1 -> p
    c(1,1,1,0,0),  # three from g1: D=2 -> p^2
    c(1,1,0,1,1)   # g1 count=2 -> +1; g2 count=2 -> +1 => D=2 -> p^2
  )

  p <- 0.7
  out <- group_dilution(Reg_ID, Nar_vec, p = p)

  expected <- c(
    1,
    1,
    p^1,
    p^2,
    p^2
  )

  expect_equal(out, expected, tolerance = 1e-12)
})

test_that("group_dilution works with group-specific p vector in group order", {
  Nar_vec <- c(1, 1, 1, 2, 2)
  Reg_ID <- rbind(
    c(1,1,0,0,0),  # g1 count=2 -> expo1=1 => p1
    c(1,1,1,0,0),  # g1 count=3 -> expo1=2 => p1^2
    c(0,0,0,1,1),  # g2 count=2 -> expo2=1 => p2
    c(1,1,0,1,1)   # expo1=1 and expo2=1 => p1*p2
  )

  p1 <- 0.7
  p2 <- 0.5
  out <- group_dilution(Reg_ID, Nar_vec, p = c(p1, p2))

  expected <- c(
    p1,
    p1^2,
    p2,
    p1 * p2
  )

  expect_equal(out, expected, tolerance = 1e-12)
})

test_that("group_dilution matches named p to group IDs", {
  Nar_vec <- c(2, 2, 1, 1)  # groups are {1,2} after sorting
  Reg_ID <- rbind(
    c(1,1,0,0),  # group 2 count=2 -> expo2=1
    c(0,0,1,1),  # group 1 count=2 -> expo1=1
    c(1,1,1,1)   # group2 expo1 + group1 expo1 => p2 * p1
  )

  p_named <- c("1" = 0.6, "2" = 0.2)
  out <- group_dilution(Reg_ID, Nar_vec, p = p_named)

  expected <- c(
    0.2,        # group 2 penalty
    0.6,        # group 1 penalty
    0.2 * 0.6
  )

  expect_equal(out, expected, tolerance = 1e-12)
})

test_that("group_dilution handles p = 0 (penalize repeated group members to 0)", {
  Nar_vec <- c(1, 1, 2)

  Reg_ID <- rbind(
    c(1,0,1),  # group1 count=1 => expo=0 => no penalty => 1
    c(1,1,0),  # group1 count=2 => expo=1 => p^1 => 0
    c(1,1,1)   # group1 expo=1 => 0 regardless of group2
  )

  out <- group_dilution(Reg_ID, Nar_vec, p = 0)

  expect_equal(out, c(1, 0, 0))
})

test_that("group_dilution validates inputs", {
  Reg_ID <- rbind(c(0,1,0), c(1,1,0))
  Nar_vec <- c(1, 1, 2)

  # Nar_vec length mismatch
  expect_error(group_dilution(Reg_ID, Nar_vec[-1], p = 0.5), "Nar_vec must have length")

  # p must be numeric and not NA
  expect_error(group_dilution(Reg_ID, Nar_vec, p = NA_real_), "p must be numeric")
  expect_error(group_dilution(Reg_ID, Nar_vec, p = "0.5"), "p must be numeric")

  # p in [0,1]
  expect_error(group_dilution(Reg_ID, Nar_vec, p = -0.1), "\\[0, 1\\]")
  expect_error(group_dilution(Reg_ID, Nar_vec, p =  1.1), "\\[0, 1\\]")

  # p length mismatch: groups are {1,2} => G=2
  expect_error(group_dilution(Reg_ID, Nar_vec, p = c(0.5, 0.4, 0.3)), "length 1 or length equal")

  # named p missing group ids
  expect_error(group_dilution(Reg_ID, Nar_vec, p = c("1" = 0.5, "3" = 0.2)),
               "not all group IDs")
})