Update descriptor tests

Author: DavisVaughan

tests/testthat/test_descriptors.R

@@ -2,109 +2,141 @@ library(testthat)
 context("descriptor variables")
 library(parsnip)
 
-template <- function(col, pred, ob, lev, fact)
-  list(cols = col, preds = pred, obs = ob, levs = lev, facts = fact)
+template <- function(col, pred, ob, lev, fact, dat, x, y) {
+  list(.n_cols = col, .n_preds = pred, .n_obs = ob,
+       .n_levs = lev, .n_facts = fact, .dat = dat, .x = x, .y = y)
+}
+
+eval_descrs <- function(descrs) {
+  lapply(descrs, do.call, list())
+}
 
 species_tab <- table(iris$Species, dnn = NULL)
 
 # ------------------------------------------------------------------------------
 
 context("Should descriptors be created?")
 
-test_that("make_descr", {
-  expect_false(parsnip:::make_descr(rand_forest()))
-  expect_false(parsnip:::make_descr(rand_forest(mtry = 3)))
-  expect_false(parsnip:::make_descr(rand_forest(mtry = varying())))
-  expect_true(parsnip:::make_descr(rand_forest(mtry = expr(..num))))
-  expect_false(parsnip:::make_descr(rand_forest(mtry = expr(3))))
-  expect_false(parsnip:::make_descr(rand_forest(mtry = quote(3))))
-  expect_true(parsnip:::make_descr(rand_forest(mtry = quote(..num))))
-
-  expect_false(parsnip:::make_descr(rand_forest(others = list(arrrg = 3))))
-  expect_false(parsnip:::make_descr(rand_forest(others = list(arrrg = varying()))))
-  expect_true(parsnip:::make_descr(rand_forest(others = list(arrrg = expr(..num)))))
-  expect_false(parsnip:::make_descr(rand_forest(others = list(arrrg = expr(3)))))
-  expect_false(parsnip:::make_descr(rand_forest(others = list(arrrg = quote(3)))))
-  expect_true(parsnip:::make_descr(rand_forest(others = list(arrrg = quote(..num)))))
+test_that("requires_descrs", {
+
+  # embedded in a function
+  fn <- function() {
+    .n_cols()
+  }
+
+  # doubly embedded
+  fn2 <- function() {
+    fn()
+  }
+
+  # core args
+  expect_false(requires_descrs(rand_forest()))
+  expect_false(requires_descrs(rand_forest(mtry = 3)))
+  expect_false(requires_descrs(rand_forest(mtry = varying())))
+  expect_true(requires_descrs(rand_forest(mtry = .n_cols())))
+  expect_false(requires_descrs(rand_forest(mtry = expr(3))))
+  expect_false(requires_descrs(rand_forest(mtry = quote(3))))
+  expect_true(requires_descrs(rand_forest(mtry = fn())))
+  expect_true(requires_descrs(rand_forest(mtry = fn2())))
+
+  # descriptors in `others`
+  expect_false(requires_descrs(rand_forest(arrrg = 3)))
+  expect_false(requires_descrs(rand_forest(arrrg = varying())))
+  expect_true(requires_descrs(rand_forest(arrrg = .n_obs())))
+  expect_false(requires_descrs(rand_forest(arrrg = expr(3))))
+  expect_true(requires_descrs(rand_forest(arrrg = fn())))
+  expect_true(requires_descrs(rand_forest(arrrg = fn2())))
+
+  # mixed
   expect_true(
-    parsnip:::make_descr(
+    requires_descrs(
       rand_forest(
         mtry = 3,
-        others = list(arrrg = quote(..num)))
+        arrrg = fn2())
     )
   )
+
   expect_true(
-    parsnip:::make_descr(
+    requires_descrs(
       rand_forest(
-        mtry = quote(..num),
-        others = list(arrrg = 3))
+        mtry = .n_cols(),
+        arrrg = 3)
     )
   )
 })
 
 
-
 # ------------------------------------------------------------------------------
 
 context("Testing formula -> xy conversion")
 
 test_that("numeric y and dummy vars", {
   expect_equal(
-    template(4, 5, 150, NA, 1),
-    parsnip:::get_descr_form(Sepal.Width ~ ., data = iris)
+    template(4, 5, 150, NA, 1, iris, iris[-2], iris[,"Sepal.Width"]),
+    eval_descrs(get_descr_form(Sepal.Width ~ ., data = iris))
   )
   expect_equal(
-    template(1, 2, 150, NA, 1),
-    parsnip:::get_descr_form(Sepal.Width ~ Species, data = iris)
+    template(1, 2, 150, NA, 1, iris, iris["Species"], iris[,"Sepal.Width"]),
+    eval_descrs(get_descr_form(Sepal.Width ~ Species, data = iris))
   )
 })
 
 test_that("numeric y and x", {
   expect_equal(
-    template(1, 1, 150, NA, 0),
-    parsnip:::get_descr_form(Sepal.Width ~ Sepal.Length, data = iris)
+    template(1, 1, 150, NA, 0, iris, iris["Sepal.Length"], iris[,"Sepal.Width"]),
+    eval_descrs(get_descr_form(Sepal.Width ~ Sepal.Length, data = iris))
   )
   expect_equal(
-    template(1, 1, 150, NA, 0),
-    parsnip:::get_descr_form(Sepal.Width ~ log(Sepal.Length), data = iris)
+    {
+      log_sep <- iris["Sepal.Length"]
+      log_sep[["Sepal.Length"]] <- log(log_sep[["Sepal.Length"]])
+      names(log_sep) <- "log(Sepal.Length)"
+      template(1, 1, 150, NA, 0, iris, log_sep, iris[,"Sepal.Width"])
+    },
+    eval_descrs(get_descr_form(Sepal.Width ~ log(Sepal.Length), data = iris))
   )
 })
 
 test_that("factor y", {
   expect_equal(
-    template(4, 4, 150, species_tab, 0),
-    parsnip:::get_descr_form(Species ~ ., data = iris)
+    template(4, 4, 150, species_tab, 0, iris, iris[-5], iris[,"Species"]),
+    eval_descrs(get_descr_form(Species ~ ., data = iris))
   )
   expect_equal(
-    template(1, 1, 150, species_tab, 0),
-    parsnip:::get_descr_form(Species ~ Sepal.Length, data = iris)
+    template(1, 1, 150, species_tab, 0, iris, iris["Sepal.Length"], iris[,"Species"]),
+    eval_descrs(get_descr_form(Species ~ Sepal.Length, data = iris))
   )
 })
 
 test_that("factors all the way down", {
+  dat <- npk[,1:4]
   expect_equal(
-    template(3, 7, 24, table(npk$K, dnn = NULL), 3),
-    parsnip:::get_descr_form(K ~ ., data = npk[,1:4])
+    template(3, 7, 24, table(npk$K, dnn = NULL), 3, dat, dat[-4], dat[,"K"]),
+    eval_descrs(get_descr_form(K ~ ., data = dat))
   )
 })
 
 test_that("weird cases", {
   # So model.frame ignores - signs in a model formula so Species is not removed
   # prior to model.matrix; otherwise this should have n_cols = 3
   expect_equal(
-    template(4, 3, 150, NA, 1),
-    parsnip:::get_descr_form(Sepal.Width ~ . - Species, data = iris)
+    template(4, 3, 150, NA, 1, iris, iris[-2], iris[,"Sepal.Width"]),
+    eval_descrs(get_descr_form(Sepal.Width ~ . - Species, data = iris))
   )
+
   # Oy ve! Before going to model.matrix, model.frame produces a data frame
   # with one column and that column is a matrix (with the results from
   # `poly(Sepal.Length, 3)`
+  x <- model.frame(~poly(Sepal.Length, 3), iris)
+  attributes(x) <- attributes(as.data.frame(x))[c("names", "class", "row.names")]
   expect_equal(
-    template(1, 3, 150, NA, 0),
-    parsnip:::get_descr_form(Sepal.Width ~ poly(Sepal.Length, 3), data = iris)
+    template(1, 3, 150, NA, 0, iris, x, iris[,"Sepal.Width"]),
+    eval_descrs(get_descr_form(Sepal.Width ~ poly(Sepal.Length, 3), data = iris))
   )
+
   expect_equal(
-    template(0, 0, 150, NA, 0),
-    parsnip:::get_descr_form(Sepal.Width ~ 1, data = iris)
+    template(0, 0, 150, NA, 0, iris, iris[,numeric()], iris[,"Sepal.Width"]),
+    eval_descrs(get_descr_form(Sepal.Width ~ 1, data = iris))
   )
 })
 
@@ -113,17 +145,24 @@ test_that("weird cases", {
 context("Testing xy -> formula conversion")
 
 test_that("numeric y and dummy vars", {
+  iris2 <- dplyr::rename(iris, ..y = Species)
+  rownames(iris2) <- rownames(iris2) # convert to char
   expect_equal(
-    template(4, 4, 150, species_tab, 0),
-    parsnip:::get_descr_xy(x = iris[, 1:4], y = iris$Species)
+    template(4, 4, 150, species_tab, 0, iris2, iris[, 1:4], iris$Species),
+    eval_descrs(get_descr_xy(x = iris[, 1:4], y = iris$Species))
   )
+
+  iris2 <- iris[,c(4,5,1,2)]
+  rownames(iris2) <- rownames(iris2)
   expect_equal(
-    template(2, 2, 150, NA, 1),
-    parsnip:::get_descr_xy(x = iris[, 4:5], y = iris[, 1:2])
+    template(2, 2, 150, NA, 1, iris2, iris[,4:5], iris[,1:2]),
+    eval_descrs(get_descr_xy(x = iris[, 4:5], y = iris[, 1:2]))
   )
+
+  iris3 <- iris2[,c("Petal.Width", "Species", "Sepal.Length")]
   expect_equal(
-    template(2, 2, 150, NA, 1),
-    parsnip:::get_descr_xy(x = iris[, 4:5], y = iris[, 1, drop = FALSE])
+    template(2, 2, 150, NA, 1, iris3, iris[, 4:5], iris[, 1, drop = FALSE]),
+    eval_descrs(get_descr_xy(x = iris[, 4:5], y = iris[, 1, drop = FALSE]))
   )
 })
 
@@ -147,27 +186,27 @@ test_that("spark descriptor", {
 
   expect_equal(
     template(4, 5, 150, NA, 1),
-    parsnip:::get_descr_form(Sepal_Width ~ ., data = iris_descr)
+    get_descr_form(Sepal_Width ~ ., data = iris_descr)
   )
   expect_equal(
     template(1, 2, 150, NA, 1),
-    parsnip:::get_descr_form(Sepal_Width ~ Species, data = iris_descr)
+    get_descr_form(Sepal_Width ~ Species, data = iris_descr)
   )
   expect_equal(
     template(1, 1, 150, NA, 0),
-    parsnip:::get_descr_form(Sepal_Width ~ Sepal_Length, data = iris_descr)
+    get_descr_form(Sepal_Width ~ Sepal_Length, data = iris_descr)
   )
   expect_equivalent(
     template(4, 4, 150, species_tab, 0),
-    parsnip:::get_descr_form(Species ~ ., data = iris_descr)
+    get_descr_form(Species ~ ., data = iris_descr)
   )
   expect_equal(
     template(1, 1, 150, species_tab, 0),
-    parsnip:::get_descr_form(Species ~ Sepal_Length, data = iris_descr)
+    get_descr_form(Species ~ Sepal_Length, data = iris_descr)
   )
   expect_equivalent(
     template(3, 7, 24, rev(table(npk$K, dnn = NULL)), 3),
-    parsnip:::get_descr_form(K ~ ., data = npk_descr)
+    get_descr_form(K ~ ., data = npk_descr)
   )
 
 })