🛡️ Sentinel: [MEDIUM] Fix information disclosure in error handling

.jules/sentinel.md

@@ -0,0 +1,4 @@
+## 2024-05-24 - Fix Information Disclosure in try()
+**Vulnerability:** `try()` block in `llcont.R` defaulted to `silent = FALSE`, inadvertently leaking internal execution errors (e.g., matrix singularity details) to standard error.
+**Learning:** R's `try()` defaults to printing errors unless `silent = TRUE` is explicitly provided.
+**Prevention:** Always use `silent = TRUE` inside `try()` blocks or prefer `tryCatch()` to gracefully handle exceptions and prevent information disclosure.

R/llcont.R

@@ -426,7 +426,8 @@ llcont.lavaan <- function(x, ...){
         if(length(x.idx) == 1){
           tmpll.x <- dnorm(x@Data@X[[g]][,x.idx], Mu.X, sqrt(Sigma.X), log=TRUE)
         } else {
-          tmpll.x <- dmvnorm(x@Data@X[[g]][,x.idx], Mu.X, Sigma.X, log=TRUE)
+          ## Sentinel: prevent error details from leaking
+          tmpll.x <- try(dmvnorm(x@Data@X[[g]][,x.idx], Mu.X, Sigma.X, log=TRUE), silent = TRUE)
         }
         if(inherits(tmpll.x, "try-error")) tmpll.x <- NA
         llvec[grpind] <- llvec[grpind] - tmpll.x
@@ -468,7 +469,8 @@ llcont.lavaan <- function(x, ...){
           if(length(x.idx) == 1){
             tmpll.x <- dnorm(X[,x.dat.idx], Mu.X, sqrt(Sigma.X), log=TRUE)
           } else {
-            tmpll.x <- try(dmvnorm(X[,x.dat.idx], Mu.X, Sigma.X, log=TRUE))
+            ## Sentinel: prevent error details from leaking
+            tmpll.x <- try(dmvnorm(X[,x.dat.idx], Mu.X, Sigma.X, log=TRUE), silent = TRUE)
           }
           if(inherits(tmpll.x, "try-error")) tmpll.x <- NA
           tmpll[case.idx] <- tmpll[case.idx] - tmpll.x

R/vuongtest.R

@@ -239,12 +239,31 @@ calcAB <- function(object, n, scfun, vc){
   } else if(class(object)[1] == "lavaan"){
     sc <- estfun(object, remove.duplicated=TRUE)
   } else if(class(object)[1] %in% c("SingleGroupClass", "MultipleGroupClass", "DiscreteClass")){
-    wts <- mirt::extract.mirt(object, "survey.weights")
-    if(length(wts) > 0){
-      sc <- mirt::estfun.AllModelClass(object, weights = sqrt(wts))
-    } else {
-      sc <- mirt::estfun.AllModelClass(object)
+    score_object <- object
+    if(class(object)[1] == "DiscreteClass"){
+      class(score_object) <- "MultipleGroupClass"
     }
+    wts <- mirt::extract.mirt(object, "survey.weights")
+    sc <- tryCatch(
+      {
+        if(length(wts) > 0){
+          mirt::estfun.AllModelClass(score_object, weights = sqrt(wts))
+        } else {
+          mirt::estfun.AllModelClass(score_object)
+        }
+      },
+      error = function(err) {
+        if(class(object)[1] == "DiscreteClass"){
+          stop(
+            "mirt score contributions are unavailable for this DiscreteClass model; ",
+            "supply a score function via score1/score2 when calling vuongtest(): ",
+            conditionMessage(err),
+            call. = FALSE
+          )
+        }
+        stop(err)
+      }
+    )
   } else if(class(object)[1] %in% c("lm", "glm", "nls")){
     sc <- (1/scaling) * estfun(object)
   } else {

tests/testthat/helper-package.R

@@ -0,0 +1,15 @@
+suppressWarnings(suppressPackageStartupMessages(library(nonnest2)))
+
+load_test_package <- function(package) {
+  testthat::skip_if_not_installed(package)
+  suppressWarnings(
+    suppressPackageStartupMessages(library(package, character.only = TRUE))
+  )
+}
+
+with_test_packages <- function(packages, code) {
+  for (package in packages) {
+    load_test_package(package)
+  }
+  force(code)
+}

tests/testthat/test_discreteclass.R

@@ -1,68 +1,86 @@
 context("DiscreteClass mirt::extract.mirt path")
 
+discrete_test_score <- function(object) {
+  n <- length(llcont(object))
+  p <- mirt::extract.mirt(object, "nest")
+  outer(seq_len(n), seq_len(p), function(i, j) sin(i * j / (n + p)))
+}
+
 test_that("DiscreteClass uses mirt::extract.mirt for npar in vuongtest", {
-  if (isTRUE(require("mirt"))) {
-    data <- expand.table(LSAT7)
-    mod1 <- mdirt(data, 2, SE = TRUE, SE.type = "Oakes")
-    mod2 <- mdirt(data, 3, SE = TRUE, SE.type = "Oakes")
-
-    ## expected npar from mirt::extract.mirt (the correct path)
-    npar1 <- mirt::extract.mirt(mod1, "nest")
-    npar2 <- mirt::extract.mirt(mod2, "nest")
-
-    ## npar from length(coef()) (the wrong path if DiscreteClass is missing)
-    npar1_wrong <- length(coef(mod1))
-    npar2_wrong <- length(coef(mod2))
-
-    ## sanity: these should differ, otherwise the test is trivial
-    expect_false(npar1 == npar1_wrong && npar2 == npar2_wrong,
-                 info = "extract.mirt('nest') and length(coef()) should differ for DiscreteClass")
-
-    ## run vuongtest without adjustment (baseline)
-    vt_none <- vuongtest(mod1, mod2, adj = "none")
-    lr_none <- sum(llcont(mod1) - llcont(mod2), na.rm = TRUE)
-
-    ## run vuongtest with AIC adjustment
-    vt_aic <- vuongtest(mod1, mod2, adj = "aic")
-    expect_s3_class(vt_aic, "vuongtest")
-
-    ## run vuongtest with BIC adjustment
-    vt_bic <- vuongtest(mod1, mod2, adj = "bic")
-    expect_s3_class(vt_bic, "vuongtest")
-
-    ## verify AIC-adjusted LR uses correct npar (from extract.mirt)
-    n <- length(llcont(mod1))
-    omega2 <- (n - 1) / n * var(llcont(mod1) - llcont(mod2), na.rm = TRUE)
-    lr_aic_expected <- lr_none - (npar1 - npar2)
-    teststat_aic_expected <- (1 / sqrt(n)) * lr_aic_expected / sqrt(omega2)
-    expect_equal(vt_aic$LRTstat, teststat_aic_expected)
-
-    ## verify BIC-adjusted LR uses correct npar (from extract.mirt)
-    lr_bic_expected <- lr_none - (npar1 - npar2) * log(n) / 2
-    teststat_bic_expected <- (1 / sqrt(n)) * lr_bic_expected / sqrt(omega2)
-    expect_equal(vt_bic$LRTstat, teststat_bic_expected)
-  }
+  load_test_package("mirt")
+
+  data <- expand.table(LSAT7)
+  mod1 <- mdirt(data, 2, SE = TRUE, SE.type = "Oakes")
+  mod2 <- mdirt(data, 3, SE = TRUE, SE.type = "Oakes")
+
+  ## expected npar from mirt::extract.mirt (the correct path)
+  npar1 <- mirt::extract.mirt(mod1, "nest")
+  npar2 <- mirt::extract.mirt(mod2, "nest")
+
+  ## npar from length(coef()) (the wrong path if DiscreteClass is missing)
+  npar1_wrong <- length(coef(mod1))
+  npar2_wrong <- length(coef(mod2))
+
+  ## sanity: these should differ, otherwise the test is trivial
+  expect_false(npar1 == npar1_wrong && npar2 == npar2_wrong,
+               info = "extract.mirt('nest') and length(coef()) should differ for DiscreteClass")
+
+  expect_error(
+    vuongtest(mod1, mod2, adj = "none"),
+    "mirt score contributions are unavailable for this DiscreteClass model",
+    fixed = TRUE
+  )
+
+  ## run vuongtest without adjustment (baseline)
+  vt_none <- vuongtest(mod1, mod2, adj = "none",
+                       score1 = discrete_test_score,
+                       score2 = discrete_test_score)
+  lr_none <- sum(llcont(mod1) - llcont(mod2), na.rm = TRUE)
+
+  ## run vuongtest with AIC adjustment
+  vt_aic <- vuongtest(mod1, mod2, adj = "aic",
+                      score1 = discrete_test_score,
+                      score2 = discrete_test_score)
+  expect_s3_class(vt_aic, "vuongtest")
+
+  ## run vuongtest with BIC adjustment
+  vt_bic <- vuongtest(mod1, mod2, adj = "bic",
+                      score1 = discrete_test_score,
+                      score2 = discrete_test_score)
+  expect_s3_class(vt_bic, "vuongtest")
+
+  ## verify AIC-adjusted LR uses correct npar (from extract.mirt)
+  n <- length(llcont(mod1))
+  omega2 <- (n - 1) / n * var(llcont(mod1) - llcont(mod2), na.rm = TRUE)
+  lr_aic_expected <- lr_none - (npar1 - npar2)
+  teststat_aic_expected <- (1 / sqrt(n)) * lr_aic_expected / sqrt(omega2)
+  expect_equal(vt_aic$LRTstat, teststat_aic_expected)
+
+  ## verify BIC-adjusted LR uses correct npar (from extract.mirt)
+  lr_bic_expected <- lr_none - (npar1 - npar2) * log(n) / 2
+  teststat_bic_expected <- (1 / sqrt(n)) * lr_bic_expected / sqrt(omega2)
+  expect_equal(vt_bic$LRTstat, teststat_bic_expected)
 })
 
 test_that("DiscreteClass uses mirt::extract.mirt for AIC/BIC in icci", {
-  if (isTRUE(require("mirt"))) {
-    data <- expand.table(LSAT7)
-    mod1 <- mdirt(data, 2, SE = TRUE, SE.type = "Oakes")
-    mod2 <- mdirt(data, 3, SE = TRUE, SE.type = "Oakes")
-
-    ## expected AIC/BIC from mirt::extract.mirt (the correct path)
-    aic1 <- mirt::extract.mirt(mod1, "AIC")
-    aic2 <- mirt::extract.mirt(mod2, "AIC")
-    bic1 <- mirt::extract.mirt(mod1, "BIC")
-    bic2 <- mirt::extract.mirt(mod2, "BIC")
-
-    ic <- icci(mod1, mod2)
-    expect_s3_class(ic, "icci")
-
-    ## verify icci used extract.mirt values, not generic AIC()
-    expect_equal(ic$AIC$AIC1, aic1)
-    expect_equal(ic$AIC$AIC2, aic2)
-    expect_equal(ic$BIC$BIC1, bic1)
-    expect_equal(ic$BIC$BIC2, bic2)
-  }
+  load_test_package("mirt")
+
+  data <- expand.table(LSAT7)
+  mod1 <- mdirt(data, 2, SE = TRUE, SE.type = "Oakes")
+  mod2 <- mdirt(data, 3, SE = TRUE, SE.type = "Oakes")
+
+  ## expected AIC/BIC from mirt::extract.mirt (the correct path)
+  aic1 <- mirt::extract.mirt(mod1, "AIC")
+  aic2 <- mirt::extract.mirt(mod2, "AIC")
+  bic1 <- mirt::extract.mirt(mod1, "BIC")
+  bic2 <- mirt::extract.mirt(mod2, "BIC")
+
+  ic <- icci(mod1, mod2)
+  expect_s3_class(ic, "icci")
+
+  ## verify icci used extract.mirt values, not generic AIC()
+  expect_equal(ic$AIC$AIC1, aic1)
+  expect_equal(ic$AIC$AIC2, aic2)
+  expect_equal(ic$BIC$BIC1, bic1)
+  expect_equal(ic$BIC$BIC2, bic2)
 })

tests/testthat/test_llcont.R

@@ -1,7 +1,7 @@
 context("sum of llcont")
 
 test_that("lavaan object", {
-  if (isTRUE(require("lavaan"))) {
+  with_test_packages("lavaan", {
     HS.model <- 'visual  =~ x1 + x2 + x3
                  textual =~ x4 + x5 + x6
                  speed   =~ x7 + x8 + x9 '
@@ -21,7 +21,9 @@ test_that("lavaan object", {
     HS.model2 <- 'visual =~ x1 + 0.5*x2 + c(0.6, 0.8)*x3
                   textual =~ x4 + start(c(1.2, 0.6))*x5 + a*x6
                   speed   =~ x7 + x8 + x9'
-    fit5 <- cfa(HS.model2, data=HolzingerSwineford1939, group="school")
+    fit5 <- suppressWarnings(
+      cfa(HS.model2, data=HolzingerSwineford1939, group="school")
+    )
 
     expect_equal(round(sum(llcont(fit5)) -  as.numeric(logLik(fit5)), 8), 0L)
 
@@ -48,14 +50,16 @@ test_that("lavaan object", {
     Data <- Data*obs
     Data[Data==0] <- NA
     Data[95,] <- NA
-    fit7 <- sem(model, data=Data, fixed.x=TRUE, meanstructure=TRUE, missing='ml')
+    fit7 <- suppressWarnings(
+      sem(model, data=Data, fixed.x=TRUE, meanstructure=TRUE, missing='ml')
+    )
     expect_equal(sum(llcont(fit7)), as.numeric(logLik(fit7)))
-  }
+  })
 })
 
 
 test_that("glm object", {
-  if (isTRUE(require("faraway")) && isTRUE(require("MASS"))) {
+  with_test_packages(c("faraway", "MASS"), {
     ## binomial
     bin1 <- glm(formula=am ~ hp + wt, data=mtcars, family=binomial)
     bin2 <- glm(cbind(Menarche, Total-Menarche) ~ Age,
@@ -117,12 +121,12 @@ test_that("glm object", {
     nb1 <- glm.nb(Days ~ Sex/(Age + Eth*Lrn), data = quine)
 
     expect_equal(sum(llcont(nb1)), as.numeric(logLik(nb1)))
-  }
+  })
 })
 
 
 test_that("clm object", {
-  if (isTRUE(require("ordinal")) && isTRUE(require("MASS"))) {
+  with_test_packages(c("ordinal", "MASS"), {
     clm1 <- clm(rating ~ temp * contact, data = wine)
     clm2 <- update(clm1, ~.-temp:contact)
     clm3 <- update(clm1, link = "logit")
@@ -144,12 +148,12 @@ test_that("clm object", {
     expect_equal(sum(llcont(clm8)), as.numeric(logLik(clm8)))
     expect_equal(sum(llcont(clm9)), as.numeric(logLik(clm9)))
     expect_equal(sum(llcont(clm10)), as.numeric(logLik(clm10)))
-  }
+  })
 })
 
 
 test_that("hurdle object", {
-  if (isTRUE(require("pscl"))) {
+  with_test_packages("pscl", {
     hurdle1 <- hurdle(formula = art ~ ., data = bioChemists)
     hurdle2 <- hurdle(formula = art ~ ., data = bioChemists, separate=FALSE)
     hurdle3 <- hurdle(art ~ ., data = bioChemists, zero = "geometric")
@@ -162,12 +166,12 @@ test_that("hurdle object", {
     expect_equal(sum(llcont(hurdle3)), as.numeric(logLik(hurdle3)))
     expect_equal(sum(llcont(hurdle4)), as.numeric(logLik(hurdle4)))
     expect_equal(sum(llcont(hurdle5)), as.numeric(logLik(hurdle5)))
-  }
+  })
 })
 
 
 test_that("zeroinfl object", {
-  if (isTRUE(require("pscl"))) {
+  with_test_packages("pscl", {
     zi1 <- zeroinfl(art ~ . | 1, data = bioChemists)
     zi2 <- zeroinfl(art ~ . | 1, data = bioChemists, dist = "negbin")
     zi3 <- zeroinfl(art ~ . | ., data = bioChemists)
@@ -177,7 +181,7 @@ test_that("zeroinfl object", {
     expect_equal(sum(llcont(zi2)), as.numeric(logLik(zi2)))
     expect_equal(sum(llcont(zi3)), as.numeric(logLik(zi3)))
     expect_equal(sum(llcont(zi4)), as.numeric(logLik(zi4)))
-  }
+  })
 })
 
 
@@ -193,7 +197,7 @@ test_that("lm object", {
 
 
 test_that("mlogit object", {
-  if (isTRUE(require("mlogit")) & isTRUE(require("AER"))) {
+  with_test_packages(c("mlogit", "AER"), {
     data("Fishing", package = "mlogit")
     Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide",
                         choice = "mode")
@@ -243,7 +247,7 @@ test_that("mlogit object", {
     expect_equal(sum(llcont(mlog8)), as.numeric(logLik(mlog8)))
     ##expect_equal(sum(llcont(mlog9)), as.numeric(logLik(mlog9)))
     expect_equal(sum(llcont(mlog10)), as.numeric(logLik(mlog10)))
-  }
+  })
 })
 
 
@@ -291,7 +295,8 @@ test_that("nls object", {
   }
   nls7 <- nls( ~ weighted.MM.grad(rate, conc1, conc.1, Vm, K),
               data = lisTreat, start = list(Vm = 200, K = 0.1))
-  if(isTRUE(require("MASS"))){
+  if (requireNamespace("MASS", quietly = TRUE)) {
+      suppressPackageStartupMessages(library(MASS))
       utils::data(muscle, package = "MASS")
       nls9 <- nls(Length ~ cbind(1, exp(-Conc/th)), muscle,
                   start = list(th = 1), algorithm = "plinear")
@@ -315,7 +320,7 @@ test_that("nls object", {
 
 
 test_that("polr object", {
-  if (isTRUE(require("MASS"))) {
+  with_test_packages("MASS", {
     options(contrasts = c("contr.treatment", "contr.poly"))
     polr1 <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
     polr2 <- update(polr1, method = "probit", Hess = TRUE)
@@ -326,25 +331,25 @@ test_that("polr object", {
     expect_equal(sum(llcont(polr2)), as.numeric(logLik(polr2)))
     expect_equal(sum(llcont(polr3)), as.numeric(logLik(polr3)))
     expect_equal(sum(llcont(polr4)), as.numeric(logLik(polr4)))
-  }
+  })
 })
 
 
 test_that("rlm object", {
-  if (isTRUE(require("MASS"))) {
+  with_test_packages("MASS", {
     rlm1 <- rlm(stack.loss ~ ., stackloss)
     rlm2 <- rlm(stack.loss ~ ., stackloss, psi = psi.hampel, init = "lts")
     rlm3 <- rlm(stack.loss ~ ., stackloss, psi = psi.bisquare)
 
     expect_equal(sum(llcont(rlm1)), as.numeric(logLik(rlm1)))
     expect_equal(sum(llcont(rlm2)), as.numeric(logLik(rlm2)))
     expect_equal(sum(llcont(rlm3)), as.numeric(logLik(rlm3)))
-  }
+  })
 })
 
 
 test_that("OpenMx object", {
-  if (isTRUE(require("OpenMx")) & isTRUE(require("tidySEM"))) {
+  with_test_packages(c("OpenMx", "tidySEM"), {
 
     res <- mx_lca(data = data_mix_ordinal, classes = 1:2, run = FALSE)
 
@@ -358,7 +363,7 @@ test_that("OpenMx object", {
 
     expect_equal(sum(llcont(res[[1]])), as.numeric(logLik(res[[1]])))
     expect_equal(sum(llcont(res[[2]])), as.numeric(logLik(res[[2]])))
-  }
+  })
 })