tests/testthat/test-model-weights.R

In serp: Smooth Effects on Response Penalty for CLM

library(testthat)
library(serp)

context("check model weights and the errorMetrics function")
wine <- serp::wine

## checks on weight arguments
test_that("weight argument introduces no error",
          {
            expect_error(
              serp(rating ~ temp + contact, link = "logit",
                   slope = "parallel", reverse=FALSE, weights = c(rep(1,71), NA),
                   data = wine))
            expect_error(
              serp(rating ~ temp + contact, link = "logit",
                   slope = "parallel", reverse=FALSE, weights =  c(rep(1,71), -1),
                   data = wine))
            expect_error(
              serp(rating ~ temp + contact, link = "logit",
                   slope = "parallel", reverse=FALSE, weights = c(rep(1,71), 0.6),
                   weight.type = "frequency", data = wine))
            expect_vector(
              serp(rating ~ temp + contact, slope = "parallel",
                   link = "cloglog", reverse=TRUE, weights = rep(1, 72),
                   weight.type = "frequency", data = wine)$coef)
            expect_vector(
              serp(rating ~ temp + contact, slope = "parallel",
                   link = "cloglog", reverse=TRUE, weights = rep(0.1, 72),
                   weight.type = "analytic", data = wine)$coef)

            set.seed(1)
            n <- 30
            test_data <- data.frame(y= as.ordered(rbinom(n,5, 0.1)),
                                    x1=runif(n), x2=rexp(n))
            expect_error(
              serp(y ~ x1 + x2 ,
                   slope = "penalize",
                   link = "logit",
                   tuneMethod = "cv",
                   gridType = "discrete",
                   weights = runif(nrow(test_data)),
                   reverse = F,
                   data = test_data)
            )

            rm(test_data, n)
          })

## checks on trace and errorMeterics
test_that("trace and errorMeterics work properly",
          {
            ## check if trace works
            expect_output(serp(rating ~ temp + contact, link = "logit",
                               slope = "unparallel", reverse=FALSE,
                               control= list(trace=1),
                               data=wine, subset = c(1:30)))

            expect_output(serp(rating ~ temp + contact, link = "loglog",
                               slope = "penalize", reverse=TRUE,
                               gridType = "fine",
                               control= list(trace=2),
                               data=wine, subset = c(1:50)))
            expect_output(serp(rating ~ temp + contact, link = "cloglog",
                               slope = "partial", reverse=TRUE,
                               globalEff = ~ temp + contact,
                               control= list(trace=3),
                               data=wine, subset = c(1:30)))

            ## checks on errorMetrics
            f1 <- serp(rating ~ temp + contact, link = "logit",
                       slope = "parallel", reverse=FALSE,
                       data = wine)
            hh <- list()
            hh$minp <- 1e-02
            fv <- f1$fitted.values
            expect_error(
              serp:::errorMetrics(f1$model[,1L], fv[,-1L], control = hh,
                                  type = "brier"))
            expect_vector(serp:::errorMetrics(f1$model[,1L], fv, control = hh, type = "logloss"))
            expect_vector(serp:::errorMetrics(f1$model[,1L], fv, control = hh, type = "misclass"))

            set.seed(1)
            y <- sample(c(0,1), 50, replace = TRUE)
            mm <- glm(y ~ rnorm(50))
             expect_error(serp:::vcov.serp(mm))
})