tests/testthat/test-jointness.R

In rmsBMA: Reduced Model Space Bayesian Model Averaging

test_that("jointness returns a square matrix with names and NA diagonal", {
  set.seed(101)

  n <- 25
  x1 <- rnorm(n); x2 <- rnorm(n); x3 <- rnorm(n); x4 <- rnorm(n)
  y  <- 1 + 0.8*x1 - 0.5*x3 + rnorm(n, sd = 0.4)

  data <- cbind(y = y, x1 = x1, x2 = x2, x3 = x3, x4 = x4)
  ms <- model_space(data, M = 4, g = "None", HC = FALSE)
  b  <- bma(ms, EMS = 2, dilution = 0, Narrative = 0, round = 12)

  out <- jointness(b, measure = "PPI", round = 6)

  expect_true(is.matrix(out))
  expect_equal(dim(out), c(4, 4))
  expect_equal(rownames(out), c("x1","x2","x3","x4"))
  expect_equal(colnames(out), c("x1","x2","x3","x4"))

  expect_true(all(is.na(diag(out))))
})

test_that("jointness errors on unknown measure", {
  # minimal fake bma_list to hit the measure branch
  fake <- list(NULL, NULL, NULL, NULL,
               c("x1","x2"),  # [[5]]
               2,             # [[6]] R
               4,             # [[7]] M
               NULL, NULL,
               cbind(matrix(c(0,1,1,1, 1,0,1,0), ncol = 2, byrow = TRUE),  # Z
                     c(0.5,0.5,0.5,0.5),                                 # wU
                     c(0.5,0.5,0.5,0.5)))                                # wR
  expect_error(jointness(fake, measure = "NOPE"), "Unknown measure")
})

test_that("jointness PPI matches joint inclusion probabilities from for_jointness (upper=uniform, lower=random)", {
  set.seed(202)

  n <- 22
  x1 <- rnorm(n); x2 <- rnorm(n); x3 <- rnorm(n); x4 <- rnorm(n)
  y  <- 1 + 0.7*x1 + 0.3*x2 - 0.4*x4 + rnorm(n, sd = 0.5)

  data <- cbind(y = y, x1 = x1, x2 = x2, x3 = x3, x4 = x4)
  ms <- model_space(data, M = 4, g = "None", HC = FALSE)
  b  <- bma(ms, EMS = 2, dilution = 0, Narrative = 0, round = 12)

  # what jointness() uses internally:
  forJ <- b[[10]]
  R <- b[[6]]
  Z  <- as.matrix(forJ[, 1:R])
  wU <- as.numeric(forJ[, R+1])
  wR <- as.numeric(forJ[, R+2])

  # implied PPI matrices:
  Pab_U <- crossprod(Z * wU, Z)  # R x R
  Pab_R <- crossprod(Z * wR, Z)

  out <- jointness(b, measure = "PPI", round = 12)

  # Check a couple of pairs explicitly:
  # Above diagonal => uniform; below diagonal => random
  # (1,2) is above diag, should equal Pab_U[1,2]
  expect_equal(unname(out[1,2]), unname(Pab_U[1,2]), tolerance = 1e-10)
  # (2,1) is below diag, should equal Pab_R[2,1]
  expect_equal(unname(out[2,1]), unname(Pab_R[2,1]), tolerance = 1e-10)

  # Another pair
  expect_equal(unname(out[1,4]), unname(Pab_U[1,4]), tolerance = 1e-10)
  expect_equal(unname(out[4,1]), unname(Pab_R[4,1]), tolerance = 1e-10)

  # Diagonal is forced NA
  expect_true(is.na(out[1,1]))
})

test_that("jointness returns finite values for all supported measures (where defined)", {
  set.seed(303)

  n <- 30
  x1 <- rnorm(n); x2 <- rnorm(n); x3 <- rnorm(n); x4 <- rnorm(n)
  y  <- 1 + 0.6*x1 - 0.2*x2 + 0.4*x3 + rnorm(n, sd = 0.6)

  data <- cbind(y = y, x1 = x1, x2 = x2, x3 = x3, x4 = x4)
  ms <- model_space(data, M = 4, g = "None", HC = FALSE)
  b  <- bma(ms, EMS = 2, dilution = 0, Narrative = 0, round = 12)

  for (measure in c("HCGHM","LS","DW","PPI")) {
    out <- jointness(b, measure = measure, rho = 0.5, round = 6)

    # ignore diagonal NA; require finite elsewhere (may still get Inf/NaN if probabilities hit 0)
    vals <- out[!is.na(out)]
    expect_true(all(is.finite(vals)))
  }
})

test_that("jointness respects rounding", {
  set.seed(404)

  n <- 25
  x1 <- rnorm(n); x2 <- rnorm(n); x3 <- rnorm(n); x4 <- rnorm(n)
  y  <- 1 + 0.9*x1 + rnorm(n, sd = 0.7)

  data <- cbind(y = y, x1 = x1, x2 = x2, x3 = x3, x4 = x4)
  ms <- model_space(data, M = 4, g = "None", HC = FALSE)
  b  <- bma(ms, EMS = 2, dilution = 0, Narrative = 0, round = 12)

  out3 <- jointness(b, measure = "PPI", round = 3)
  out6 <- jointness(b, measure = "PPI", round = 6)

  # Values rounded to 3 decimals should match rounding of the 6-decimal version
  expect_equal(out3, round(out6, 3))
})

test_that("jointness HCGHM changes with rho (sensitivity check)", {
  set.seed(505)

  n <- 25
  x1 <- rnorm(n); x2 <- rnorm(n); x3 <- rnorm(n); x4 <- rnorm(n)
  y  <- 1 + 0.5*x1 - 0.5*x2 + rnorm(n, sd = 0.5)

  data <- cbind(y = y, x1 = x1, x2 = x2, x3 = x3, x4 = x4)
  ms <- model_space(data, M = 4, g = "None", HC = FALSE)
  b  <- bma(ms, EMS = 2, dilution = 0, Narrative = 0, round = 12)

  out_a <- jointness(b, measure = "HCGHM", rho = 0.1, round = 6)
  out_b <- jointness(b, measure = "HCGHM", rho = 0.9, round = 6)

  # should differ somewhere off-diagonal
  expect_true(any(abs(out_a - out_b) > 1e-8, na.rm = TRUE))
})