diff --git a/.github/workflows/R-CMD-check-hard.yaml b/.github/workflows/R-CMD-check-hard.yaml new file mode 100644 index 0000000..ac3bc0f --- /dev/null +++ b/.github/workflows/R-CMD-check-hard.yaml @@ -0,0 +1,59 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +# +# NOTE: This workflow only directly installs "hard" dependencies, i.e. Depends, +# Imports, and LinkingTo dependencies. Notably, Suggests dependencies are never +# installed, with the exception of testthat, knitr, and rmarkdown. The cache is +# never used to avoid accidentally restoring a cache containing a suggested +# dependency. +on: + push: + branches: [main, master] + pull_request: + +name: R-CMD-check-hard.yaml + +permissions: read-all + +jobs: + check-no-suggests: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: ubuntu-latest, r: 'release'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + dependencies: '"hard"' + cache: false + extra-packages: | + any::rcmdcheck + any::testthat + any::knitr + any::rmarkdown + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/DESCRIPTION b/DESCRIPTION index a2c1fc2..bff79c6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -4,9 +4,9 @@ Version: 1.0.1.9000 Authors@R: c( person("Emil", "Hvitfeldt", , "emil.hvitfeldt@posit.co", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-0679-1945")), - person("Max", "Kuhn", , "max@posit.co", role = c("aut"), + person("Max", "Kuhn", , "max@posit.co", role = "aut", comment = c(ORCID = "0000-0003-2402-136X")), - person(given = "Posit Software, PBC", role = c("cph", "fnd")) + person("Posit Software, PBC", role = c("cph", "fnd")) ) Description: Bindings for additional classification models for use with the 'parsnip' package. Models include flavors of discriminant @@ -34,6 +34,7 @@ Suggests: dplyr, earth, ggplot2, + hardhat, klaR, knitr, MASS, @@ -47,12 +48,10 @@ Suggests: spelling, testthat (>= 3.0.0), xml2 -Config/Needs/website: - tidymodels/tidymodels, - tidyverse/tidytemplate +Config/Needs/website: tidymodels/tidymodels, tidyverse/tidytemplate +Config/testthat/edition: 3 Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 -Config/testthat/edition: 3 diff --git a/R/data.R b/R/data.R index 77ee055..f6c5339 100644 --- a/R/data.R +++ b/R/data.R @@ -10,11 +10,13 @@ #' #' @keywords datasets #' @examples -#' data(parabolic) +#' if (rlang::is_installed("ggplot2")) { +#' data(parabolic) #' -#' library(ggplot2) -#' ggplot(parabolic, aes(x = X1, y = X2, col = class)) + -#' geom_point(alpha = .5) + -#' theme_bw() +#' library(ggplot2) +#' ggplot(parabolic, aes(x = X1, y = X2, col = class)) + +#' geom_point(alpha = .5) + +#' theme_bw() +#' } #' NULL diff --git a/inst/WORDLIST b/inst/WORDLIST index de045d7..a0103ad 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,43 +1,26 @@ -al +Ahdesmaki Buja +CMD Codecov -doi -et Hastie -klaR Lifecycle -mda -nonlinearly -param -pre +ORCID +PBC QDA -quant +RStudio +Strimmer Tibshirani Yu -cov -fL -frac -laplace +doi +funder +klaR +mda +modeldata naivebayes -nprune -num -pmethod +param psock -Ahdesmaki -Strimmer +quant +reprex +sda sparsediscrim -Bioinformatics -Biometrics -Dudoit -Fridlyand -Kubokawa -Springer -Srivistava -Zhao -backward' -diagonal' -naivebayes -ORCID -modeldata tidymodels -funder diff --git a/man/parabolic.Rd b/man/parabolic.Rd index e7e80c8..5ab504b 100644 --- a/man/parabolic.Rd +++ b/man/parabolic.Rd @@ -15,12 +15,14 @@ These data were simulated. There are two correlated predictors and two classes in the factor outcome. } \examples{ -data(parabolic) +if (rlang::is_installed("ggplot2")) { + data(parabolic) -library(ggplot2) -ggplot(parabolic, aes(x = X1, y = X2, col = class)) + - geom_point(alpha = .5) + - theme_bw() + library(ggplot2) + ggplot(parabolic, aes(x = X1, y = X2, col = class)) + + geom_point(alpha = .5) + + theme_bw() +} } \keyword{datasets} diff --git a/tests/testthat/_snaps/flexible.md b/tests/testthat/_snaps/flexible.md deleted file mode 100644 index c7b4138..0000000 --- a/tests/testthat/_snaps/flexible.md +++ /dev/null @@ -1,30 +0,0 @@ -# check_args() works - - Code - spec <- discrim_flexible(prod_degree = 0) %>% set_engine("earth") %>% set_mode( - "classification") - fit(spec, factor ~ ., glass_tr) - Condition - Error in `fit()`: - ! `prod_degree` must be a whole number larger than or equal to 1 or `NULL`, not the number 0. - ---- - - Code - spec <- discrim_flexible(num_terms = 0) %>% set_engine("earth") %>% set_mode( - "classification") - fit(spec, factor ~ ., glass_tr) - Condition - Error in `fit()`: - ! `num_terms` must be a whole number larger than or equal to 1 or `NULL`, not the number 0. - ---- - - Code - spec <- discrim_flexible(prune_method = 2) %>% set_engine("earth") %>% set_mode( - "classification") - fit(spec, factor ~ ., glass_tr) - Condition - Error in `fit()`: - ! `prune_method` must be a single string or `NULL`, not the number 2. - diff --git a/tests/testthat/_snaps/linear-lda.md b/tests/testthat/_snaps/linear-lda.md index e3b252e..d21cd28 100644 --- a/tests/testthat/_snaps/linear-lda.md +++ b/tests/testthat/_snaps/linear-lda.md @@ -1,4 +1,4 @@ -# missing data +# MASS::lda missing data Code f_pred <- predict(f_fit, glass_na, type = "prob") @@ -11,7 +11,7 @@ --- Code - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_na)$posterior) + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_lda, glass_na)$posterior) Condition Warning in `FUN()`: no non-missing arguments to min; returning Inf diff --git a/tests/testthat/_snaps/linear-sparsediscrim.md b/tests/testthat/_snaps/linear-sparsediscrim.md index a79ded6..d59b034 100644 --- a/tests/testthat/_snaps/linear-sparsediscrim.md +++ b/tests/testthat/_snaps/linear-sparsediscrim.md @@ -1,4 +1,4 @@ -# lda_emp_bayes_eigen fit and prediction +# sparsediscrim lda_emp_bayes_eigen fit and prediction 'method' should be one of: 'diagonal', 'min_distance', 'shrink_cov', 'shrink_mean' diff --git a/tests/testthat/_snaps/naive-Bayes.md b/tests/testthat/_snaps/naive-Bayes.md deleted file mode 100644 index cfc5482..0000000 --- a/tests/testthat/_snaps/naive-Bayes.md +++ /dev/null @@ -1,13 +0,0 @@ -# printing - - Code - print(nb_spec) - Output - Naive Bayes Model Specification (classification) - - Main Arguments: - smoothness = 1.2 - - Computational engine: klaR - - diff --git a/tests/testthat/_snaps/naive-Bayes_naivebayes.md b/tests/testthat/_snaps/naive-Bayes_naivebayes.md deleted file mode 100644 index d19ac2e..0000000 --- a/tests/testthat/_snaps/naive-Bayes_naivebayes.md +++ /dev/null @@ -1,13 +0,0 @@ -# printing - - Code - print(nb_spec) - Output - Naive Bayes Model Specification (classification) - - Main Arguments: - smoothness = 1.2 - - Computational engine: naivebayes - - diff --git a/tests/testthat/_snaps/quad-qda.md b/tests/testthat/_snaps/quad-qda.md index 797f4a3..7433ac8 100644 --- a/tests/testthat/_snaps/quad-qda.md +++ b/tests/testthat/_snaps/quad-qda.md @@ -1,4 +1,4 @@ -# missing data +# MASS::qda missing data Code f_pred <- predict(f_fit, penguins_miss, type = "prob") @@ -28,29 +28,5 @@ --- - Code - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, penguins_miss)$posterior) - Condition - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf - Warning in `FUN()`: - no non-missing arguments to min; returning Inf + no non-missing arguments to min; returning Inf diff --git a/tests/testthat/_snaps/rda.md b/tests/testthat/_snaps/rda.md index 9f1fdbc..c78bea0 100644 --- a/tests/testthat/_snaps/rda.md +++ b/tests/testthat/_snaps/rda.md @@ -1,4 +1,4 @@ -# printing +# klaR::rda printing Code print(rda_spec) diff --git a/tests/testthat/helper-objects.R b/tests/testthat/helper-objects.R index 4e69cba..30ce4c7 100644 --- a/tests/testthat/helper-objects.R +++ b/tests/testthat/helper-objects.R @@ -1,20 +1,107 @@ -library(mlbench) -data(Glass) -set.seed(55822) -in_samp <- sample.int(nrow(Glass), 5) +# ------------------------------------------------------------------------------ +# Glass data + +if (rlang::is_installed("mlbench")) { + library(mlbench) + data(Glass, package = "mlbench") + + set.seed(55822) + in_samp <- sample.int(nrow(Glass), 5) -# Add a random factor predictor to test dummy variables -Glass$factor <- factor(sample(letters[1:4], nrow(Glass), replace = TRUE)) + # Add a random factor predictor to test dummy variables + Glass$factor <- factor(sample(letters[1:4], nrow(Glass), replace = TRUE)) -glass_tr <- Glass[-in_samp, ] -glass_te <- Glass[in_samp, -10] -glass_na <- glass_te -glass_na$RI[1] <- NA -glass_na$Na[2] <- NA + glass_tr <- Glass[-in_samp, ] + glass_te <- Glass[in_samp, -10] + glass_na <- glass_te + glass_na$RI[1] <- NA + glass_na$Na[2] <- NA + + glass_lvl <- levels(Glass$Type) + glass_prob_names <- paste0(".pred_", glass_lvl) + + wts <- ifelse(runif(nrow(glass_tr)) < .1, 0, 1) + wts <- hardhat::importance_weights(wts) +} + +# ------------------------------------------------------------------------------ +# Penguin data + +if (rlang::is_installed("modeldata")) { + data(penguins, package = "modeldata") + penguins$island <- NULL + penguins_miss <- penguins + penguins <- na.omit(penguins) + in_train <- seq(1, nrow(penguins), by = 2) + penguin_tr <- penguins[in_train, ] + penguin_te <- penguins[-in_train, ] + + pen_prob_names <- c(".pred_Adelie", ".pred_Chinstrap", ".pred_Gentoo") +} + +# ------------------------------------------------------------------------------ +# LDA/QDA fits + +if (rlang::is_installed(c("mlbench", "MASS"))) { + + lda_spec <- discrim_linear() %>% set_engine("MASS") + prior_spec_lda <- discrim_linear() %>% set_engine("MASS", prior = rep(1/6, 6)) + + exp_f_fit_lda <- MASS::lda(Type ~ ., data = glass_tr) + exp_xy_fit_lda <- MASS::lda(x = glass_tr[,-10], grouping = glass_tr$Type) + exp_prior_fit_lda <- MASS::lda(Type ~ ., data = glass_tr, prior = rep(1/6, 6)) + + ### + + qda_spec <- discrim_quad() %>% set_engine("MASS") + prior_spec_qda <- discrim_quad() %>% set_engine("MASS", prior = rep(1 / 3, 3)) + + exp_f_fit_qda <- MASS::qda(species ~ ., data = penguin_tr) + exp_xy_fit_qda <- MASS::qda(x = penguin_tr[, -1], grouping = penguin_tr$species) + exp_prior_fit_qda <- MASS::qda(species ~ ., data = penguin_tr, prior = rep(1 / 3, 3)) + +} -glass_lvl <- levels(Glass$Type) -prob_names <- paste0(".pred_", glass_lvl) +# ------------------------------------------------------------------------------ +# RDA fits + +if (rlang::is_installed(c("mlbench", "klaR"))) { + + rda_spec <- + discrim_regularized(frac_common_cov = .1, frac_identity = 1) %>% + set_engine("klaR") + + prior_spec_rda <- discrim_regularized() %>% set_engine("klaR", prior = rep(1 / 6, 6)) + + exp_f_fit_rda <- klaR::rda(Type ~ ., data = glass_tr, lambda = .1, gamma = 1) + +} + + +# ------------------------------------------------------------------------------ +# FDA fits + +if (rlang::is_installed(c("mlbench", "mda", "earth"))) { + + fda_spec <- discrim_flexible(num_terms = 7) %>% set_engine("earth") + + exp_f_fit_fda <- mda::fda(Type ~ ., data = glass_tr, method = earth::earth, nprune = 7) + + exp_f_wts_fit_fda <- mda::fda(Type ~ ., data = glass_tr, weights = as.double(wts), + method = earth::earth, nprune = 7) +} + +if (rlang::is_installed(c("mlbench", "mda"))) { + + lda_fda_spec <- discrim_linear(penalty = 1) %>% set_engine("mda") + prior_lda_fda_spec <- discrim_linear() %>% set_engine("mda", prior = rep(1/6, 6)) + + exp_f_fit_lda_fda <- mda::fda(Type ~ ., data = glass_tr, method = mda::gen.ridge, lambda = 1) + + exp_f_wts_fit_lda_fda <- mda::fda(Type ~ ., data = glass_tr, weights = as.double(wts), + method = mda::gen.ridge, lambda = 1) +} # ------------------------------------------------------------------------------ diff --git a/tests/testthat/test-flexible.R b/tests/testthat/test-flexible-earth.R similarity index 58% rename from tests/testthat/test-flexible.R rename to tests/testthat/test-flexible-earth.R index d6b2399..443a905 100644 --- a/tests/testthat/test-flexible.R +++ b/tests/testthat/test-flexible-earth.R @@ -1,55 +1,52 @@ -fda_spec <- discrim_flexible(num_terms = 7) %>% set_engine("earth") - -exp_f_fit <- mda::fda(Type ~ ., data = glass_tr, method = earth::earth, nprune = 7) - -wts <- ifelse(runif(nrow(glass_tr)) < .1, 0, 1) -wts <- importance_weights(wts) - -exp_f_wts_fit <- mda::fda(Type ~ ., data = glass_tr, weights = as.double(wts), - method = earth::earth, nprune = 7) - -# ------------------------------------------------------------------------------ - -test_that("model object", { +test_that("mda::fda/earth model object", { + skip_if_not_installed("mda") + skip_if_not_installed("earth") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R # formula method expect_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr), NA) - expect_equal(f_fit$fit$theta.mod, exp_f_fit$theta.mod) - expect_equal(f_fit$fit$fit$cuts, exp_f_fit$fit$cuts) + expect_equal(f_fit$fit$theta.mod, exp_f_fit_fda$theta.mod) + expect_equal(f_fit$fit$fit$cuts, exp_f_fit_fda$fit$cuts) expect_error( f_wts_fit <- fit(fda_spec, Type ~ ., case_weights = wts, data = glass_tr), NA ) - expect_equal(f_wts_fit$fit$theta.mod, exp_f_wts_fit$theta.mod) - expect_equal(f_wts_fit$fit$fit$cuts, exp_f_wts_fit$fit$cuts) + expect_equal(f_wts_fit$fit$theta.mod, exp_f_wts_fit_fda$theta.mod) + expect_equal(f_wts_fit$fit$fit$cuts, exp_f_wts_fit_fda$fit$cuts) # x/y method expect_error( xy_fit <- fit_xy(fda_spec, x = glass_tr[, -10], y = glass_tr$Type), NA ) - expect_equal(xy_fit$fit$theta.mod, exp_f_fit$theta.mod) - expect_equal(xy_fit$fit$fit$cuts, exp_f_fit$fit$cuts) + expect_equal(xy_fit$fit$theta.mod, exp_f_fit_fda$theta.mod) + expect_equal(xy_fit$fit$fit$cuts, exp_f_fit_fda$fit$cuts) expect_error( xy_wts_fit <- fit_xy(fda_spec, x = glass_tr[, -10], y = glass_tr$Type, - case_weights = wts), + case_weights = wts), NA ) - expect_equal(xy_wts_fit$fit$theta.mod, exp_f_wts_fit$theta.mod) - expect_equal(xy_wts_fit$fit$fit$cuts, exp_f_wts_fit$fit$cuts) + expect_equal(xy_wts_fit$fit$theta.mod, exp_f_wts_fit_fda$theta.mod) + expect_equal(xy_wts_fit$fit$fit$cuts, exp_f_wts_fit_fda$fit$cuts) }) # ------------------------------------------------------------------------------ -test_that("class predictions", { +test_that("mda::fda/earth class predictions", { + skip_if_not_installed("mda") + skip_if_not_installed("earth") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te) - exp_f_pred <- predict(exp_f_fit, glass_te) + exp_f_pred <- predict(exp_f_fit_fda, glass_te) expect_true(inherits(f_pred, "tbl_df")) expect_true(all(names(f_pred) == ".pred_class")) @@ -72,14 +69,19 @@ test_that("class predictions", { # ------------------------------------------------------------------------------ -test_that("prob predictions", { +test_that("mda::fda/earth prob predictions", { + skip_if_not_installed("mda") + skip_if_not_installed("earth") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te, type = "prob") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_te, type = "posterior")) + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_fda, glass_te, type = "posterior")) expect_true(inherits(f_pred, "tbl_df")) - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), glass_prob_names) expect_equal(f_pred, exp_f_pred) # x/y method @@ -89,54 +91,55 @@ test_that("prob predictions", { ) xy_pred <- predict(xy_fit, glass_te, type = "prob") expect_true(inherits(xy_pred, "tbl_df")) - expect_equal(names(xy_pred), prob_names) + expect_equal(names(xy_pred), glass_prob_names) expect_equal(xy_pred, exp_f_pred) }) # ------------------------------------------------------------------------------ -test_that("missing data", { +test_that("mda::fda/earth missing data", { + skip_if_not_installed("mda") + skip_if_not_installed("earth") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + expect_error(f_fit <- fit(fda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_na, type = "prob") opt <- getOption("na.action") options(na.action = "na.pass") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_na, type = "posterior")) + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_fda, glass_na, type = "posterior")) options(na.action = opt) expect_true(inherits(f_pred, "tbl_df")) expect_true(nrow(f_pred) == nrow(glass_te)) - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), glass_prob_names) expect_equal(f_pred, exp_f_pred) }) # ------------------------------------------------------------------------------ -test_that("printing", { - expect_output( - print(fda_spec), - "Flexible Discriminant Model Specification" - ) -}) - - -# ------------------------------------------------------------------------------ +test_that("mda::fda/earth updating", { + skip_if_not_installed("earth") + skip_if_not_installed("mda") + skip_if_not_installed("mlbench") -test_that("updating", { fda_spec_2 <- discrim_flexible(num_terms = 6) %>% set_engine("earth") fda_spec_3 <- update(fda_spec, num_terms = 6) expect_equal(fda_spec_2, fda_spec_3) }) -test_that('check_args() works', { +test_that('mda::fda/earth check_args() works', { skip_if_not_installed("earth") skip_if_not_installed("parsnip", "1.2.1.9001") + skip_if_not_installed("mda") + skip_if_not_installed("mlbench") expect_snapshot( error = TRUE, { - spec <- discrim_flexible(prod_degree = 0) %>% + spec <- discrim_flexible(prod_degree = 0) %>% set_engine("earth") %>% set_mode("classification") fit(spec, factor ~ ., glass_tr) @@ -145,7 +148,7 @@ test_that('check_args() works', { expect_snapshot( error = TRUE, { - spec <- discrim_flexible(num_terms = 0) %>% + spec <- discrim_flexible(num_terms = 0) %>% set_engine("earth") %>% set_mode("classification") fit(spec, factor ~ ., glass_tr) @@ -155,7 +158,7 @@ test_that('check_args() works', { expect_snapshot( error = TRUE, { - spec <- discrim_flexible(prune_method = 2) %>% + spec <- discrim_flexible(prune_method = 2) %>% set_engine("earth") %>% set_mode("classification") fit(spec, factor ~ ., glass_tr) diff --git a/tests/testthat/test-linear-fda.R b/tests/testthat/test-linear-fda.R deleted file mode 100644 index 4c856a8..0000000 --- a/tests/testthat/test-linear-fda.R +++ /dev/null @@ -1,140 +0,0 @@ -lda_spec <- discrim_linear(penalty = 1) %>% set_engine("mda") -prior_spec <- discrim_linear() %>% set_engine("mda", prior = rep(1/6, 6)) - -exp_f_fit <- mda::fda(Type ~ ., data = glass_tr, method = mda::gen.ridge, lambda = 1) - -wts <- ifelse(runif(nrow(glass_tr)) < .1, 0, 1) -wts <- importance_weights(wts) - -exp_f_wts_fit <- mda::fda(Type ~ ., data = glass_tr, weights = as.double(wts), - method = mda::gen.ridge, lambda = 1) - -# ------------------------------------------------------------------------------ - -test_that('model object', { - - # formula method - expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) - expect_equal(f_fit$fit$theta.mod, exp_f_fit$theta.mod) - expect_equal(f_fit$fit$fit$coefficients, exp_f_fit$fit$coefficients) - - expect_error( - f_wts_fit <- fit(lda_spec, Type ~ ., data = glass_tr, case_weights = wts), - NA - ) - expect_equal(f_wts_fit$fit$theta.mod, exp_f_wts_fit$theta.mod) - expect_equal(f_wts_fit$fit$fit$coefficients, exp_f_wts_fit$fit$coefficients) - - # x/y method - expect_error( - xy_fit <- fit_xy(lda_spec, x = glass_tr[,-10], y = glass_tr$Type), - NA - ) - expect_equal(xy_fit$fit$theta.mod, exp_f_fit$theta.mod) - expect_equal(xy_fit$fit$fit$coefficients, exp_f_fit$fit$coefficients) - - expect_error( - xy_wts_fit <- fit_xy(lda_spec, x = glass_tr[,-10], y = glass_tr$Type, - case_weights = wts), - NA - ) - expect_equal(xy_wts_fit$fit$theta.mod, exp_f_wts_fit$theta.mod) - expect_equal(xy_wts_fit$fit$fit$coefficients, exp_f_wts_fit$fit$coefficients) - -}) - -# ------------------------------------------------------------------------------ - - -test_that('class predictions', { - # formula method - expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) - f_pred <- predict(f_fit, glass_te) - exp_f_pred <- predict(exp_f_fit, glass_te) - - expect_true(inherits(f_pred, "tbl_df")) - expect_true(all(names(f_pred) == ".pred_class")) - expect_equal(f_pred$.pred_class, exp_f_pred) - - # x/y method - expect_error( - xy_fit <- fit_xy(lda_spec, x = glass_tr[, -10], y = glass_tr$Type), - NA - ) - xy_pred <- predict(xy_fit, glass_te) - # See bug note above - # exp_xy_pred <- predict(exp_xy_fit, glass_te) - - expect_true(inherits(xy_pred, "tbl_df")) - expect_true(all(names(xy_pred) == ".pred_class")) - expect_equal(xy_pred$.pred_class, exp_f_pred) -}) - -# ------------------------------------------------------------------------------ - - -test_that("prob predictions", { - # formula method - expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) - f_pred <- predict(f_fit, glass_te, type = "prob") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_te, type = "posterior")) - - expect_true(inherits(f_pred, "tbl_df")) - expect_equal(names(f_pred), prob_names) - expect_equal(f_pred, exp_f_pred) - - # x/y method - expect_error( - xy_fit <- fit_xy(lda_spec, x = glass_tr[, -10], y = glass_tr$Type), - NA - ) - xy_pred <- predict(xy_fit, glass_te, type = "prob") - expect_true(inherits(xy_pred, "tbl_df")) - expect_equal(names(xy_pred), prob_names) - expect_equal(xy_pred, exp_f_pred) -}) - -# ------------------------------------------------------------------------------ - - -test_that("missing data", { - expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) - f_pred <- predict(f_fit, glass_na, type = "prob") - - opt <- getOption("na.action") - options(na.action = "na.pass") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_na, type = "posterior")) - options(na.action = opt) - - expect_true(inherits(f_pred, "tbl_df")) - expect_true(nrow(f_pred) == nrow(glass_te)) - expect_equal(names(f_pred), prob_names) - expect_equal(f_pred, exp_f_pred) -}) - -# ------------------------------------------------------------------------------ - -test_that("printing", { - expect_output( - print(lda_spec), - "Linear Discriminant Model Specification" - ) -}) - - -# ------------------------------------------------------------------------------ - -test_that("updating", { - lda_spec_2 <- discrim_linear(penalty = .1) %>% set_engine("mda") - lda_spec_3 <- update(lda_spec, penalty = .1) - expect_equal(lda_spec_2, lda_spec_3) - - prior_spec_2 <- discrim_linear(penalty = .1) %>% - set_engine("mda", prior = rep(1 / 6, 6)) - prior_spec_3 <- update(prior_spec, penalty = .1) - expect_equal( - prior_spec_2, prior_spec_3, - ignore_function_env = TRUE, - ignore_formula_env = TRUE - ) -}) diff --git a/tests/testthat/test-linear-lda.R b/tests/testthat/test-linear-lda.R index 66cfda0..0a9b0dd 100644 --- a/tests/testthat/test-linear-lda.R +++ b/tests/testthat/test-linear-lda.R @@ -1,18 +1,12 @@ -lda_spec <- discrim_linear() %>% set_engine("MASS") -prior_spec <- discrim_linear() %>% set_engine("MASS", prior = rep(1/6, 6)) - -exp_f_fit <- MASS::lda(Type ~ ., data = glass_tr) -exp_xy_fit <- MASS::lda(x = glass_tr[,-10], grouping = glass_tr$Type) -exp_prior_fit <- MASS::lda(Type ~ ., data = glass_tr, prior = rep(1/6, 6)) - -# ------------------------------------------------------------------------------ - -test_that('model object', { +test_that('MASS::lda model object', { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R # formula method expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) - expect_equal(f_fit$fit$scaling, exp_f_fit$scaling) - expect_equal(f_fit$fit$means, exp_f_fit$means) + expect_equal(f_fit$fit$scaling, exp_f_fit_lda$scaling) + expect_equal(f_fit$fit$means, exp_f_fit_lda$means) # x/y method expect_error( @@ -22,24 +16,28 @@ test_that('model object', { # `MASS::lda()` doesn't throw an error despite a factor predictor. It converts # the factor to integers. Reported to MASS@stats.ox.ac.uk on 2019-10-08. We # now use the formula method in the parsnip model to avoid the bug. - # expect_error(xy_fit$fit$scaling, exp_xy_fit$scaling) + # expect_error(xy_fit$fit$scaling, exp_xy_fit_lda$scaling) # expect_error(xy_fit$fit$means, exp_xy_fit$means) # pass an extra argument - expect_error(prior_fit <- fit(prior_spec, Type ~ ., data = glass_tr), NA) - expect_equal(prior_fit$fit$scaling, exp_prior_fit$scaling) - expect_equal(prior_fit$fit$means, exp_prior_fit$means) + expect_error(prior_fit <- fit(prior_spec_lda, Type ~ ., data = glass_tr), NA) + expect_equal(prior_fit$fit$scaling, exp_prior_fit_lda$scaling) + expect_equal(prior_fit$fit$means, exp_prior_fit_lda$means) }) # ------------------------------------------------------------------------------ -test_that("class predictions", { +test_that("MASS::lda class predictions", { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te) - exp_f_pred <- predict(exp_f_fit, glass_te) + exp_f_pred <- predict(exp_f_fit_lda, glass_te) expect_true(inherits(f_pred, "tbl_df")) expect_true(all(names(f_pred) == ".pred_class")) @@ -52,16 +50,16 @@ test_that("class predictions", { ) xy_pred <- predict(xy_fit, glass_te) # See bug note above - # exp_xy_pred <- predict(exp_xy_fit, glass_te) + # exp_xy_pred <- predict(exp_xy_fit_lda, glass_te) expect_true(inherits(xy_pred, "tbl_df")) expect_true(all(names(xy_pred) == ".pred_class")) expect_equal(xy_pred$.pred_class, exp_f_pred$class) # added argument - expect_error(prior_fit <- fit(prior_spec, Type ~ ., data = glass_tr), NA) + expect_error(prior_fit <- fit(prior_spec_lda, Type ~ ., data = glass_tr), NA) prior_pred <- predict(prior_fit, glass_te) - exp_prior_pred <- predict(exp_prior_fit, glass_te) + exp_prior_pred <- predict(exp_prior_fit_lda, glass_te) expect_true(inherits(f_pred, "tbl_df")) expect_true(all(names(f_pred) == ".pred_class")) @@ -71,14 +69,18 @@ test_that("class predictions", { # ------------------------------------------------------------------------------ -test_that("prob predictions", { +test_that("MASS::lda prob predictions", { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te, type = "prob") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_te)$posterior) + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_lda, glass_te)$posterior) expect_true(inherits(f_pred, "tbl_df")) - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), glass_prob_names) expect_equal(f_pred, exp_f_pred) # x/y method @@ -88,39 +90,46 @@ test_that("prob predictions", { ) xy_pred <- predict(xy_fit, glass_te, type = "prob") # See bug note above - # exp_xy_pred <- predict(exp_xy_fit, glass_te) + # exp_xy_pred <- predict(exp_xy_fit_lda, glass_te) expect_s3_class(xy_pred, "tbl_df") - expect_equal(names(xy_pred), prob_names) + expect_equal(names(xy_pred), glass_prob_names) expect_equal(xy_pred, exp_f_pred) # added argument - expect_error(prior_fit <- fit(prior_spec, Type ~ ., data = glass_tr), NA) + expect_error(prior_fit <- fit(prior_spec_lda, Type ~ ., data = glass_tr), NA) prior_pred <- predict(prior_fit, glass_te, type = "prob") - exp_prior_pred <- probs_to_tibble(predict(exp_prior_fit, glass_te)$posterior) + exp_prior_pred <- probs_to_tibble(predict(exp_prior_fit_lda, glass_te)$posterior) expect_true(inherits(prior_pred, "tbl_df")) - expect_equal(names(prior_pred), prob_names) + expect_equal(names(prior_pred), glass_prob_names) expect_equal(prior_pred, exp_prior_pred) }) # ------------------------------------------------------------------------------ -test_that("missing data", { +test_that("MASS::lda missing data", { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + expect_error(f_fit <- fit(lda_spec, Type ~ ., data = glass_tr), NA) expect_snapshot(f_pred <- predict(f_fit, glass_na, type = "prob")) - expect_snapshot(exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_na)$posterior)) + expect_snapshot(exp_f_pred <- probs_to_tibble(predict(exp_f_fit_lda, glass_na)$posterior)) expect_s3_class(f_pred, "tbl_df") expect_true(nrow(f_pred) == nrow(glass_te)) - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), glass_prob_names) expect_equal(f_pred, exp_f_pred) }) # ------------------------------------------------------------------------------ test_that("sda fit and prediction", { + skip_if_not_installed("sda") + skip_if_not_installed("mlbench") + sda_fit <- sda::sda( glass_tr %>% dplyr::select(-factor, -Type) %>% as.matrix(), glass_tr$Type, diff --git a/tests/testthat/test-linear-ridge.R b/tests/testthat/test-linear-ridge.R new file mode 100644 index 0000000..2be2374 --- /dev/null +++ b/tests/testthat/test-linear-ridge.R @@ -0,0 +1,136 @@ +test_that('mda::fda/gen.ridge model object', { + skip_if_not_installed("mda") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + + # formula method + expect_error(f_fit <- fit(lda_fda_spec, Type ~ ., data = glass_tr), NA) + expect_equal(f_fit$fit$theta.mod, exp_f_fit_lda_fda$theta.mod) + expect_equal(f_fit$fit$fit$coefficients, exp_f_fit_lda_fda$fit$coefficients) + + expect_error( + f_wts_fit <- fit(lda_fda_spec, Type ~ ., data = glass_tr, case_weights = wts), + NA + ) + expect_equal(f_wts_fit$fit$theta.mod, exp_f_wts_fit_lda_fda$theta.mod) + expect_equal(f_wts_fit$fit$fit$coefficients, exp_f_wts_fit_lda_fda$fit$coefficients) + + # x/y method + expect_error( + xy_fit <- fit_xy(lda_fda_spec, x = glass_tr[,-10], y = glass_tr$Type), + NA + ) + expect_equal(xy_fit$fit$theta.mod, exp_f_fit_lda_fda$theta.mod) + expect_equal(xy_fit$fit$fit$coefficients, exp_f_fit_lda_fda$fit$coefficients) + + expect_error( + xy_wts_fit <- fit_xy(lda_fda_spec, x = glass_tr[,-10], y = glass_tr$Type, + case_weights = wts), + NA + ) + expect_equal(xy_wts_fit$fit$theta.mod, exp_f_wts_fit_lda_fda$theta.mod) + expect_equal(xy_wts_fit$fit$fit$coefficients, exp_f_wts_fit_lda_fda$fit$coefficients) + +}) + +# ------------------------------------------------------------------------------ + + +test_that('mda::fda/gen.ridge class predictions', { + skip_if_not_installed("mda") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + + # formula method + expect_error(f_fit <- fit(lda_fda_spec, Type ~ ., data = glass_tr), NA) + f_pred <- predict(f_fit, glass_te) + exp_f_pred <- predict(exp_f_fit_lda_fda, glass_te) + + expect_true(inherits(f_pred, "tbl_df")) + expect_true(all(names(f_pred) == ".pred_class")) + expect_equal(f_pred$.pred_class, exp_f_pred) + + # x/y method + expect_error( + xy_fit <- fit_xy(lda_fda_spec, x = glass_tr[, -10], y = glass_tr$Type), + NA + ) + xy_pred <- predict(xy_fit, glass_te) + # See bug note above + # exp_xy_pred <- predict(exp_xy_fit, glass_te) + + expect_true(inherits(xy_pred, "tbl_df")) + expect_true(all(names(xy_pred) == ".pred_class")) + expect_equal(xy_pred$.pred_class, exp_f_pred) +}) + +# ------------------------------------------------------------------------------ + + +test_that("mda::fda/gen.ridge prob predictions", { + skip_if_not_installed("mda") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + + # formula method + expect_error(f_fit <- fit(lda_fda_spec, Type ~ ., data = glass_tr), NA) + f_pred <- predict(f_fit, glass_te, type = "prob") + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_lda_fda, glass_te, type = "posterior")) + + expect_true(inherits(f_pred, "tbl_df")) + expect_equal(names(f_pred), glass_prob_names) + expect_equal(f_pred, exp_f_pred) + + # x/y method + expect_error( + xy_fit <- fit_xy(lda_fda_spec, x = glass_tr[, -10], y = glass_tr$Type), + NA + ) + xy_pred <- predict(xy_fit, glass_te, type = "prob") + expect_true(inherits(xy_pred, "tbl_df")) + expect_equal(names(xy_pred), glass_prob_names) + expect_equal(xy_pred, exp_f_pred) +}) + +# ------------------------------------------------------------------------------ + + +test_that("mda::fda/gen.ridge missing data", { + skip_if_not_installed("mda") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + + expect_error(f_fit <- fit(lda_fda_spec, Type ~ ., data = glass_tr), NA) + f_pred <- predict(f_fit, glass_na, type = "prob") + + opt <- getOption("na.action") + options(na.action = "na.pass") + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_lda_fda, glass_na, type = "posterior")) + options(na.action = opt) + + expect_true(inherits(f_pred, "tbl_df")) + expect_true(nrow(f_pred) == nrow(glass_te)) + expect_equal(names(f_pred), glass_prob_names) + expect_equal(f_pred, exp_f_pred) +}) + +# ------------------------------------------------------------------------------ + +test_that("mda::fda/gen.ridge updating", { + skip_if_not_installed("mda") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + + lda_spec_2 <- discrim_linear(penalty = .1) %>% set_engine("mda") + lda_spec_3 <- update(lda_fda_spec, penalty = .1) + expect_equal(lda_spec_2, lda_spec_3) + + prior_spec_2 <- discrim_linear(penalty = .1) %>% + set_engine("mda", prior = rep(1 / 6, 6)) + prior_spec_3 <- update(prior_lda_fda_spec, penalty = .1) + expect_equal( + prior_spec_2, prior_spec_3, + ignore_function_env = TRUE, + ignore_formula_env = TRUE + ) +}) diff --git a/tests/testthat/test-linear-sda.R b/tests/testthat/test-linear-sda.R index e689def..fab0df8 100644 --- a/tests/testthat/test-linear-sda.R +++ b/tests/testthat/test-linear-sda.R @@ -1,4 +1,8 @@ test_that("sda fit and prediction", { + skip_if_not_installed("sda") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + sda_fit <- sda::sda( glass_tr %>% dplyr::select(-factor, -Type) %>% as.matrix(), glass_tr$Type, diff --git a/tests/testthat/test-linear-sparsediscrim.R b/tests/testthat/test-linear-sparsediscrim.R index b2bf27c..2f00fd4 100644 --- a/tests/testthat/test-linear-sparsediscrim.R +++ b/tests/testthat/test-linear-sparsediscrim.R @@ -1,4 +1,7 @@ -test_that("lda_diag fit and prediction", { +test_that("sparsediscrim::lda_diag fit and prediction", { + skip_if_not_installed("sparsediscrim") + skip_if_not_installed("mlbench") + spd_fit <- sparsediscrim::lda_diag( glass_tr %>% dplyr::select(RI, Na, Mg), glass_tr$Type @@ -51,7 +54,10 @@ test_that("lda_diag fit and prediction", { # ------------------------------------------------------------------------------ -test_that("lda_shrink_mean fit and prediction", { +test_that("sparsediscrim::lda_shrink_mean fit and prediction", { + skip_if_not_installed("sparsediscrim") + skip_if_not_installed("mlbench") + spd_fit <- sparsediscrim::lda_shrink_mean( glass_tr %>% dplyr::select(RI, Na, Mg), glass_tr$Type @@ -103,7 +109,10 @@ test_that("lda_shrink_mean fit and prediction", { # ------------------------------------------------------------------------------ -test_that("lda_shrink_cov fit and prediction", { +test_that("sparsediscrim::lda_shrink_cov fit and prediction", { + skip_if_not_installed("sparsediscrim") + skip_if_not_installed("mlbench") + spd_fit <- sparsediscrim::lda_shrink_cov( glass_tr %>% dplyr::select(RI, Na, Mg), glass_tr$Type @@ -155,7 +164,10 @@ test_that("lda_shrink_cov fit and prediction", { # ------------------------------------------------------------------------------ -test_that('lda_emp_bayes_eigen fit and prediction', { +test_that('sparsediscrim lda_emp_bayes_eigen fit and prediction', { + skip_if_not_installed("sparsediscrim") + skip_if_not_installed("mlbench") + data(cells, package = "modeldata") cell_tr <- cells %>% dplyr::filter(case == "Train") %>% dplyr::select(-case) cell_te <- cells %>% dplyr::filter(case == "Test") %>% dplyr::select(-case, -class) diff --git a/tests/testthat/test-naive-Bayes.R b/tests/testthat/test-naive-Bayes.R index 945fb3a..c023320 100644 --- a/tests/testthat/test-naive-Bayes.R +++ b/tests/testthat/test-naive-Bayes.R @@ -1,49 +1,43 @@ -library(mlbench) -data(Glass) +test_that("klaR::NaiveBayes", { + skip_if_not_installed("mlbench") + skip_if_not_installed("klaR") -# Naive Bayes doesn't like zero-variance predictors within a class -Glass <- Glass[, !(names(Glass) %in% c("K", "Ba", "Fe"))] + # ------------------------------------------------------------------------------ -set.seed(55822) -in_samp <- sample.int(nrow(Glass), 5) + library(mlbench) -# Add a random factor predictor to test dummy variables -Glass$factor <- factor(sample(letters[1:3], nrow(Glass), replace = TRUE)) + data(Glass) -glass_tr <- Glass[-in_samp, ] -glass_te <- Glass[in_samp, -10] -glass_na <- glass_te -glass_na$RI[1] <- NA -glass_na$Na[2] <- NA + # Naive Bayes doesn't like zero-variance predictors within a class + Glass <- Glass[, !(names(Glass) %in% c("K", "Ba", "Fe"))] -glass_lvl <- levels(Glass$Type) -prob_names <- paste0(".pred_", glass_lvl) + set.seed(55822) + in_samp <- sample.int(nrow(Glass), 5) -# ------------------------------------------------------------------------------ + # Add a random factor predictor to test dummy variables + Glass$factor <- factor(sample(letters[1:3], nrow(Glass), replace = TRUE)) -probs_to_tibble <- function(x) { - x <- tibble::as_tibble(x) - names(x) <- paste0(".pred_", names(x)) - x -} + glass_tr <- Glass[-in_samp, ] + glass_te <- Glass[in_samp, -10] + glass_na <- glass_te + glass_na$RI[1] <- NA + glass_na$Na[2] <- NA -# ------------------------------------------------------------------------------ + glass_lvl <- levels(Glass$Type) + prob_names <- paste0(".pred_", glass_lvl) -nb_spec <- naive_Bayes(smoothness = 1.2) %>% set_engine("klaR") -prior_spec <- naive_Bayes() %>% set_engine("klaR", prior = rep(1/6, 6)) + nb_spec <- naive_Bayes(smoothness = 1.2) %>% set_engine("klaR") + prior_spec <- naive_Bayes() %>% set_engine("klaR", prior = rep(1/6, 6)) -exp_f_fit <- klaR::NaiveBayes(Type ~ ., data = glass_tr, - usekernel = TRUE, adjust = 1.2) -exp_xy_fit <- klaR::NaiveBayes(x = glass_tr[,-10], grouping = glass_tr$Type, - usekernel = TRUE, adjust = 1.2) -exp_prior_fit <- klaR::NaiveBayes(x = glass_tr[,-10], grouping = glass_tr$Type, - prior = rep(1/6, 6), usekernel = TRUE) - -# ------------------------------------------------------------------------------ - -test_that("model object", { + exp_f_fit <- klaR::NaiveBayes(Type ~ ., data = glass_tr, + usekernel = TRUE, adjust = 1.2) + exp_xy_fit <- klaR::NaiveBayes(x = glass_tr[,-10], grouping = glass_tr$Type, + usekernel = TRUE, adjust = 1.2) + exp_prior_fit <- klaR::NaiveBayes(x = glass_tr[,-10], grouping = glass_tr$Type, + prior = rep(1/6, 6), usekernel = TRUE) + # ------------------------------------------------------------------------------ # formula method expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) # The calls are embedded and different so check the numbers @@ -93,12 +87,11 @@ test_that("model object", { } expect_equal(prior_fit$fit$tables[["factor"]], exp_prior_fit$tables[["factor"]]) -}) -# ------------------------------------------------------------------------------ + # ------------------------------------------------------------------------------ + # class predictions -test_that("class predictions", { # formula method expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te) @@ -128,12 +121,10 @@ test_that("class predictions", { expect_s3_class(f_pred, "tbl_df") expect_true(all(names(f_pred) == ".pred_class")) expect_equal(prior_pred$.pred_class, exp_prior_pred$class, ignore_attr = TRUE) -}) - -# ------------------------------------------------------------------------------ + # ------------------------------------------------------------------------------ + # prob predictions -test_that("prob predictions", { # formula method expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te, type = "prob") @@ -163,12 +154,10 @@ test_that("prob predictions", { expect_s3_class(prior_pred, "tbl_df") expect_equal(names(prior_pred), prob_names) expect_equal(prior_pred, exp_prior_pred) -}) -# ------------------------------------------------------------------------------ + # ------------------------------------------------------------------------------ + # missing data - -test_that("missing data", { expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_na, type = "prob") exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_na)$posterior) @@ -177,17 +166,10 @@ test_that("missing data", { expect_true(nrow(f_pred) == nrow(glass_te)) expect_equal(names(f_pred), prob_names) expect_equal(f_pred, exp_f_pred) -}) - -# ------------------------------------------------------------------------------ -test_that("printing", { - expect_snapshot(print(nb_spec)) -}) - -# ------------------------------------------------------------------------------ + # ------------------------------------------------------------------------------ + # updating -test_that("updating", { nb_spec_2 <- naive_Bayes(smoothness = .1) %>% set_engine("klaR") nb_spec_3 <- update(nb_spec, smoothness = .1) expect_equal(nb_spec_2, nb_spec_3) @@ -202,8 +184,3 @@ test_that("updating", { ) }) -test_that("check_args() works", { - skip_if_not_installed("parsnip", "1.2.1.9001") - # Here for completeness, no checking is done - expect_true(TRUE) -}) diff --git a/tests/testthat/test-naive-Bayes_naivebayes.R b/tests/testthat/test-naive-Bayes_naivebayes.R index d922e2c..2205cdd 100644 --- a/tests/testthat/test-naive-Bayes_naivebayes.R +++ b/tests/testthat/test-naive-Bayes_naivebayes.R @@ -1,59 +1,51 @@ -library(mlbench) +test_that("naivebayes::naive_bayes", { + skip_if_not_installed("mlbench") + skip_if_not_installed("naivebayes") -data(Glass) + # ------------------------------------------------------------------------------ -# Naive Bayes doesn't like zero-variance predictors within a class -Glass <- Glass[, !(names(Glass) %in% c("K", "Ba", "Fe"))] + data(Glass) -set.seed(55822) -in_samp <- sample.int(nrow(Glass), 5) + # Naive Bayes doesn't like zero-variance predictors within a class + Glass <- Glass[, !(names(Glass) %in% c("K", "Ba", "Fe"))] -# Add a random factor predictor to test dummy variables -Glass$factor <- factor(sample(letters[1:3], nrow(Glass), replace = TRUE)) + set.seed(55822) + in_samp <- sample.int(nrow(Glass), 5) -glass_tr <- Glass[-in_samp, ] -glass_te <- Glass[in_samp, -7] -glass_na <- glass_te -glass_na$RI[1] <- NA -glass_na$Na[2] <- NA + # Add a random factor predictor to test dummy variables + Glass$factor <- factor(sample(letters[1:3], nrow(Glass), replace = TRUE)) -glass_lvl <- levels(Glass$Type) -prob_names <- paste0(".pred_", glass_lvl) + glass_tr <- Glass[-in_samp, ] + glass_te <- Glass[in_samp, -7] + glass_na <- glass_te + glass_na$RI[1] <- NA + glass_na$Na[2] <- NA -# ------------------------------------------------------------------------------ + glass_lvl <- levels(Glass$Type) + prob_names <- paste0(".pred_", glass_lvl) -probs_to_tibble <- function(x) { - x <- tibble::as_tibble(x) - names(x) <- paste0(".pred_", names(x)) - x -} + # ------------------------------------------------------------------------------ -# ------------------------------------------------------------------------------ + nb_spec <- naive_Bayes(smoothness = 1.2) %>% set_engine("naivebayes") + prior_spec <- naive_Bayes() %>% set_engine("naivebayes", prior = rep(1 / 6, 6)) -nb_spec <- naive_Bayes(smoothness = 1.2) %>% set_engine("naivebayes") -prior_spec <- naive_Bayes() %>% set_engine("naivebayes", prior = rep(1 / 6, 6)) - - -exp_f_fit <- naivebayes::naive_bayes( - Type ~ ., - data = glass_tr, - usekernel = TRUE, adjust = 1.2 -) - -exp_xy_fit <- naivebayes::naive_bayes( - x = glass_tr[, -7], y = glass_tr$Type, - usekernel = TRUE, adjust = 1.2 -) - -exp_prior_fit <- naivebayes::naive_bayes( - x = glass_tr[, -7], y = glass_tr$Type, - prior = rep(1 / 6, 6), usekernel = TRUE -) + exp_f_fit <- naivebayes::naive_bayes( + Type ~ ., + data = glass_tr, + usekernel = TRUE, adjust = 1.2 + ) + exp_xy_fit <- naivebayes::naive_bayes( + x = glass_tr[, -7], y = glass_tr$Type, + usekernel = TRUE, adjust = 1.2 + ) -# ------------------------------------------------------------------------------ + exp_prior_fit <- naivebayes::naive_bayes( + x = glass_tr[, -7], y = glass_tr$Type, + prior = rep(1 / 6, 6), usekernel = TRUE + ) -test_that("model object", { + # ------------------------------------------------------------------------------ # formula method expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) @@ -102,12 +94,9 @@ test_that("model object", { } } expect_equal(prior_fit$fit$tables[["factor"]], exp_prior_fit$tables[["factor"]]) -}) -# ------------------------------------------------------------------------------ + # ------------------------------------------------------------------------------ - -test_that("class predictions", { # formula method expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te) @@ -137,12 +126,10 @@ test_that("class predictions", { expect_s3_class(f_pred, "tbl_df") expect_true(all(names(f_pred) == ".pred_class")) expect_equal(prior_pred$.pred_class, exp_prior_pred, ignore_attr = TRUE) -}) -# ------------------------------------------------------------------------------ + # ------------------------------------------------------------------------------ + # prob predictions - -test_that("prob predictions", { # formula method expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te, type = "prob") @@ -172,12 +159,10 @@ test_that("prob predictions", { expect_s3_class(prior_pred, "tbl_df") expect_equal(names(prior_pred), prob_names) expect_equal(prior_pred, exp_prior_pred) -}) -# ------------------------------------------------------------------------------ + # ------------------------------------------------------------------------------ + # missing data - -test_that("missing data", { expect_error(f_fit <- fit(nb_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_na, type = "prob") exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_na, type = "prob")) @@ -188,8 +173,3 @@ test_that("missing data", { expect_equal(f_pred, exp_f_pred) }) -# ------------------------------------------------------------------------------ - -test_that("printing", { - expect_snapshot(print(nb_spec)) -}) diff --git a/tests/testthat/test-quad-qda.R b/tests/testthat/test-quad-qda.R index 444d666..64671c9 100644 --- a/tests/testthat/test-quad-qda.R +++ b/tests/testthat/test-quad-qda.R @@ -1,28 +1,12 @@ -data(penguins, package = "modeldata") -penguins$island <- NULL -penguins_miss <- penguins -penguins <- na.omit(penguins) -in_train <- seq(1, nrow(penguins), by = 2) -penguin_tr <- penguins[in_train, ] -penguin_te <- penguins[-in_train, ] - -qda_spec <- discrim_quad() %>% set_engine("MASS") -prior_spec <- discrim_quad() %>% set_engine("MASS", prior = rep(1 / 3, 3)) - -exp_f_fit <- MASS::qda(species ~ ., data = penguin_tr) -exp_xy_fit <- MASS::qda(x = penguin_tr[, -1], grouping = penguin_tr$species) -exp_prior_fit <- MASS::qda(species ~ ., data = penguin_tr, prior = rep(1 / 3, 3)) - -prob_names <- c(".pred_Adelie", ".pred_Chinstrap", ".pred_Gentoo") - -# ------------------------------------------------------------------------------ - -test_that("model object", { +test_that("MASS::qda model object", { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R # formula method expect_error(f_fit <- fit(qda_spec, species ~ ., data = penguin_tr), NA) - expect_equal(f_fit$fit$scaling, exp_f_fit$scaling) - expect_equal(f_fit$fit$means, exp_f_fit$means) + expect_equal(f_fit$fit$scaling, exp_f_fit_qda$scaling) + expect_equal(f_fit$fit$means, exp_f_fit_qda$means) # x/y method expect_error( @@ -37,19 +21,23 @@ test_that("model object", { # pass an extra argument - expect_error(prior_fit <- fit(prior_spec, species ~ ., data = penguin_tr), NA) - expect_equal(prior_fit$fit$scaling, exp_prior_fit$scaling) - expect_equal(prior_fit$fit$means, exp_prior_fit$means) + expect_error(prior_fit <- fit(prior_spec_qda, species ~ ., data = penguin_tr), NA) + expect_equal(prior_fit$fit$scaling, exp_prior_fit_qda$scaling) + expect_equal(prior_fit$fit$means, exp_prior_fit_qda$means) }) # ------------------------------------------------------------------------------ -test_that("class predictions", { +test_that("MASS::qda class predictions", { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(qda_spec, species ~ ., data = penguin_tr), NA) f_pred <- predict(f_fit, penguin_te) - exp_f_pred <- predict(exp_f_fit, penguin_te) + exp_f_pred <- predict(exp_f_fit_qda, penguin_te) expect_true(inherits(f_pred, "tbl_df")) expect_true(all(names(f_pred) == ".pred_class")) @@ -69,9 +57,9 @@ test_that("class predictions", { expect_equal(xy_pred$.pred_class, exp_f_pred$class) # added argument - expect_error(prior_fit <- fit(prior_spec, species ~ ., data = penguin_tr), NA) + expect_error(prior_fit <- fit(prior_spec_qda, species ~ ., data = penguin_tr), NA) prior_pred <- predict(prior_fit, penguin_te) - exp_prior_pred <- predict(exp_prior_fit, penguin_te) + exp_prior_pred <- predict(exp_prior_fit_qda, penguin_te) expect_true(inherits(f_pred, "tbl_df")) expect_true(all(names(f_pred) == ".pred_class")) @@ -81,14 +69,18 @@ test_that("class predictions", { # ------------------------------------------------------------------------------ -test_that("prob predictions", { +test_that("MASS::qda prob predictions", { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(qda_spec, species ~ ., data = penguin_tr), NA) f_pred <- predict(f_fit, penguin_te, type = "prob") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, penguin_te)$posterior) + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_qda, penguin_te)$posterior) expect_true(inherits(f_pred, "tbl_df")) - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), pen_prob_names) expect_equal(f_pred, exp_f_pred) # x/y method @@ -101,30 +93,37 @@ test_that("prob predictions", { # exp_xy_pred <- predict(exp_xy_fit, penguin_te) expect_true(inherits(xy_pred, "tbl_df")) - expect_equal(names(xy_pred), prob_names) + expect_equal(names(xy_pred), pen_prob_names) expect_equal(xy_pred, exp_f_pred) # added argument - expect_error(prior_fit <- fit(prior_spec, species ~ ., data = penguin_tr), NA) + expect_error(prior_fit <- fit(prior_spec_qda, species ~ ., data = penguin_tr), NA) prior_pred <- predict(prior_fit, penguin_te, type = "prob") - exp_prior_pred <- probs_to_tibble(predict(exp_prior_fit, penguin_te)$posterior) + exp_prior_pred <- probs_to_tibble(predict(exp_prior_fit_qda, penguin_te)$posterior) expect_true(inherits(prior_pred, "tbl_df")) - expect_equal(names(prior_pred), prob_names) + expect_equal(names(prior_pred), pen_prob_names) expect_equal(prior_pred, exp_prior_pred) }) # ------------------------------------------------------------------------------ +test_that("MASS::qda missing data", { + skip_if_not_installed("MASS") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R -test_that("missing data", { - exp_f_fit <- MASS::qda(species ~ ., data = penguins_miss) + exp_f_fit_miss <- MASS::qda(species ~ ., data = penguins_miss) expect_error(f_fit <- fit(qda_spec, species ~ ., data = penguins_miss), NA) expect_snapshot(f_pred <- predict(f_fit, penguins_miss, type = "prob")) - expect_snapshot(exp_f_pred <- probs_to_tibble(predict(exp_f_fit, penguins_miss)$posterior)) + expect_snapshot_warning( + # exp_f_pred <- probs_to_tibble(predict(exp_f_fit_miss, penguins_miss)$posterior) + exp_f_pred <- predict(exp_f_fit_miss, penguins_miss)$posterior + ) + exp_f_pred <- probs_to_tibble(exp_f_pred) expect_s3_class(f_pred, "tbl_df") expect_true(nrow(f_pred) == nrow(penguins_miss)) - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), pen_prob_names) expect_equal(f_pred, exp_f_pred) }) diff --git a/tests/testthat/test-quad-sparsediscrim.R b/tests/testthat/test-quad-sparsediscrim.R index d5fc932..6c816e0 100644 --- a/tests/testthat/test-quad-sparsediscrim.R +++ b/tests/testthat/test-quad-sparsediscrim.R @@ -1,4 +1,7 @@ -test_that("qda_diag fit and prediction", { +test_that("sparsediscrim::qda_diag fit and prediction", { + skip_if_not_installed("sparsediscrim") + skip_if_not_installed("mlbench") + spd_fit <- sparsediscrim::qda_diag( glass_tr %>% dplyr::select(RI, Na, Mg), glass_tr$Type @@ -51,7 +54,10 @@ test_that("qda_diag fit and prediction", { # ------------------------------------------------------------------------------ -test_that("qda_shrink_mean fit and prediction", { +test_that("sparsediscrim::qda_shrink_mean fit and prediction", { + skip_if_not_installed("sparsediscrim") + skip_if_not_installed("mlbench") + spd_fit <- sparsediscrim::qda_shrink_mean( glass_tr %>% dplyr::select(RI, Na, Mg), glass_tr$Type @@ -103,7 +109,10 @@ test_that("qda_shrink_mean fit and prediction", { # ------------------------------------------------------------------------------ -test_that("qda_shrink_cov fit and prediction", { +test_that("sparsediscrim::qda_shrink_cov fit and prediction", { + skip_if_not_installed("sparsediscrim") + skip_if_not_installed("mlbench") + spd_fit <- sparsediscrim::qda_shrink_cov( glass_tr %>% dplyr::select(RI, Na, Mg), glass_tr$Type diff --git a/tests/testthat/test-quad.R b/tests/testthat/test-quad.R deleted file mode 100644 index 162cb0d..0000000 --- a/tests/testthat/test-quad.R +++ /dev/null @@ -1,4 +0,0 @@ -test_that("check_args() works", { - # Here for completeness, no checking is done - expect_true(TRUE) -}) diff --git a/tests/testthat/test-rda.R b/tests/testthat/test-rda.R index c7f68ba..61c3c67 100644 --- a/tests/testthat/test-rda.R +++ b/tests/testthat/test-rda.R @@ -1,37 +1,34 @@ -rda_spec <- - discrim_regularized(frac_common_cov = .1, frac_identity = 1) %>% - set_engine("klaR") - -prior_spec <- discrim_regularized() %>% set_engine("klaR", prior = rep(1 / 6, 6)) - -exp_f_fit <- klaR::rda(Type ~ ., data = glass_tr, lambda = .1, gamma = 1) - -# ------------------------------------------------------------------------------ - -test_that("model object", { +test_that("klaR::rda model object", { + skip_if_not_installed("klaR") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R # formula method expect_error(f_fit <- fit(rda_spec, Type ~ ., data = glass_tr), NA) - expect_equal(f_fit$fit$covpooled, exp_f_fit$covpooled) - expect_equal(f_fit$fit$means, exp_f_fit$means) + expect_equal(f_fit$fit$covpooled, exp_f_fit_rda$covpooled) + expect_equal(f_fit$fit$means, exp_f_fit_rda$means) # x/y method expect_error( xy_fit <- fit_xy(rda_spec, x = glass_tr[, -10], y = glass_tr$Type), NA ) - expect_equal(xy_fit$fit$covpooled, exp_f_fit$covpooled) - expect_equal(xy_fit$fit$means, exp_f_fit$means) + expect_equal(xy_fit$fit$covpooled, exp_f_fit_rda$covpooled) + expect_equal(xy_fit$fit$means, exp_f_fit_rda$means) }) # ------------------------------------------------------------------------------ -test_that("class predictions", { +test_that("klaR::rda class predictions", { + skip_if_not_installed("klaR") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(rda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te) - exp_f_pred <- predict(exp_f_fit, glass_te)$class + exp_f_pred <- predict(exp_f_fit_rda, glass_te)$class expect_s3_class(f_pred, "tbl_df") expect_true(all(names(f_pred) == ".pred_class")) @@ -54,14 +51,18 @@ test_that("class predictions", { # ------------------------------------------------------------------------------ -test_that("prob predictions", { +test_that("klaR::rda prob predictions", { + skip_if_not_installed("klaR") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + # formula method expect_error(f_fit <- fit(rda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_te, type = "prob") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_te, type = "posterior")$posterior) + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_rda, glass_te, type = "posterior")$posterior) expect_s3_class(f_pred, "tbl_df") - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), glass_prob_names) expect_equal(f_pred, exp_f_pred) # x/y method @@ -71,34 +72,46 @@ test_that("prob predictions", { ) xy_pred <- predict(xy_fit, glass_te, type = "prob") expect_s3_class(xy_pred, "tbl_df") - expect_equal(names(xy_pred), prob_names) + expect_equal(names(xy_pred), glass_prob_names) expect_equal(xy_pred, exp_f_pred) }) # ------------------------------------------------------------------------------ -test_that("missing data", { +test_that("klaR::rda missing data", { + skip_if_not_installed("klaR") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + expect_error(f_fit <- fit(rda_spec, Type ~ ., data = glass_tr), NA) f_pred <- predict(f_fit, glass_na, type = "prob") - exp_f_pred <- probs_to_tibble(predict(exp_f_fit, glass_na, type = "posterior")$posterior) + exp_f_pred <- probs_to_tibble(predict(exp_f_fit_rda, glass_na, type = "posterior")$posterior) expect_s3_class(f_pred, "tbl_df") expect_true(nrow(f_pred) == nrow(glass_te)) - expect_equal(names(f_pred), prob_names) + expect_equal(names(f_pred), glass_prob_names) expect_equal(f_pred, exp_f_pred) }) # ------------------------------------------------------------------------------ -test_that("printing", { +test_that("klaR::rda printing", { + skip_if_not_installed("klaR") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + expect_snapshot(print(rda_spec)) }) # ------------------------------------------------------------------------------ -test_that("updating", { +test_that("klaR::rda updating", { + skip_if_not_installed("klaR") + skip_if_not_installed("mlbench") + # exp_* objects in helper-object.R + rda_spec_2 <- discrim_regularized(frac_common_cov = 1, frac_identity = 1) %>% set_engine("klaR") @@ -107,7 +120,7 @@ test_that("updating", { prior_spec_2 <- discrim_regularized(frac_common_cov = 1) %>% set_engine("klaR", prior = rep(1 / 6, 6)) - prior_spec_3 <- update(prior_spec, frac_common_cov = 1) + prior_spec_3 <- update(prior_spec_rda, frac_common_cov = 1) expect_equal(prior_spec_2, prior_spec_3, ignore_function_env = TRUE, ignore_formula_env = TRUE