tests/testthat/test-walsNB.R

In WALS: Weighted-Average Least Squares Model Averaging

test_that("walsNB estimation converges", {
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)

  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  nbWals <- walsNB(fWals, data = dd,
                   link = "log",
                   prior = weibull(), method = "fullSVD",
                   iterate = TRUE, tol = 1e-6,
                   verbose = TRUE)

  expect_true(nbWals$converged)
})

test_that("walsNB limiting nIt works and returns finite coefficients", {
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  # maximum value of L2 norm of coefficients
  # For NMES1988 dataset and given regressors, it should not exceed this value!
  limit <- 10

  # Check if limiting number of iteration works
  nbWals <- walsNB(fWals, data = dd,
                   link = "log",
                   prior = weibull(), method = "fullSVD",
                   iterate = TRUE, tol = 1e-6, nIt = 50,
                   verbose = TRUE)
  coefs <- coef(nbWals)
  coefsNorm <- norm(coefs, type = "2")

  # expect that L2 norm of coefficients is smaller than limit and finite
  expect_true(is.finite(coefsNorm))
  expect_true(coefsNorm < limit)

})

test_that("Different walsNB class methods yield same result", {
  tol <- 1e-8
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  nbWals <- walsNB(fWals, data = dd,
                   link = "log",
                   prior = weibull(), method = "fullSVD",
                   iterate = TRUE, tol = 1e-6,
                   verbose = TRUE, keepY = TRUE, keepX = TRUE)

  nbWalsMatrix <- walsNB(nbWals$x$focus, x2 = nbWals$x$aux, y = nbWals$y,
                         link = "log", prior = weibull(), method = "fullSVD",
                         iterate = TRUE, tol = 1e-6,
                         verbose = TRUE)

  nbWalsDefault <- walsNB.default(nbWals$x$focus, x2 = nbWals$x$aux,
                                  y = nbWals$y, link = "log", prior = weibull(),
                                  method = "fullSVD", iterate = TRUE, tol = 1e-6,
                                  verbose = TRUE)

  # check coefs
  expect_equal(coef(nbWals), coef(nbWalsMatrix), tolerance = tol)
  expect_equal(coef(nbWals), coef(nbWalsDefault), tolerance = tol)
})

test_that("walsNBmatrix predictions equal walsNB predictions", {
  tol <- 1e-8
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  nbWals <- walsNB(fWals, data = dd,
                   link = "log",
                   prior = weibull(), method = "fullSVD",
                   iterate = TRUE, tol = 1e-6,
                   verbose = TRUE, keepY = TRUE, keepX = TRUE)

  nbWalsMatrix <- walsNB(nbWals$x$focus, x2 = nbWals$x$aux, y = nbWals$y,
                         link = "log", prior = weibull(), method = "fullSVD",
                         iterate = TRUE, tol = 1e-6,
                         verbose = TRUE)

  # check predictions
  pred1 <- predict(nbWals, newdata = dd, type = "density")
  pred2 <- predict(nbWalsMatrix, newX1 = nbWals$x$focus, newX2 = nbWals$x$aux,
                   newY = nbWals$y, type = "density")

  expect_equal(pred1, pred2, tolerance = tol)
})

test_that("residuals of walsNB return correct values", {
  tol <- 1e-6
  data("NMES1988", package = "AER")
  NMES1988 <- na.omit(NMES1988)

  fitNB <- walsNB(visits ~ health + chronic + age + gender |
                    I((age^2)/10) + married + region,
                  data = NMES1988, prior = laplace(), verbose = TRUE)

  y <- NMES1988$visits
  mu <- predict(fitNB, newdata = NMES1988)
  rho <- fitNB$rho

  pearson <- (y - mu) / sqrt(mu + (mu^2)/rho)
  devres <- pmax(2 * (y*log(pmax(1, y)/mu) - (y + rho)*log((y + rho) / (mu + rho))), 0)
  devres <- sqrt(devres)
  devres <- ifelse(y - mu > 0, devres, -devres)
  resids <- y - mu

  expect_equal(pearson, residuals(fitNB, type = "pearson"), tolerance = tol)
  expect_equal(devres, residuals(fitNB, type = "deviance"), tolerance = tol)
  expect_equal(resids, residuals(fitNB, type = "response"), tolerance = tol)
})

test_that("Predictions use correct link values", {
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  fitFormula <- walsNB(fWals, data = dd, link = "log", prior = weibull(),
                       method = "fullSVD", keepY = TRUE, keepX = TRUE)
  linkFormula <- as.vector(model.matrix(fitFormula, "focus") %*% coef(fitFormula, "focus")
                           + model.matrix(fitFormula, "aux") %*% coef(fitFormula, "aux"))

  fitMatrix <- walsNB(fitFormula$x$focus, fitFormula$x$aux, fitFormula$y,
                      prior = weibull())
  linkMatrix <- as.vector(fitFormula$x$focus %*% coef(fitMatrix, "focus")
                          + fitFormula$x$aux %*% coef(fitMatrix, "aux"))

  expect_identical(linkFormula, as.vector(predict(fitFormula, newdata = dd,
                                                  type = "link")))
  expect_identical(linkMatrix, as.vector(predict(fitMatrix, newX1 = fitFormula$x$focus,
                                                 newX2 = fitFormula$x$aux, type = "link")))
})

