tests/testthat/test-bootstrap-significance.R

In plsRglm: Partial Least Squares Regression for Generalized Linear Models

test_that("confints.bootpls labels CI columns and preserves predictor names", {
  skip_on_cran()
  data(Cornell, package = "plsRglm")

  set.seed(1)
  mod <- plsR(Y ~ ., data = Cornell, nt = 1, verbose = FALSE)
  bt <- bootpls(mod, R = 20, verbose = FALSE)
  ci <- suppressWarnings(confints.bootpls(bt, indices = 2:4, typeBCa = FALSE))

  expect_equal(
    colnames(ci),
    c("Normal.Lower", "Normal.Upper",
      "Basic.Lower", "Basic.Upper",
      "Percentile.Lower", "Percentile.Upper")
  )
  expect_equal(rownames(ci), c("X1", "X2", "X3"))
  expect_false(isTRUE(attr(ci, "typeBCa")))
})

test_that("confints.bootpls returns a matrix for one selected PLS coefficient", {
  skip_on_cran()
  data(Cornell, package = "plsRglm")

  set.seed(250)
  mod <- plsR(Y ~ ., data = Cornell, nt = 3, verbose = FALSE)
  bt <- bootpls(mod, R = 20, verbose = FALSE)
  ci <- suppressWarnings(confints.bootpls(bt, indices = 2, typeBCa = FALSE))

  expect_true(is.matrix(ci))
  expect_equal(dim(ci), c(1L, 6L))
  expect_equal(rownames(ci), "X1")
  expect_false(isTRUE(attr(ci, "typeBCa")))
})

test_that("confints.bootpls returns a matrix for one selected BCa coefficient", {
  set.seed(2)
  bt <- boot::boot(
    1:20,
    function(data, i) c(mean = mean(data[i]), sd = stats::sd(data[i])),
    R = 99
  )

  ci <- suppressWarnings(confints.bootpls(bt, indices = 1, typeBCa = TRUE))

  expect_true(is.matrix(ci))
  expect_equal(dim(ci), c(1L, 8L))
  expect_equal(
    colnames(ci),
    c("Normal.Lower", "Normal.Upper",
      "Basic.Lower", "Basic.Upper",
      "Percentile.Lower", "Percentile.Upper",
      "BCa.Lower", "BCa.Upper")
  )
  expect_equal(rownames(ci), "mean")
  expect_true(isTRUE(attr(ci, "typeBCa")))
})

test_that("confints2signifind defaults to BCa when available", {
  ci <- matrix(
    c(-1, 1, -1, 1, -1, 1, 0.2, 0.8,
      -1, 1, -1, 1, -1, 1, -0.4, 0.3),
    nrow = 2,
    byrow = TRUE,
    dimnames = list(c("X1", "X2"), NULL)
  )
  colnames(ci) <- c("Normal.Lower", "Normal.Upper",
                    "Basic.Lower", "Basic.Upper",
                    "Percentile.Lower", "Percentile.Upper",
                    "BCa.Lower", "BCa.Upper")
  attr(ci, "typeBCa") <- TRUE

  ind <- confints2signifind(ci)

  expect_identical(ind, c(X1 = TRUE, X2 = FALSE))
})

test_that("confints2signifind falls back to percentile intervals when BCa is absent", {
  ci <- matrix(
    c(-0.7, 0.2, -0.4, 0.1, 0.2, 0.9,
      -0.4, 0.5, -0.3, 0.4, -0.2, 0.3),
    nrow = 2,
    byrow = TRUE,
    dimnames = list(c("X1", "X2"), NULL)
  )
  colnames(ci) <- c("Normal.Lower", "Normal.Upper",
                    "Basic.Lower", "Basic.Upper",
                    "Percentile.Lower", "Percentile.Upper")
  attr(ci, "typeBCa") <- FALSE

  ind <- confints2signifind(ci)

  expect_identical(ind, c(X1 = TRUE, X2 = FALSE))
})

test_that("confints2signifind rejects BCa when those limits are unavailable", {
  ci <- matrix(
    c(-0.7, 0.2, -0.4, 0.1, 0.2, 0.9),
    nrow = 1,
    dimnames = list("X1", c("Normal.Lower", "Normal.Upper",
                             "Basic.Lower", "Basic.Upper",
                             "Percentile.Lower", "Percentile.Upper"))
  )
  attr(ci, "typeBCa") <- FALSE

  expect_error(
    confints2signifind(ci, typeIC = "BCa"),
    "BCa intervals were not computed"
  )
})

test_that("weighted_significance computes matched weighted averages", {
  cv_counts <- c("1" = 87, "2" = 13)
  matind <- rbind(
    YT1 = c(X1 = TRUE, X2 = TRUE, X3 = FALSE),
    YT2 = c(X1 = TRUE, X2 = FALSE, X3 = TRUE)
  )

  out <- weighted_significance(cv_counts, matind)

  expect_equal(out, c(X1 = 1, X2 = 0.87, X3 = 0.13))
  expect_equal(names(out), colnames(matind))
})

test_that("weighted_significance ignores unmatched components and renormalizes weights", {
  cv_counts <- c("1" = 4, "2" = 2, "3" = 94)
  matind <- rbind(
    YT1 = c(X1 = TRUE, X2 = FALSE),
    YT2 = c(X1 = FALSE, X2 = TRUE)
  )

  out <- weighted_significance(cv_counts, matind)

  expect_equal(out, c(X1 = 4 / 6, X2 = 2 / 6))
})

test_that("weighted_significance returns named NA values when no rows match", {
  cv_counts <- c("3" = 4, "4" = 6)
  matind <- rbind(
    YT1 = c(X1 = TRUE, X2 = FALSE),
    YT2 = c(X1 = FALSE, X2 = TRUE)
  )

  out <- weighted_significance(cv_counts, matind)

  expect_equal(out, c(X1 = NA_real_, X2 = NA_real_))
})

test_that("weighted_significance accepts data-frame-like indicator input", {
  cv_counts <- c("1" = 3, "2" = 1)
  matind <- data.frame(
    X1 = c(TRUE, FALSE),
    X2 = c(TRUE, TRUE),
    row.names = c("YT1", "YT2")
  )

  out <- weighted_significance(cv_counts, matind)

  expect_equal(out, c(X1 = 0.75, X2 = 1))
  expect_equal(names(out), names(matind))
})