tests/testthat/test-nestedLogit.R

In insight: Easy Access to Model Information for Various Model Objects

skip_if_not_installed("nestedLogit")
skip_if_not_installed("broom")
skip_if_not_installed("car")
skip_if_not_installed("carData")

data(Womenlf, package = "carData")

comparisons <- nestedLogit::logits(
  work = nestedLogit::dichotomy("not.work", working = c("parttime", "fulltime")),
  full = nestedLogit::dichotomy("parttime", "fulltime")
)

mnl1 <- nestedLogit::nestedLogit(
  partic ~ hincome + children,
  dichotomies = comparisons,
  data = Womenlf
)

mnl2 <- nestedLogit::nestedLogit(
  partic ~ hincome + children,
  dichotomies = comparisons,
  subset = "region == 'Ontario'",
  data = Womenlf
)

test_that("model_info", {
  expect_true(model_info(mnl1)$is_logit)
  expect_true(model_info(mnl2)$is_logit)
})

test_that("find_predictors", {
  expect_identical(find_predictors(mnl1), list(conditional = c("hincome", "children")))
  expect_identical(find_predictors(mnl2), list(conditional = c("hincome", "children")))
  expect_identical(find_predictors(mnl1, flatten = TRUE), c("hincome", "children"))
  expect_null(find_predictors(mnl1, effects = "random"))
})

test_that("find_random", {
  expect_null(find_random(mnl1))
})

test_that("get_random", {
  expect_warning(get_random(mnl1))
})

test_that("find_response", {
  expect_identical(find_response(mnl1), "partic")
  expect_identical(find_response(mnl2), "partic")
})

test_that("get_response", {
  expect_equal(get_response(mnl1), Womenlf$partic, ignore_attr = TRUE)
  expect_equal(
    get_response(mnl2),
    Womenlf$partic[Womenlf$region == "Ontario"],
    ignore_attr = TRUE
  )
})

# fmt: skip
test_that("get_response, as dichotomies", {
  expect_equal(
    get_response(mnl1, dichotomies = TRUE),
    list(
      work = c(
        0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 1L,
        0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 0L,
        0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 1L, 0L,
        1L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L,
        1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L,
        1L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 1L,
        1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L,
        0L, 0L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L,
        0L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L,
        0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, 0L,
        1L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 0L, 1L, 1L, 0L,
        0L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 0L,
        1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 0L,
        1L, 0L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 1L, 0L, 1L, 0L, 1L,
        0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 0L, 1L,
        1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 1L, 0L, 0L,
        0L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L
      ),
      full = c(
        1L, 1L,
        0L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L,
        0L, 0L, 0L, 0L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 1L,
        1L, 1L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 1L,
        1L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L,
        1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, 1L,
        1L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L,
        1L, 1L, 1L, 1L, 0L, 1L, 1L, 0L, 1L, 1L
      )
    ),
    ignore_attr = TRUE
  )
  expect_equal(
    get_response(mnl2, dichotomies = TRUE),
    list(
      work = c(
        0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 1L,
        0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
        0L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L,
        0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 1L,
        1L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L,
        1L, 1L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L,
        1L, 1L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 0L, 0L
      ),
      full = c(
        1L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L,
        1L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 1L, 0L, 0L,
        0L, 1L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
      )
    ),
    ignore_attr = TRUE
  )
})

test_that("get_predictors", {
  expect_identical(colnames(get_predictors(mnl1)), c("hincome", "children"))
  expect_identical(colnames(get_predictors(mnl2)), c("hincome", "children"))
})

test_that("get_data", {
  expect_identical(nrow(get_data(mnl1)), 263L)
  expect_identical(nrow(get_data(mnl2)), 108L)
  expect_identical(colnames(get_data(mnl1)), c("partic", "hincome", "children", "region"))
  expect_identical(colnames(get_data(mnl2)), c("partic", "hincome", "children", "region"))
})

test_that("find_formula", {
  expect_length(find_formula(mnl1), 1)
  expect_equal(
    find_formula(mnl1),
    list(conditional = as.formula("partic ~ hincome + children")),
    ignore_attr = TRUE
  )
})

test_that("find_formula, as dichotomies", {
  expect_length(find_formula(mnl1, dichotomies = TRUE), 2)
  expect_equal(
    find_formula(mnl1, dichotomies = TRUE),
    list(
      work = list(conditional = as.formula("work ~ hincome + children")),
      full = list(conditional = as.formula("full ~ hincome + children"))
    ),
    ignore_attr = TRUE
  )
})

test_that("find_variables", {
  expect_identical(
    find_variables(mnl1),
    list(
      response = "partic",
      conditional = c("hincome", "children")
    )
  )
  expect_identical(
    find_variables(mnl1, flatten = TRUE),
    c("partic", "hincome", "children")
  )
})

test_that("n_obs", {
  expect_identical(n_obs(mnl1), list(work = 263L, full = 108L))
  expect_identical(n_obs(mnl2), list(work = 108L, full = 44L))
})

test_that("linkfun", {
  expect_equal(link_function(mnl1)(0.2), -1.386294, tolerance = 1e-3)
  expect_equal(link_function(mnl2)(0.2), -1.386294, tolerance = 1e-3)
})

test_that("link_inverse", {
  expect_equal(link_inverse(mnl1)(0.2), 0.549834, tolerance = 1e-3)
  expect_equal(link_inverse(mnl2)(0.2), 0.549834, tolerance = 1e-3)
})

