tests/testthat/test-best_models.R

In rmsBMA: Reduced Model Space Bayesian Model Averaging

testthat::test_that("best_models returns expected structure and ranking (criterion = 1)", {

  R <- 2L
  K <- R + 1L
  MS <- 4L
  x_names <- c("x1", "x2")

  Reg_ID <- rbind(
    c(0, 0),
    c(1, 0),
    c(0, 1),
    c(1, 1)
  )

  betas <- rbind(
    c(1.0,  0.0,  0.0),
    c(1.2,  0.5,  0.0),
    c(0.8,  0.0, -0.3),
    c(1.1,  0.4, -0.2)
  )

  ses <- rbind(
    c(0.10, 0.10, 0.10),
    c(0.10, 0.20, 0.10),
    c(0.10, 0.10, 0.20),
    c(0.10, 0.20, 0.20)
  )

  DF <- c(10, 10, 10, 10)
  R2 <- c(0.10, 0.40, 0.30, 0.50)

  pmp_uniform <- c(0.05, 0.60, 0.20, 0.15)
  pmp_random  <- c(0.10, 0.10, 0.70, 0.10)

  # Matches bma(): cbind(Reg_ID, betas, SE, DF, R2, pmp_uniform, pmp_random)
  for_best_models <- cbind(Reg_ID, betas, ses, DF, R2, pmp_uniform, pmp_random)

  bma_list <- vector("list", 11)
  bma_list[[5]]  <- x_names
  bma_list[[6]]  <- R
  bma_list[[7]]  <- MS
  bma_list[[11]] <- for_best_models

  out <- best_models(bma_list, criterion = 1, best = 3, round = 3, estimate = TRUE)

  testthat::expect_type(out, "list")
  testthat::expect_length(out, 6)

  inclusion <- out[[1]]
  est_tbl   <- out[[2]]

  # Row names may be stored as a (K+2) x 1 matrix, so coerce safely:
  rn_incl <- rownames(inclusion)
  rn_incl <- if (is.matrix(rn_incl)) as.character(rn_incl[, 1]) else as.character(rn_incl)

  rn_est <- rownames(est_tbl)
  rn_est <- if (is.matrix(rn_est)) as.character(rn_est[, 1]) else as.character(rn_est)

  testthat::expect_equal(rn_incl, c("Const", "x1", "x2", "PMP", "R^2"))
  testthat::expect_equal(rn_est,  c("Const", "x1", "x2", "PMP", "R^2"))

  testthat::expect_equal(dim(inclusion), c(K + 2L, 3L))
  testthat::expect_equal(dim(est_tbl),   c(K + 2L, 3L))

  # Ranking check (criterion = 1 uses PMP_uniform)
  # Highest is model 2 -> includes x1=1, x2=0
  testthat::expect_equal(as.numeric(inclusion["x1", 1]), 1)
  testthat::expect_equal(as.numeric(inclusion["x2", 1]), 0)

  # PMP row should be decreasing
  pmp_row <- as.numeric(inclusion["PMP", ])
  testthat::expect_true(all(diff(pmp_row) <= 0))
})

testthat::test_that("best_models uses criterion=2 (PMP_random) for ranking", {

  R <- 2L
  K <- R + 1L
  MS <- 4L
  x_names <- c("x1", "x2")

  Reg_ID <- rbind(
    c(0, 0),
    c(1, 0),
    c(0, 1),
    c(1, 1)
  )

  # Keep simple, but correct dimensions:
  betas <- rbind(
    c(1, 0, 0),
    c(1, 1, 0),
    c(1, 0, 1),
    c(1, 1, 1)
  )
  ses <- matrix(0.1, nrow = MS, ncol = K)

  DF <- rep(10, MS)
  R2 <- c(0.1, 0.2, 0.3, 0.4)

  pmp_uniform <- c(0.25, 0.25, 0.25, 0.25)
  pmp_random  <- c(0.05, 0.10, 0.80, 0.05)  # model 3 best

  for_best_models <- cbind(Reg_ID, betas, ses, DF, R2, pmp_uniform, pmp_random)

  bma_list <- vector("list", 11)
  bma_list[[5]]  <- x_names
  bma_list[[6]]  <- R
  bma_list[[7]]  <- MS
  bma_list[[11]] <- for_best_models

  # Use best >= 2 to avoid stricter row.names<- edge-case with matrix RHS
  out <- best_models(bma_list, criterion = 2, best = 2, round = 3, estimate = TRUE)
  inclusion <- out[[1]]

  # Under PMP_random the best model is model 3: includes x2 only
  testthat::expect_equal(as.numeric(inclusion["x1", 1]), 0)
  testthat::expect_equal(as.numeric(inclusion["x2", 1]), 1)
})

testthat::test_that("best_models clamps best > M to best = M and still returns tables", {

  R <- 2L
  K <- R + 1L
  MS <- 4L
  x_names <- c("x1", "x2")

  Reg_ID <- rbind(c(0,0), c(1,0), c(0,1), c(1,1))
  betas  <- matrix(0, nrow = MS, ncol = K); betas[,1] <- 1
  ses    <- matrix(0.1, nrow = MS, ncol = K)
  DF     <- rep(10, MS)
  R2     <- rep(0.1, MS)
  pmp_uniform <- c(0.4, 0.3, 0.2, 0.1)
  pmp_random  <- c(0.1, 0.2, 0.3, 0.4)

  for_best_models <- cbind(Reg_ID, betas, ses, DF, R2, pmp_uniform, pmp_random)

  bma_list <- vector("list", 11)
  bma_list[[5]]  <- x_names
  bma_list[[6]]  <- R
  bma_list[[7]]  <- MS
  bma_list[[11]] <- for_best_models

  testthat::expect_message(
    out <- best_models(bma_list, criterion = 1, best = 999, round = 3, estimate = TRUE),
    "best > M"
  )

  inclusion <- out[[1]]
  testthat::expect_equal(ncol(inclusion), MS)
})