Detect multivariate vgams/vglms

R/is_multivariate.R

@@ -54,5 +54,10 @@ is_multivariate <- function(x) {
     return(isTRUE(ncol(x$coefficients) > 1L))
   }
 
-  return(FALSE)
+  vgam_classes <- c("vglm", "vgam")
+  if (inherits(x, vgam_classes)) {
+    return(isTRUE(x@extra$multiple.responses))
+  }
+
+  FALSE
 }

R/model_info.R

@@ -39,7 +39,7 @@
 #' * `is_hurdle`: model has zero-inflation component and is a hurdle-model (truncated family distribution)
 #' * `is_dispersion`: model has dispersion component (not only dispersion _parameter_)
 #' * `is_mixed`: model is a mixed effects model (with random effects)
-#' * `is_multivariate`: model is a multivariate response model (currently only works for _brmsfit_ objects)
+#' * `is_multivariate`: model is a multivariate response model (currently only works for _brmsfit_ and _vglm/vgam_ objects)
 #' * `is_trial`: model response contains additional information about the trials
 #' * `is_bayesian`: model is a Bayesian model
 #' * `is_gam`: model is a generalized additive model
@@ -1092,6 +1092,7 @@
     fitfam = faminfo@vfamily[1],
     logit.link = any(.string_contains("logit", faminfo@blurb)),
     link.fun = link.fun,
+    multi.var = is_multivariate(x),
     ...
   )
 }

inst/WORDLIST

@@ -178,6 +178,7 @@ unstandardizing
 variates
 vectorized
 vgam
+vglm
 visualisation
 warmup
 warmups

tests/testthat/test-gam.R

@@ -40,7 +40,7 @@
 
 test_that("n_parameters", {
   expect_identical(n_parameters(m1), 5L)
-  expect_identical(n_parameters(m1, component = "conditional"), 1)
+  expect_identical(n_parameters(m1, component = "conditional"), 1L)
 })
 
 test_that("clean_names", {
@@ -80,7 +80,7 @@
   expect_identical(find_predictors(m2, flatten = TRUE), c("x2", "x3", "x0", "x1"))
   expect_null(find_predictors(m2, effects = "random"))
 
   expect_identical(find_predictors(m3), list(y0 = list(conditional = c("x0", "x1")), y1 = list(conditional = c("x2", "x3"))))
   expect_identical(find_predictors(m3, flatten = TRUE), c("x0", "x1", "x2", "x3"))
   expect_null(find_predictors(m3, effects = "random"))
 })
@@ -159,7 +159,7 @@
   expect_identical(find_variables(m1, flatten = TRUE), c("y", "x0", "x1", "x2", "x3"))
   expect_identical(find_variables(m2), list(response = "y", conditional = c("x2", "x3"), zero_inflated = c("x0", "x1")))
   expect_identical(find_variables(m2, flatten = TRUE), c("y", "x2", "x3", "x0", "x1"))
   expect_identical(find_variables(m3), list(response = c(y0 = "y0", y1 = "y1"), y0 = list(conditional = c("x0", "x1")), y1 = list(conditional = c("x2", "x3"))))
   expect_identical(find_variables(m3, flatten = TRUE), c("y0", "y1", "x0", "x1", "x2", "x3"))
 })
 
@@ -278,12 +278,12 @@
 withr::with_environment(
   new.env(),
   test_that("get_predicted, gam-1", {
     # dat3 <- head(dat, 30)
     # tmp <- mgcv::gam(y ~ s(x0) + s(x1), data = dat3)
     # pred <- get_predicted(tmp, verbose = FALSE, ci = 0.95)
     # expect_s3_class(pred, "get_predicted")
     # expect_equal(
     #   as.vector(pred),
     #   c(
     #     11.99341, 5.58098, 10.89252, 7.10335, 5.94836, 6.5724, 8.5054,
     #     5.47147, 5.9343, 8.27001, 5.71199, 9.94999, 5.69979, 6.63532,
@@ -291,10 +291,10 @@
     #     7.80726, 7.38088, 5.70664, 10.60654, 7.62847, 5.8596, 6.06744,
     #     5.81571, 10.4606
     #   ),
     #   tolerance = 1e-3
     # )
 
     # x <- get_predicted(tmp, predict = NULL, type = "link", ci = 0.95)
     # y <- get_predicted(tmp, predict = "link", ci = 0.95)
     # z <- predict(tmp, type = "link", se.fit = TRUE)
     # expect_equal(x, y)

tests/testthat/test-glmmTMB.R

@@ -968,9 +968,6 @@ test_that("model_info, ordered beta", {
   out <- model_info(m)
   expect_true(out$is_orderedbeta)
   expect_identical(out$family, "ordbeta")
-  skip_on_cran()
-  out <- get_variance(m)
-  expect_equal(out$var.distribution, 1.44250604187634, tolerance = 1e-4)
 })
 
 
@@ -987,3 +984,25 @@ test_that("model_info, recognize ZI even without ziformula", {
   expect_true(out$is_zero_inflated)
   expect_true(out$is_hurdle)
 })
+
+
+skip_if_not_installed("withr")
+
+withr::with_environment(
+  new.env(),
+  test_that("get_variance, ordered beta", {
+    skip_if_not_installed("glmmTMB", minimum_version = "1.1.8")
+    skip_if_not_installed("datawizard")
+    skip_if_not_installed("lme4")
+    skip_on_cran()
+    data(sleepstudy, package = "lme4")
+    sleepstudy$y <- datawizard::normalize(sleepstudy$Reaction)
+    m <- glmmTMB::glmmTMB(
+      y ~ Days + (Days | Subject),
+      data = sleepstudy,
+      family = glmmTMB::ordbeta()
+    )
+    out <- get_variance(m)
+    expect_equal(out$var.distribution, 1.44250604187634, tolerance = 1e-4)
+  })
+)

tests/testthat/test-vgam.R

@@ -48,10 +48,11 @@ test_that("find_response", {
 })
 
 test_that("get_response", {
-  expect_equal(get_response(m1), hunua$agaaus)
+  expect_identical(get_response(m1), hunua$agaaus)
   expect_equal(
     get_response(m2),
-    data.frame(agaaus = hunua$agaaus, kniexc = hunua$kniexc)
+    data.frame(agaaus = hunua$agaaus, kniexc = hunua$kniexc),
+    ignore_attr = TRUE
   )
 })
 
@@ -195,7 +196,7 @@ test_that("find_parameters", {
 
 test_that("is_multivariate", {
   expect_false(is_multivariate(m1))
-  expect_false(is_multivariate(m2))
+  expect_true(is_multivariate(m2))
 })
 
 test_that("find_statistic", {