tests/testthat/test-dufour_etal.R

In skedastic: Handling Heteroskedasticity in the Linear Regression Model

context("dufour_etal works for two lm examples across all hypothesis tests in package")

htest <- c("bamset", "breusch_pagan", "carapeto_holt", "cook_weisberg",
           "diblasi_bowman", "evans_king", "glejser",
           "goldfeld_quandt", "harvey", "honda", "horn",
           "li_yao", "rackauskas_zuokas", "simonoff_tsai",
           "szroeter", "verbyla", "white", "zhou_etal")

carslm <- lm(dist ~ speed, data = cars)
bostonlm <- lm(medv ~ crim + zn + indus + chas + nox + rm +
  age + dis + rad + tax + ptratio + b + lstat, data = BostonHousing)

# theargs <- formals(dufour_etal)


theargs <- lapply(1:length(htest), function(i) list("mainlm" = list(carslm, bostonlm)))

names(theargs) <- htest

# theargs$bickel$fitmethod <- c("lm", "rlm")
theargs$carapeto_holt$alternative <- c("greater", "less", "two.sided")
theargs$diblasi_bowman$distmethod <- c("moment.match", "bootstrap")
theargs$evans_king$method <- c("GLS", "LM")
theargs$goldfeld_quandt$alternative <- c("greater", "less", "two.sided")
theargs$honda$alternative <- c("greater", "less", "two.sided")
theargs$horn$restype <- c("ols", "blus")
theargs$horn$alternative <- c("greater", "less", "two.sided")
theargs$li_yao$method <- c("cvt", "alrt")
theargs$simonoff_tsai$method <- c("score")
theargs$zhou_etal$method <- c("pooled", "covariate-specific", "hybrid")

for (l in 1:length(theargs)) {
  theargs[[l]]$hettest <- names(theargs)[l]
}

allargs <- lapply(1:length(theargs), function(i) expand.grid(theargs[[i]],
                stringsAsFactors = FALSE))
names(allargs) <- names(theargs)

unlist(lapply(allargs, nrow))

allargs$zhou_etal <- allargs$zhou_etal[c(-4, -6), ]

# lapply(1:length(theargs), function(l)
#   test_that("linear regression works for dufour_etal with two regression models and each htest with method argument",
#   {pvals <- vapply(1:nrow(allargs[[l]]),
#     function(i) do.call(what = dufour_etal,
#              args = append(list("R" = 10L), unlist(allargs[[l]][i, ],
#                   recursive = FALSE)))$p.value, NA_real_)
#   lapply(pvals, function(p) expect_true(is.btwn01(p)))}))

lapply(1:length(theargs), function(l) {print(paste0("Test: ", names(allargs)[l]))
  test_that("dufour_etal with two regression models and each htest with method argument (normal errors)",
            {skip_on_cran()
              pvals <- vapply(1:nrow(allargs[[l]]),
            function(i) {print(paste0(i, " of ", nrow(allargs[[l]])))
            do.call(what = dufour_etal,
            args = append(list("R" = 10L), unlist(allargs[[l]][i, ],
            recursive = FALSE)))$p.value}, NA_real_)
            lapply(pvals, function(p) expect_true(is.btwn01(p)))}) } )


lapply(1:length(theargs), function(l) {print(paste0("Test: ", names(allargs)[l]))

  test_that("dufour_etal with two regression models and each htest with method argument (t errors)",
            {skip_on_cran()
            pvals <- vapply(1:nrow(allargs[[l]]),
            function(i) {print(paste0(i, " of ", nrow(allargs[[l]])))
            do.call(what = dufour_etal,
            args = append(list("R" = 10L, "errorgen" = stats::rt,
                    "errorparam" = list("df" = 3)), unlist(allargs[[l]][i, ],
            recursive = FALSE)))$p.value}, NA_real_)
            lapply(pvals, function(p) expect_true(is.btwn01(p)))}) } )


lapply(1:length(theargs), function(l) {print(paste0("Test: ", names(allargs)[l]))
  test_that("dufour_etal with two regression models and each htest with method argument (uniform errors)",
            {skip_on_cran()
            pvals <- vapply(1:nrow(allargs[[l]]),
            function(i) {print(paste0(i, " of ", nrow(allargs[[l]])))
            do.call(what = dufour_etal,
            args = append(list("R" = 10L, "errorgen" = stats::runif,
                    "errorparam" = list("min" = -1, "max" = 1)), unlist(allargs[[l]][i, ],
            recursive = FALSE)))$p.value}, NA_real_)
            lapply(pvals, function(p) expect_true(is.btwn01(p)))}) } )