tests/testthat/test-cubist.R

In tidyrules: Utilities to Retrieve Rulelists from Model Fits, Filter, Prune, Reorder and Predict on Unseen Data

################################################################################
# This is the part of the 'tidy' R package hosted at
# https://github.com/talegari/tidy with GPL-3 license.
################################################################################

context("test-cubist")

# setup some models ----
# attrition
data("attrition", package = "modeldata")
cols_att = setdiff(colnames(attrition), c("MonthlyIncome", "Attrition"))

cb_att =
  Cubist::cubist(x = attrition[, cols_att],
                 y = attrition[["MonthlyIncome"]]
                 )
tr_att = tidy(cb_att)

# attrition with commitees
cb_att_2 =
  Cubist::cubist(x = attrition[, cols_att],
                 y = attrition[["MonthlyIncome"]],
                 committees = 7
                 )
tr_att_2 = tidy(cb_att_2)

# ames housing
ames   = AmesHousing::make_ames()
cb_ames = Cubist::cubist(x = ames[, setdiff(colnames(ames), c("Sale_Price"))],
                          y = log10(ames[["Sale_Price"]]),
                          committees = 3
                          )
tr_ames = tidy(cb_ames)


# column name has a space in it
data("Boston", package = "MASS")
boston_2 = Boston
names(boston_2)[6] = "r m"
names(boston_2)[13] = "l stat"
cb_boston = Cubist::cubist(x = boston_2[, -14], y = boston_2[[14]])
tr_boston = tidy(cb_boston)

# function to check whether a rule is filterable
ruleFilterable = function(rule, data){
  dplyr::filter(data, eval(parse(text = rule)))
}

# function to check whether all rules are filterable
allRulesFilterable = function(tr, data){
  parse_status = sapply(
    tr[["LHS"]]
    , function(arule){
        trydf = try(ruleFilterable(arule, data)
                   , silent = TRUE
                   )
        if(nrow(trydf) == 0){
          #print(arule)
        }
        inherits(trydf, "data.frame") && (nrow(trydf) > 0)
      }
    )
  return(parse_status)
}

# evaluate RHS
evalRHS = function(tr, data){

  message(deparse(substitute(data)))

  with_RHS = sapply(tr[["RHS"]],
    function(x){
      try(data %>%
            dplyr::mutate(RHS_ = eval(parse(text = x))) %>%
            dplyr::pull(RHS_) %>%
            is.numeric()
        , silent = TRUE
      )}
    , USE.NAMES = FALSE
    )

  # print(which(!with_RHS))
  return(all(with_RHS))
}

# test output type ----

test_that("creates tibble", {
  expect_is(tr_att, "rulelist")
  expect_is(tr_att_2, "rulelist")
  expect_is(tr_ames, "rulelist")
  expect_is(tr_boston, "rulelist")
})

# test NA ----
test_that("Are NA present", {
  expect_false(anyNA(tr_att))
  expect_false(anyNA(tr_att_2))
  expect_false(anyNA(tr_ames))
  expect_false(anyNA(tr_boston))
})

# test parsable ----
test_that("rules are parsable", {
  expect_true(all(allRulesFilterable(tr_att, attrition)))
  expect_true(all(allRulesFilterable(tr_att_2, attrition)))
  expect_true(all(allRulesFilterable(tr_ames, ames)))
  expect_true(all(allRulesFilterable(tr_boston, boston_2)))
})

# rhs is computable ----
test_that("rhs is computable", {
  expect_true(evalRHS(tr_att, attrition))
  expect_true(evalRHS(tr_att_2, attrition))
  expect_true(evalRHS(tr_ames, ames))
  expect_true(evalRHS(tr_boston, boston_2))
})