test_that("get_parameters", {
  expect_identical(
    find_parameters(mnl1),
    list(conditional = c("(Intercept)", "hincome", "childrenpresent"))
  )
  expect_identical(nrow(get_parameters(mnl1)), 6L)
  expect_identical(
    get_parameters(mnl1)$Parameter,
    c(
      "(Intercept)",
      "hincome",
      "childrenpresent",
      "(Intercept)",
      "hincome",
      "childrenpresent"
    )
  )
  expect_equal(
    get_parameters(mnl1)$Estimate,
    unname(c(coef(mnl1)[, 1], coef(mnl1)[, 2])),
    ignore_attr = TRUE
  )
  expect_equal(
    get_parameters(mnl1, component = "full")$Estimate,
    c(3.47777, -0.10727, -2.65146),
    tolerance = 1e-3
  )
})

test_that("is_multivariate", {
  expect_false(is_multivariate(mnl1))
})

test_that("n_parameters", {
  expect_identical(n_parameters(mnl1), 3L)
})

test_that("find_algorithm", {
  expect_identical(find_algorithm(mnl1), list(algorithm = "ML"))
})

test_that("find_statistic", {
  expect_identical(find_statistic(mnl1), "z-statistic")
})

test_that("get_statistic", {
  expect_equal(
    get_statistic(mnl1)$Statistic,
    c(3.48087, -2.13894, -5.3912, 4.53361, -2.73976, -4.90035),
    tolerance = 1e-3
  )
  expect_identical(
    colnames(get_statistic(mnl1)),
    c("Parameter", "Statistic", "Response", "Component")
  )
  expect_equal(
    get_statistic(mnl1, component = "full")$Statistic,
    c(4.53361, -2.73976, -4.90035),
    tolerance = 1e-3
  )
  expect_message(get_statistic(mnl1, component = "msg"))
})

test_that("get_varcov", {
  skip_if_not_installed("sandwich")
  expect_equal(
    diag(get_varcov(mnl1)$work),
    c(`(Intercept)` = 0.14727, hincome = 0.00039, childrenpresent = 0.08542),
    tolerance = 1e-3
  )
  expect_equal(
    diag(get_varcov(mnl1, vcov = "HC3")$work),
    c(`(Intercept)` = 0.17421, hincome = 0.00051, childrenpresent = 0.08741),
    tolerance = 1e-3
  )
})

test_that("get_predicted", {
  out <- get_predicted(mnl1)
  expect_identical(length(out), 789L)
  expect_equal(
    head(out),
    c(0.70567, 0.20199, 0.09234, 0.68779, 0.19929, 0.11291),
    tolerance = 1e-3
  )
  expect_identical(ncol(as.data.frame(out)), 1L)

  d <- get_datagrid(mnl1, "children", include_response = TRUE)

  out <- get_predicted(mnl1, data = d)
  expect_identical(dim(out), c(6L, 4L))
  expect_named(out, c("Row", "Response", "children", "Predictions"))

  out <- as.data.frame(get_predicted(mnl1, data = d, ci = 0.95))
  expect_identical(dim(out), c(6L, 7L))
  expect_named(
    out,
    c("Row", "Response", "children", "Predictions", "SE", "CI_low", "CI_high")
  )

  out <- as.data.frame(get_predicted(mnl1, data = d, ci = 0.95, submodel = "dichotomies"))
  expect_identical(dim(out), c(4L, 7L))
  expect_named(
    out,
    c("Row", "Response", "children", "Predictions", "SE", "CI_low", "CI_high")
  )

  expect_error(
    get_predicted(mnl1, data = d, ci = 0.95, submodel = "test"),
    regex = "Invalid option for argument `submodel`.",
    fixed = TRUE
  )

  out <- as.data.frame(get_predicted(mnl1, data = d, ci = 0.95, predict = "link"))
  expect_equal(
    out$Predictions,
    c(-0.7115, -2.34256, 0.3354, 0.86415, -1.37518, -2.25768),
    tolerance = 1e-3
  )
  expect_equal(
    out$CI_low,
    c(-1.18639, -3.15412, -0.1215, 0.5448, -1.74915, -2.78268),
    tolerance = 1e-3
  )

  out <- get_predicted(mnl2)
  expect_identical(length(out), 324L)
  expect_equal(
    head(out),
    c(0.71458, 0.21003, 0.07539, 0.70479, 0.20517, 0.09004),
    tolerance = 1e-3
  )
  expect_identical(ncol(as.data.frame(out)), 1L)

  d <- get_datagrid(mnl2, "children", include_response = TRUE)

  out <- get_predicted(mnl2, data = d)
  expect_identical(dim(out), c(6L, 4L))
  expect_named(out, c("Row", "Response", "children", "Predictions"))

  out <- as.data.frame(get_predicted(mnl2, data = d, ci = 0.95))
  expect_identical(dim(out), c(6L, 7L))
  expect_named(
    out,
    c("Row", "Response", "children", "Predictions", "SE", "CI_low", "CI_high")
  )

  out <- as.data.frame(get_predicted(mnl2, data = d, ci = 0.95, submodel = "dichotomies"))
  expect_identical(dim(out), c(4L, 7L))
  expect_named(
    out,
    c("Row", "Response", "children", "Predictions", "SE", "CI_low", "CI_high")
  )

  expect_error(
    get_predicted(mnl2, data = d, ci = 0.95, submodel = "test"),
    regex = "Invalid option for argument `submodel`.",
    fixed = TRUE
  )

  out <- as.data.frame(get_predicted(mnl2, data = d, ci = 0.95, predict = "link"))
  expect_equal(
    out$Predictions,
    c(-0.84747, -2.85315, 0.59939, 0.95536, -1.30874, -2.66435),
    tolerance = 1e-3
  )
  expect_equal(
    out$CI_low,
    c(-1.59451, -4.35748, -0.11586, 0.44797, -1.88383, -3.67293),
    tolerance = 1e-3
  )
})