find_ and get_ methods with models of multiple formula components lik…

…e clm() & lme() (#729)

* find_ and get_ methods with models of multiple formula components like clm() & lme()
Fixes #727

* fix lme issue

* news, version

* fix for clm

* fix test

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.19.0.9
+Version: 0.19.0.10
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",

NAMESPACE

@@ -100,6 +100,7 @@ S3method(find_formula,btergm)
 S3method(find_formula,censReg)
 S3method(find_formula,cgamm)
 S3method(find_formula,cglm)
+S3method(find_formula,clm)
 S3method(find_formula,clm2)
 S3method(find_formula,clmm)
 S3method(find_formula,clmm2)
@@ -323,6 +324,7 @@ S3method(find_terms,default)
 S3method(find_terms,mipo)
 S3method(find_weights,brmsfit)
 S3method(find_weights,default)
+S3method(find_weights,lme)
 S3method(find_weights,merMod)
 S3method(find_weights,model_fit)
 S3method(format,insight_formula)

NEWS.md

@@ -15,10 +15,16 @@
 * `format_table()` now also formats columns named `SGPV` (second generation
   p-values) as p-values.
 
+* Functions for models of class `clm` (like `find_formula()`, `find_variables()`,
+  `get_data()` etc.) now also include variables that were defined as `scale` or
+  `nominal` component.
+
 ## Bug fixes
 
 * Fixed issue in `get_data()` for results from `kruskal.test()`.
 
+* Fixed issue in `find_weights()` for models of class `lme`.
+
 # insight 0.19.0
 
 ## New supported models

R/find_formula.R

@@ -1037,6 +1037,17 @@ find_formula.clm2 <- function(x, verbose = TRUE, ...) {
 }
 
 
+#' @export
+find_formula.clm <- function(x, verbose = TRUE, ...) {
+  f <- compact_list(list(
+    conditional = stats::formula(x),
+    scale = x$formulas$scale,
+    nominal = x$formulas$nominal
+  ))
+  .find_formula_return(f, verbose = verbose)
+}
+
+
 #' @export
 find_formula.DirichletRegModel <- function(x, verbose = TRUE, ...) {
   f <- safe_deparse(stats::formula(x))

R/find_weights.R

@@ -96,3 +96,21 @@ find_weights.merMod <- function(x, ...) {
     }
   )
 }
+
+
+#' @export
+find_weights.lme <- function(x, ...) {
+  w <- find_weights.default(x, ...)
+  # any weights? If so, get formula
+  if (!is.null(w)) {
+    # in lme(), weights are either an optional varFunc object or a one-sided
+    # formula. The formula is usally stored in "$modelStruct$varStruct"
+    w_formula <- .safe(stats::formula(x$modelStruct$varStruct))
+    if (!is.null(w_formula)) {
+      w <- all.vars(w_formula)
+    } else {
+      w <- NULL
+    }
+  }
+  w
+}

R/helper_functions.R

@@ -208,7 +208,8 @@
     "sigma", "nu", "tau", "correlation", "slopes", "cluster", "extra", "scale",
     "marginal", "alpha", "beta", "survival", "infrequent_purchase", "auxiliary",
     "mix", "shiftprop", "phi", "ndt", "hu", "xi", "coi", "zoi", "aux", "dist",
-    "selection", "outcome", "time_dummies", "sigma_random", "beta_random", "car"
+    "selection", "outcome", "time_dummies", "sigma_random", "beta_random", "car",
+    "nominal"
   )
 }
 

tests/testthat/test-clm.R

