tests/testthat/test_preprocessing.R

In petersonR/sparseR: Variable Selection under Ranked Sparsity Principles for Interactions and Polynomials

context("Preprocessing Functionality")
skip_on_cran() # takes awhile, so only test on GitHub

data(iris)
iris <- iris[1:50,]

set.seed(123)

# Add another unbalanced factor
iris$Group <- factor(sample(c('A', 'B'), nrow(iris), replace = TRUE))

# Add a nzv variable
iris$NotUseful <- 2

# Add a binary variable
iris$BV <- rbinom(nrow(iris), 1, prob = .5)

# Add an unbalanced binary variable
iris$UBV <- rbinom(nrow(iris), 1, prob = .02)

# Add missing continuous data
iris$Sepal.Length[5] <- NA

# Add missing factor data
iris$Group[2] <- NA

# Add missing binary data
iris$BV[12] <- NA

test_that("Different vals of k and poly work, general formula", {
  expect_silent({
    obj1 <- sparseR_prep(Sepal.Width ~ ., data = iris)
  })
  expect_silent({
    obj2 <- sparseR_prep(Sepal.Width ~ ., data = iris, k = 2, poly = 2)
  })
  expect_silent({
    obj3 <- sparseR_prep(Sepal.Width ~ ., data = iris, k = 1, poly = 1)
  })
  expect_silent({
    obj4 <- sparseR_prep(Sepal.Width ~ ., data = iris, k = 0, poly = 2)
  })
  expect_silent({
    obj5 <- sparseR_prep(Sepal.Width ~ ., data = iris, k = 5, poly = 5)
  })

  expect_error(sparseR_prep(Sepal.Width ~ ., data = iris, k = 1, poly = 0))
  expect_error(sparseR_prep(Sepal.Width ~ ., data = iris, k = 1, poly = NULL))
  expect_error(sparseR_prep(Sepal.Width ~ ., data = iris, k = 1, poly = 0))
  expect_error(sparseR_prep(Sepal.Width ~ ., data = iris, k = NULL, poly = NULL))

})

test_that("Different vals of k and poly work, specific formulae", {

  formula <- Sepal.Width ~ Petal.Width + BV + Petal.Length + Group
  expect_silent({
    obj1 <- sparseR_prep(formula, data = iris)
    obj2 <- sparseR_prep(formula, data = iris, k = 2, poly = 2)
    obj3 <- sparseR_prep(formula, data = iris, k = 1, poly = 1)
    obj4 <- sparseR_prep(formula, data = iris, k = 0, poly = 2)
    obj5 <- sparseR_prep(formula, data = iris, k = 5, poly = 5)
  })

  formula <- Sepal.Width ~ BV + UBV + Group
  expect_silent({
    obj1 <- sparseR_prep(formula, data = iris)
    obj2 <- sparseR_prep(formula, data = iris, k = 2, poly = 2)
    obj3 <- sparseR_prep(formula, data = iris, k = 1, poly = 1)
    obj4 <- sparseR_prep(formula, data = iris, k = 0, poly = 2)
    obj5 <- sparseR_prep(formula, data = iris, k = 5, poly = 5)
  })

  formula <- Sepal.Width ~ BV + UBV
  expect_warning({
    obj1 <- sparseR_prep(formula, data = iris)
    obj2 <- sparseR_prep(formula, data = iris, k = 2, poly = 2)
    obj3 <- sparseR_prep(formula, data = iris, k = 1, poly = 1)
    obj4 <- sparseR_prep(formula, data = iris, k = 0, poly = 2)
    obj5 <- sparseR_prep(formula, data = iris, k = 5, poly = 5)
  })

  expect_error(sparseR_prep(formula, data = iris, k = 1, poly = 0))
  expect_error(sparseR_prep(formula, data = iris, k = 1, poly = NULL))
  expect_error(sparseR_prep(formula, data = iris, k = .5, poly = 1))
  expect_error(sparseR_prep(formula, data = iris, k = NULL, poly = NULL))

})

## Test Detrano use-case

data("Detrano")
# smaller data set
cleveland <- cleveland[1:50,]

