tests/testthat/test_p.R

In smurf: Sparse Multi-Type Regularized Feature Modeling

context("Test p function for formula")


test_that("Test penalty name in p function", {
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "gglasso"), family = gaussian(), data = rent),
               "Invalid penalty name.")
})


test_that("Test factor errors in p function", {
  
  # Expect error since good is not a factor
  expect_error(glmsmurf(rentm ~ p(good, pen = "flasso"), 
                        family = gaussian(), data = rent),
               "Predictor 'good' needs to be given as a factor.")
  
  expect_error(glmsmurf(rentm ~ p(good, pen = "gflasso"), 
                        family = gaussian(), data = rent),
               "Predictor 'good' needs to be given as a factor.")
  
  expect_error(glmsmurf(rentm ~ p(good, pen = "ggflasso"), 
                        family = gaussian(), data = rent),
               "Predictor 'good' needs to be given as a factor.")
  
  # Expect error since warm2 is not a factor or numeric
  rent$warm2 <- as.character(rent$warm)
  expect_error(glmsmurf(rentm ~ p(warm2, pen = "none"), 
                        family = gaussian(), data = rent),
               "Predictor 'warm2' needs to be given as a factor or numeric.")
  
  expect_error(glmsmurf(rentm ~ p(warm2, pen = "lasso"), 
                        family = gaussian(), data = rent),
               "Predictor 'warm2' needs to be given as a factor or numeric.")
  
  expect_error(glmsmurf(rentm ~ p(warm2, pen = "grouplasso"), 
                        family = gaussian(), data = rent),
               "Predictor 'warm2' needs to be given as a factor or numeric.")
  
  # Test if warning for ordered
  rent$area2 <- ordered(rent$area)
  terms <- terms(rentm ~ p(area2, pen = "flasso"), specials = "p", data = rent)
  expect_warning(model.frame(formula = terms, data = rent, drop.unused.levels = TRUE),
                 "Predictor 'area2' is transformed from an ordered factor to a factor.")
})


test_that("Test 2D Fused Lasso in p function", {
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "2dflasso"), 
                        family = gaussian(), data = rent),
               "No second predictor is given for penalty type '2dflasso'.")
  
  expect_error(glmsmurf(rentm ~ p(area, year, pen = "flasso"), 
                        family = gaussian(), data = rent),
               "Two predictors are given, penalty type should be '2dflasso'.")
  
  rent$warm2 <- as.character(rent$warm)
  expect_error(glmsmurf(rentm ~ p(good, warm2, pen = "2dflasso"), 
                        family = gaussian(), data = rent),
               paste0("Predictors 'good' and 'warm2' in the interaction need to be given as factors."))
  
  expect_error(glmsmurf(rentm ~ p(area, warm2, pen = "2dflasso"), 
                        family = gaussian(), data = rent),
               paste0("Predictors 'area' and 'warm2' in the interaction need to be given as factors."))
  
  expect_error(glmsmurf(rentm ~ p(warm2, area, pen = "2dflasso"), 
                        family = gaussian(), data = rent),
               paste0("Predictors 'warm2' and 'area' in the interaction need to be given as factors."))
})


test_that("Test 'group' in p function", {
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "grouplasso", group = -1), 
                        family = gaussian(), data = rent),
               "'group' needs to be a strictly positive integer or NULL.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "grouplasso", group = 0), 
                        family = gaussian(), data = rent),
               "'group' needs to be a strictly positive integer or NULL.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "grouplasso", group = 0.5), 
                        family = gaussian(), data = rent),
               "'group' needs to be a strictly positive integer or NULL.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "grouplasso", group = 1:2), 
                        family = gaussian(), data = rent),
               "'group' needs to be a strictly positive integer of length 1 or NULL.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "grouplasso", group = NA), 
                        family = gaussian(), data = rent),
               "'group' needs to be a strictly positive integer of length 1 or NULL.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "grouplasso", group = NaN), 
                        family = gaussian(), data = rent),
               "'group' needs to be a strictly positive integer or NULL.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "grouplasso", group = Inf), 
                        family = gaussian(), data = rent),
               "'group' needs to be a strictly positive integer or NULL.",
               fixed = TRUE)
})


test_that("Test 'refcat' in p function", {
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "flasso", refcat = 1:2), 
                        family = gaussian(), data = rent),
               "The 'refcat' argument for the predictor 'area' should be NULL or have length 1.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "flasso", refcat = NA), 
                        family = gaussian(), data = rent),
               "'NA' is not a level of the predictor 'area'.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "flasso", refcat = NaN), 
                        family = gaussian(), data = rent),
               "'NaN' is not a level of the predictor 'area'.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "flasso", refcat = Inf), 
                        family = gaussian(), data = rent),
               "'Inf' is not a level of the predictor 'area'.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(area, pen = "flasso", refcat = 0), 
                        family = gaussian(), data = rent),
               "'0' is not a level of the predictor 'area'.",
               fixed = TRUE)
  
  terms <- terms(rentm ~ p(year, area, pen = "2dflasso", refcat = "1"), specials = "p", data = rent)
  expect_warning(model.frame(formula = terms, data = rent, drop.unused.levels = TRUE),
                 "The 'refcat' argument is ignored for 'pen = \"2dflasso\"'.")
  
  expect_error(glmsmurf(rentm ~ p(quality, pen = "flasso", refcat="good") + p(bathextra, pen = "flasso") +
                          p(quality, bathextra, pen = "2dflasso"), family = gaussian(), data = rent), 
               "The reference category for the predictor 'quality 'cannot be changed as it (or its binned version) is included in a 2D effect.",
               fixed = TRUE)
  
  expect_error(glmsmurf(rentm ~ p(quality, pen = "flasso") + p(bathextra, pen = "flasso", refcat="yes") +
                          p(quality, bathextra, pen = "2dflasso"), family = gaussian(), data = rent), 
               "The reference category for the predictor 'bathextra 'cannot be changed as it (or its binned version) is included in a 2D effect.",
               fixed = TRUE)
})