@@ -2,6 +2,13 @@ if (skip_if_not_or_load_if_installed("ordinal")) {
   data(wine, package = "ordinal")
   m1 <- clm(rating ~ temp * contact, data = wine)
 
+  data(mtcars)
+  m2 <- suppressWarnings(clm( # nominal + scale effects
+    cyl ~ wt,
+    scale = ~vs, nominal = ~hp,
+    data = transform(mtcars, cyl = factor(cyl))
+  ))
+
   test_that("model_info", {
     expect_true(model_info(m1)$is_ordinal)
     expect_false(model_info(m1)$is_multinomial)
@@ -12,6 +19,10 @@ if (skip_if_not_or_load_if_installed("ordinal")) {
     expect_identical(find_predictors(m1), list(conditional = c("temp", "contact")))
     expect_identical(find_predictors(m1, flatten = TRUE), c("temp", "contact"))
     expect_null(find_predictors(m1, effects = "random"))
+    expect_identical(
+      find_predictors(m2),
+      list(conditional = "wt", scale = "vs", nominal = "hp")
+    )
   })
 
   test_that("find_random", {
@@ -27,20 +38,21 @@ if (skip_if_not_or_load_if_installed("ordinal")) {
   })
 
   test_that("get_response", {
-    expect_equal(get_response(m1), wine$rating)
+    expect_equal(get_response(m1), wine$rating, tolerance = 1e-5)
   })
 
   test_that("get_predictors", {
-    expect_equal(colnames(get_predictors(m1)), c("temp", "contact"))
+    expect_identical(colnames(get_predictors(m1)), c("temp", "contact"))
   })
 
   test_that("link_inverse", {
     expect_equal(link_inverse(m1)(0.2), plogis(0.2), tolerance = 1e-5)
   })
 
   test_that("get_data", {
-    expect_equal(nrow(get_data(m1)), 72)
-    expect_equal(colnames(get_data(m1)), c("rating", "temp", "contact"))
+    expect_identical(nrow(get_data(m1)), 72L)
+    expect_identical(colnames(get_data(m1)), c("rating", "temp", "contact"))
+    expect_identical(colnames(get_data(m2)), c("cyl", "wt", "vs", "hp"))
   })
 
   test_that("find_formula", {
@@ -50,21 +62,45 @@ if (skip_if_not_or_load_if_installed("ordinal")) {
       list(conditional = as.formula("rating ~ temp * contact")),
       ignore_attr = TRUE
     )
+    expect_equal(
+      find_formula(m2),
+      list(
+        conditional = as.formula("cyl ~ wt"),
+        scale = as.formula("~vs"),
+        nominal = as.formula("~hp")
+      ),
+      ignore_attr = TRUE
+    )
+  })
+
+  test_that("find_variables", {
+    expect_identical(
+      find_variables(m2),
+      list(response = "cyl", conditional = "wt", scale = "vs", nominal = "hp")
+    )
   })
 
   test_that("find_terms", {
-    expect_equal(find_terms(m1), list(
-      response = "rating",
-      conditional = c("temp", "contact")
-    ))
     expect_equal(
+      find_terms(m1),
+      list(
+        response = "rating",
+        conditional = c("temp", "contact")
+      ),
+      ignore_attr = TRUE
+    )
+    expect_identical(
       find_terms(m1, flatten = TRUE),
       c("rating", "temp", "contact")
     )
+    expect_identical(
+      find_terms(m2),
+      list(response = "cyl", conditional = "wt", scale = "vs", nominal = "hp")
+    )
   })
 
   test_that("n_obs", {
-    expect_equal(n_obs(m1), 72)
+    expect_equal(n_obs(m1), 72) # nolint
   })
 
   test_that("linkfun", {
@@ -84,10 +120,11 @@ if (skip_if_not_or_load_if_installed("ordinal")) {
           "contactyes",
           "tempwarm:contactyes"
         )
-      )
+      ),
+      ignore_attr = TRUE
     )
-    expect_equal(nrow(get_parameters(m1)), 7)
-    expect_equal(
+    expect_identical(nrow(get_parameters(m1)), 7L)
+    expect_identical(
       get_parameters(m1)$Parameter,
       c(
         "1|2",
@@ -116,15 +153,15 @@ if (skip_if_not_or_load_if_installed("ordinal")) {
     y <- as.data.frame(get_predicted(m1, predict = NULL, type = "prob"))
     z <- predict(m1, type = "prob", newdata = nd, se.fit = TRUE)
     expect_true(all(c("Row", "Response", "Predicted", "SE") %in% colnames(x)))
-    expect_equal(x, y)
+    expect_equal(x, y, tolerance = 1e-5)
     for (i in 1:5) {
       expect_equal(x$Predicted[x$Response == i], unname(z$fit[, i]), ignore_attr = FALSE)
       expect_equal(x$SE[x$Response == i], unname(z$se.fit[, i]), ignore_attr = FALSE)
     }
     x <- as.data.frame(get_predicted(m1, predict = "classification"))
     y <- as.data.frame(get_predicted(m1, predict = NULL, type = "class"))
     z <- predict(m1, type = "class", newdata = nd)
-    expect_equal(x, y)
+    expect_equal(x, y, tolerance = 1e-5)
     expect_equal(as.character(x$Predicted), as.character(z$fit), ignore_attr = FALSE)
 
     # we use a hack to handle in-formula factors

tests/testthat/test-find_weights.R

@@ -3,12 +3,44 @@ if (skip_if_not_or_load_if_installed("lme4")) {
     data(mtcars)
     mtcars$weight <- rnorm(nrow(mtcars), 1, 0.3)
     m <- lm(mpg ~ wt + cyl + vs, data = mtcars, weights = weight)
-    expect_equal(find_weights(m), "weight")
+    expect_identical(find_weights(m), "weight")
   })
   test_that("find_weights", {
     data(iris)
     iris$wgt <- rnorm(nrow(iris), 1, 0.3)
     m <- lmer(Sepal.Width ~ Sepal.Length + (1 | Species), data = iris, weights = wgt)
-    expect_equal(find_weights(m), "wgt")
+    expect_identical(find_weights(m), "wgt")
+  })
+}
+
+
+if (skip_if_not_or_load_if_installed("nlme")) {
+  data(Orthodont)
+  Orthodont$w <- abs(rnorm(nrow(Orthodont)))
+
+  m1 <- lme(
+    distance ~ age,
+    data = Orthodont,
+    random = ~ 1 | Subject,
+    weights = varIdent(form = ~ 1 | Sex)
+  )
+
+  m2 <- lme(
+    distance ~ age,
+    data = Orthodont,
+    random = ~ 1 | Subject
+  )
+
+  m3 <- lme(
+    distance ~ age,
+    data = Orthodont,
+    random = ~ 1 | Subject,
+    weights = ~w
+  )
+
+  test_that("find_weights", {
+    expect_identical(find_weights(m1), "Sex")
+    expect_null(find_weights(m2))
+    expect_identical(find_weights(m3), "w")
   })
 }