cleveland$thal <- factor(cleveland$thal)
cleveland$case <- 1*(cleveland$num > 0)

# Convert variables into factor variables if necessary!
cleveland$sex <- factor(cleveland$sex)
cleveland$fbs <- factor(cleveland$fbs)
cleveland$exang <- factor(cleveland$exang)

# Simulate missing data
cleveland$thal[2] <- cleveland$thalach[1] <- NA


test_that("Different vals of k and poly work, cleveland", {
  expect_silent({
    obj1 <- sparseR_prep(case ~ ., data = cleveland)
  })
  expect_silent({
    obj2 <- sparseR_prep(case ~ ., data = cleveland, k = 2, poly = 2)
  })
  expect_silent({
    obj3 <- sparseR_prep(case ~ ., data = cleveland, k = 1, poly = 1)
  })
  expect_silent({
    obj4 <- sparseR_prep(case ~ ., data = cleveland, k = 0, poly = 2)
  })


  expect_error(sparseR_prep(case ~ ., data = cleveland, k = 1, poly = 0))
  expect_error(sparseR_prep(case ~ ., data = cleveland, k = 1, poly = NULL))
  expect_error(sparseR_prep(case ~ ., data = cleveland, k = 1, poly = 0))
  expect_error(sparseR_prep(case ~ ., data = cleveland, k = NULL, poly = NULL))

})

test_that("Different vals of k and poly work, specific formulae", {

  formula <- case ~ trestbps + cp + thalach + thal
  expect_silent({
    obj1 <- sparseR_prep(formula, data = cleveland)
    obj2 <- sparseR_prep(formula, data = cleveland, k = 2, poly = 2)
    obj3 <- sparseR_prep(formula, data = cleveland, k = 1, poly = 1)
    obj4 <- sparseR_prep(formula, data = cleveland, k = 0, poly = 2)
    obj5 <- sparseR_prep(formula, data = cleveland, k = 5, poly = 5)
  })

  formula <- case ~ thal + num + chol
  expect_silent({
    obj1 <- sparseR_prep(formula, data = cleveland)
    obj2 <- sparseR_prep(formula, data = cleveland, k = 2, poly = 2)
    obj3 <- sparseR_prep(formula, data = cleveland, k = 1, poly = 1)
    obj4 <- sparseR_prep(formula, data = cleveland, k = 0, poly = 2)
    obj5 <- sparseR_prep(formula, data = cleveland, k = 5, poly = 5)
  })

  formula <- case ~ sex + thal
  expect_silent({
    obj1 <- sparseR_prep(formula, data = cleveland)
    obj2 <- sparseR_prep(formula, data = cleveland, k = 2, poly = 2)
    obj3 <- sparseR_prep(formula, data = cleveland, k = 1, poly = 1)
    obj4 <- sparseR_prep(formula, data = cleveland, k = 0, poly = 2)
    obj5 <- sparseR_prep(formula, data = cleveland, k = 5, poly = 5)
  })

  expect_error(sparseR_prep(formula, data = cleveland, k = 1, poly = 0))
  expect_error(sparseR_prep(formula, data = cleveland, k = 1, poly = NULL))
  expect_error(sparseR_prep(formula, data = cleveland, k = .5, poly = 1))
  expect_error(sparseR_prep(formula, data = cleveland, k = NULL, poly = NULL))

})

test_that("Centering to minimum works", {
  cc <- iris %>%
    dplyr::select(Sepal.Length, Petal.Length, Petal.Width) %>%
    apply(2, min, na.rm = TRUE)

  p1 <- sparseR_prep(Sepal.Width ~ ., iris, k = 0, extra_opts = list(centers = cc))
  c2min <- bake(p1, iris)
  p2 <- sparseR_prep(Sepal.Width ~ ., iris, k = 0, extra_opts = list(center_fn = min))
  c2min2 <- bake(p2, iris)
  expect_identical(c2min2, c2min)

  # testing print + tidy methods for center_to
  expect_output(print(p2$steps[[3]]))
  expect_silent(t1 <- tidy(p2$steps[[3]]))
})