test_that("Probability prediction works", {
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  nbWals <- walsNB(fWals, data = dd, link = "log",prior = weibull(),
                   method = "fullSVD")

  # expect no error in probability prediction.
  expect_error(predict(nbWals, newdata = dd, type = "prob"), regexp = NA)
})

test_that("Initialization with MASS::glm.nb runs", {
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  # expect no error in estimation.
  expect_error(walsNB(fWals, data = dd, link = "log",prior = weibull(),
                      method = "fullSVD", iterate = TRUE, tol = 1e-6,
                      verbose = TRUE, keepY = TRUE, keepX = TRUE,
                      controlInitNB = controlNB(initMASS = TRUE)),
               regexp = NA)

})

test_that("Initialization with restricted estimator", {
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  # expect no error in estimation.
  expect_error(walsNB(fWals, data = dd, link = "log",prior = weibull(),
                      method = "fullSVD", iterate = TRUE, tol = 1e-6,
                      verbose = TRUE, keepY = TRUE, keepX = TRUE,
                      controlInitNB = controlNB(initMASS = TRUE,
                                                restricted = TRUE)
                      ),
               regexp = NA)

  expect_error(walsNB(fWals, data = dd, link = "log",prior = weibull(),
                      method = "fullSVD", iterate = TRUE, tol = 1e-6,
                      verbose = TRUE, keepY = TRUE, keepX = TRUE,
                      controlInitNB = controlNB(initMASS = FALSE,
                                                restricted = TRUE)
                      ),
               regexp = NA)

  ## only constant as focus
  fWals <- (visits ~ 1 | health + chronic + age + I((age^2)/10) + insurance + medicaid +
              adl + region + gender + married + income + school + afam + employed)

  # expect no error in estimation.
  expect_error(walsNB(fWals, data = dd, link = "log",prior = weibull(),
                      method = "fullSVD", iterate = TRUE, tol = 1e-6,
                      verbose = TRUE, keepY = TRUE, keepX = TRUE,
                      controlInitNB = controlNB(initMASS = TRUE,
                                                restricted = TRUE)
  ),
  regexp = NA)

  expect_error(walsNB(fWals, data = dd, link = "log",prior = weibull(),
                      method = "fullSVD", iterate = TRUE, tol = 1e-6,
                      verbose = TRUE, keepY = TRUE, keepX = TRUE,
                      controlInitNB = controlNB(initMASS = FALSE,
                                                restricted = TRUE)
  ),
  regexp = NA)

})

test_that("Different methods for walsNB yield same results", {
  ## Check if estimated regression coefficients from different methods
  ## yield same results.
  tol <- 1e-06 # relative tolerance for deviations
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fWals <- (visits ~ health + chronic + age + I((age^2)/10) + insurance + medicaid |
              adl + region + gender + married + income + school + afam + employed)

  # Turn off iteration in all models as iterating WALS algo will magnify
  # small numerical differences between the methods.

  nbWalsfSVD <- walsNB(fWals, data = dd,
                       link = "log",
                       prior = weibull(), method = "fullSVD",
                       iterate = FALSE, tol = 1e-6,
                       verbose = TRUE, keepY = TRUE, keepX = TRUE)

  nbWalsOriginal <- walsNB(fWals, data = dd,
                          link = "log",
                          prior = weibull(), method = "original",
                          iterate = FALSE, tol = 1e-6,
                          verbose = TRUE, keepY = TRUE, keepX = TRUE)

  expect_equal(coef(nbWalsfSVD), coef(nbWalsOriginal), tolerance = tol)
})

test_that("One-part formula uses all variables as auxiliary regressors", {
  ## Check if y ~ x1 + x2 is the same as y ~ 1 | x1 + x2
  tol <- 1e-08 # relative tolerance for deviations
  data("NMES1988", package = "AER")
  dd <- na.omit(NMES1988)
  fOne <- visits ~ health + chronic + age + insurance + medicaid
  fTwo <- visits ~ 1 | health + chronic + age + insurance + medicaid

  nbOne <- walsNB(fOne, data = dd, link = "log", prior = laplace(),
                  method = "fullSVD")
  nbTwo <- walsNB(fTwo, data = dd, link = "log", prior = laplace(),
                  method = "fullSVD")

  expect_equal(coef(nbOne), coef(nbTwo), tolerance = tol)
})