fix(api): validate callback contracts before model evaluation

NEWS

@@ -2,6 +2,9 @@ Changes in Version 0.5-9
 
     o bug fixes: lavaan parameter counts with equality constraints, mirt DiscreteClass (credit to Seongho Bae)
 
+    o validate public vuongtest() and icci() option and callback arguments before
+      model evaluation, with stable errors for malformed inputs
+
 Changes in Version 0.5-8
 
     o add support for objects of DiscreteClass from mirt package (credit to Phil Chalmers)

R/icci.R

@@ -65,10 +65,13 @@
 #' @export
 icci <- function(object1, object2, conf.level=.95, ll1=llcont, ll2=llcont) {
 
-  ## Security validation for inputs
+  ## Public argument validation
   if (length(conf.level) != 1 || !is.numeric(conf.level) || is.na(conf.level) || conf.level <= 0 || conf.level >= 1) {
     stop("Argument 'conf.level' must be a single numeric value between 0 and 1.", call. = FALSE)
   }
+  if (!is.function(ll1) || !is.function(ll2)) {
+    stop("Arguments 'll1' and 'll2' must be functions.", call. = FALSE)
+  }
 
   ## check objects, issue warnings/errors, get classes/calls
   obinfo <- check.obj(object1, object2)

R/vuongtest.R

@@ -98,13 +98,22 @@
 #' @export
 vuongtest <- function(object1, object2, nested=FALSE, adj="none", ll1=llcont, ll2=llcont, score1=NULL, score2=NULL, vc1=vcov, vc2=vcov) {
 
-  ## Security validation for inputs
+  ## Public argument validation
   if (length(nested) != 1 || !is.logical(nested) || is.na(nested)) {
     stop("Argument 'nested' must be a single logical value (TRUE/FALSE).", call. = FALSE)
   }
   if (length(adj) != 1 || !is.character(adj) || is.na(adj) || !(adj %in% c("none", "aic", "bic"))) {
     stop("Argument 'adj' must be a single character string ('none', 'aic', or 'bic').", call. = FALSE)
   }
+  if (!is.function(ll1) || !is.function(ll2)) {
+    stop("Arguments 'll1' and 'll2' must be functions.", call. = FALSE)
+  }
+  if ((!is.null(score1) && !is.function(score1)) || (!is.null(score2) && !is.function(score2))) {
+    stop("Arguments 'score1' and 'score2' must be functions or NULL.", call. = FALSE)
+  }
+  if (!is.function(vc1) || !is.function(vc2)) {
+    stop("Arguments 'vc1' and 'vc2' must be functions.", call. = FALSE)
+  }
 
   ## check objects, issue warnings/errors, get classes/calls
   obinfo <- check.obj(object1, object2)
@@ -285,6 +294,7 @@ calcAB <- function(object, n, scfun, vc){
     sc <- estfun(object)
   }
   sc.cp <- crossprod(sc)/n
+
   B <- matrix(sc.cp, nrow(A), nrow(A))
 
   list(A=A, B=B, sc=sc)

tests/testthat/test_exported_input_validation.R

@@ -32,3 +32,51 @@ test_that("icci validates confidence levels at the exported boundary", {
     )
   }
 })
+
+test_that("exported likelihood callbacks must be functions", {
+  callback_message <- "Arguments 'll1' and 'll2' must be functions."
+  for (value in list(NULL, "llcont", 1, TRUE, list())) {
+    expect_exported_boundary_error(
+      vuongtest(NULL, NULL, ll1 = value),
+      callback_message
+    )
+    expect_exported_boundary_error(
+      vuongtest(NULL, NULL, ll2 = value),
+      callback_message
+    )
+    expect_exported_boundary_error(
+      icci(NULL, NULL, ll1 = value),
+      callback_message
+    )
+    expect_exported_boundary_error(
+      icci(NULL, NULL, ll2 = value),
+      callback_message
+    )
+  }
+})
+
+test_that("vuongtest validates optional score and covariance callbacks", {
+  score_message <- "Arguments 'score1' and 'score2' must be functions or NULL."
+  for (value in list("score", 1, TRUE, list())) {
+    expect_exported_boundary_error(
+      vuongtest(NULL, NULL, score1 = value),
+      score_message
+    )
+    expect_exported_boundary_error(
+      vuongtest(NULL, NULL, score2 = value),
+      score_message
+    )
+  }
+
+  vc_message <- "Arguments 'vc1' and 'vc2' must be functions."
+  for (value in list(NULL, "vcov", 1, TRUE, list())) {
+    expect_exported_boundary_error(
+      vuongtest(NULL, NULL, vc1 = value),
+      vc_message
+    )
+    expect_exported_boundary_error(
+      vuongtest(NULL, NULL, vc2 = value),
+      vc_message
+    )
+  }
+})