tests/testthat/test-flexible-earth.R

In tidymodels/discrim: Model Wrappers for Discriminant Analysis

test_that("mda::fda/earth model object", {
  skip_if_not_installed("mda")
  skip_if_not_installed("earth")
  skip_if_not_installed("mlbench")
  # exp_* objects in helper-object.R

  # formula method
  expect_no_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr))
  expect_equal(f_fit$fit$theta.mod, exp_f_fit_fda$theta.mod)
  expect_equal(f_fit$fit$fit$cuts, exp_f_fit_fda$fit$cuts)

  expect_no_error(
    f_wts_fit <- fit(fda_spec, Type ~ ., case_weights = wts,
                     data = glass_tr)
  )
  expect_equal(f_wts_fit$fit$theta.mod, exp_f_wts_fit_fda$theta.mod)
  expect_equal(f_wts_fit$fit$fit$cuts, exp_f_wts_fit_fda$fit$cuts)

  # x/y method
  expect_no_error(
    xy_fit <- fit_xy(fda_spec, x = glass_tr[, -10], y = glass_tr$Type)
  )
  expect_equal(xy_fit$fit$theta.mod, exp_f_fit_fda$theta.mod)
  expect_equal(xy_fit$fit$fit$cuts, exp_f_fit_fda$fit$cuts)

  expect_no_error(
    xy_wts_fit <- fit_xy(fda_spec, x = glass_tr[, -10], y = glass_tr$Type,
                         case_weights = wts)
  )
  expect_equal(xy_wts_fit$fit$theta.mod, exp_f_wts_fit_fda$theta.mod)
  expect_equal(xy_wts_fit$fit$fit$cuts, exp_f_wts_fit_fda$fit$cuts)
})

# ------------------------------------------------------------------------------


test_that("mda::fda/earth class predictions", {
  skip_if_not_installed("mda")
  skip_if_not_installed("earth")
  skip_if_not_installed("mlbench")
  # exp_* objects in helper-object.R

  # formula method
  expect_no_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr))
  f_pred <- predict(f_fit, glass_te)
  exp_f_pred <- predict(exp_f_fit_fda, glass_te)

  expect_true(inherits(f_pred, "tbl_df"))
  expect_true(all(names(f_pred) == ".pred_class"))
  expect_equal(f_pred$.pred_class, exp_f_pred)

  # x/y method
  expect_no_error(
    xy_fit <- fit_xy(fda_spec, x = glass_tr[, -10], y = glass_tr$Type)
  )
  xy_pred <- predict(xy_fit, glass_te)
  # See bug note above
  # exp_xy_pred <- predict(exp_xy_fit, glass_te)

  expect_true(inherits(xy_pred, "tbl_df"))
  expect_true(all(names(xy_pred) == ".pred_class"))
  expect_equal(xy_pred$.pred_class, exp_f_pred)
})

# ------------------------------------------------------------------------------


test_that("mda::fda/earth prob predictions", {
  skip_if_not_installed("mda")
  skip_if_not_installed("earth")
  skip_if_not_installed("mlbench")
  # exp_* objects in helper-object.R

  # formula method
  expect_no_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr))
  f_pred <- predict(f_fit, glass_te, type = "prob")
  exp_f_pred <- probs_to_tibble(predict(exp_f_fit_fda, glass_te, type = "posterior"))

  expect_true(inherits(f_pred, "tbl_df"))
  expect_equal(names(f_pred), glass_prob_names)
  expect_equal(f_pred, exp_f_pred)

  # x/y method
  expect_no_error(
    xy_fit <- fit_xy(fda_spec, x = glass_tr[, -10], y = glass_tr$Type)
  )
  xy_pred <- predict(xy_fit, glass_te, type = "prob")
  expect_true(inherits(xy_pred, "tbl_df"))
  expect_equal(names(xy_pred), glass_prob_names)
  expect_equal(xy_pred, exp_f_pred)
})

# ------------------------------------------------------------------------------


test_that("mda::fda/earth missing data", {
  skip_if_not_installed("mda")
  skip_if_not_installed("earth")
  skip_if_not_installed("mlbench")
  # exp_* objects in helper-object.R

  expect_no_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr))
  f_pred <- predict(f_fit, glass_na, type = "prob")

  opt <- getOption("na.action")
  options(na.action = "na.pass")
  exp_f_pred <- probs_to_tibble(predict(exp_f_fit_fda, glass_na, type = "posterior"))
  options(na.action = opt)

  expect_true(inherits(f_pred, "tbl_df"))
  expect_true(nrow(f_pred) == nrow(glass_te))
  expect_equal(names(f_pred), glass_prob_names)
  expect_equal(f_pred, exp_f_pred)
})

# ------------------------------------------------------------------------------

test_that("mda::fda/earth updating", {
  skip_if_not_installed("earth")
  skip_if_not_installed("mda")
  skip_if_not_installed("mlbench")

  fda_spec_2 <- discrim_flexible(num_terms = 6) %>% set_engine("earth")
  fda_spec_3 <- update(fda_spec, num_terms = 6)
  expect_equal(fda_spec_2, fda_spec_3)
})

test_that('mda::fda/earth check_args() works', {
  skip_if_not_installed("earth")
  skip_if_not_installed("parsnip", "1.2.1.9001")
  skip_if_not_installed("mda")
  skip_if_not_installed("mlbench")

  expect_snapshot(
    error = TRUE,
    {
      spec <- discrim_flexible(prod_degree = 0) %>%
        set_engine("earth") %>%
        set_mode("classification")
      fit(spec, factor ~ ., glass_tr)
    }
  )
  expect_snapshot(
    error = TRUE,
    {
      spec <- discrim_flexible(num_terms = 0) %>%
        set_engine("earth") %>%
        set_mode("classification")
      fit(spec, factor ~ ., glass_tr)
    }
  )

  expect_snapshot(
    error = TRUE,
    {
      spec <- discrim_flexible(prune_method = 2) %>%
        set_engine("earth") %>%
        set_mode("classification")
      fit(spec, factor ~ ., glass_tr)
    }
  )
})