From ef15c8452633bf9a6451920f2d7b8f34918b4c5a Mon Sep 17 00:00:00 2001 From: Sky Qiu Date: Mon, 24 Oct 2022 13:32:38 -0700 Subject: [PATCH] modified tests for nonreproducible learners, added some unit tests --- tests/testthat/test-bartMachine.R | 61 +++++++++++++--------- tests/testthat/test-binomial_learners.R | 1 + tests/testthat/test-caret.R | 16 ++++-- tests/testthat/test-character_covariates.R | 24 +++++---- tests/testthat/test-solnp_density.R | 48 +++++++++++++++++ 5 files changed, 110 insertions(+), 40 deletions(-) create mode 100644 tests/testthat/test-solnp_density.R diff --git a/tests/testthat/test-bartMachine.R b/tests/testthat/test-bartMachine.R index f3b4b045..5604693a 100644 --- a/tests/testthat/test-bartMachine.R +++ b/tests/testthat/test-bartMachine.R @@ -1,38 +1,51 @@ context("test-bartMachine.R -- Lrnr_bartMachine") -test_that("Lrnr_bartMachine produces warning when java parameters are not set", { - expect_warning(Lrnr_bartMachine$new()) -}) - - -data(cpp_imputed) -covs <- c("apgar1", "apgar5", "parity", "gagebrth", "mage", "meducyrs", "sexn") -outcome <- "haz" -task <- sl3_Task$new(cpp_imputed, covariates = covs, outcome = outcome) +if (is.null(getOption("java.parameters"))) { + test_that("Lrnr_bartMachine warns when java parameters are not set", { + expect_warning(Lrnr_bartMachine$new()) + }) +} test_that("Lrnr_bartMachine produces results matching those of bartMachine::bartMachine", { + cpp_task <- sl3_Task$new( + data = cpp_imputed, + covariates = c("apgar1", "apgar5", "parity", "gagebrth", "mage", "meducyrs", "sexn"), + outcome = "haz" + ) + # sl3 fit + set.seed(123) lrnr_bartMachine <- suppressWarnings(Lrnr_bartMachine$new( seed = 196, verbose = FALSE )) - fit_sl3 <- lrnr_bartMachine$train(task) - preds_sl3 <- fit_sl3$predict(task) - + fit_sl3 <- lrnr_bartMachine$train(cpp_task) + preds_sl3 <- fit_sl3$predict() + mse_sl3 <- mean((cpp_task$Y - preds_sl3)^2) + # classic fit + X <- data.frame(cpp_task$X) + y <- cpp_task$Y fit_classic <- bartMachine::bartMachine( - X = data.frame(task$X), y = task$Y, seed = 196, verbose = FALSE + X = X, y = y, seed = 196, verbose = FALSE ) - preds_classic <- as.numeric(predict(fit_classic, new_data = task$X)) - + preds_classic <- as.numeric(predict(fit_classic, new_data = X)) + mse_classic <- mean((cpp_task$Y - preds_classic)^2) + # check equality - expect_equal(preds_sl3, preds_classic) + expect_equal(mse_sl3, mse_classic, tolerance = 0.01) }) -# test Lrnr_bartMachine does not fail when cross-validated -lrnr_bartMachine <- suppressWarnings(make_learner( - Lrnr_bartMachine, - verbose = FALSE -)) -cv_lrnr_bartMachine <- Lrnr_cv$new(lrnr_bartMachine) -fit_cv <- cv_lrnr_bartMachine$train(task) -preds_cv <- fit_cv$predict(task) +test_that("Lrnr_bartMachine can be cross-validated", { + cpp_task <- sl3_Task$new( + data = cpp_imputed, + covariates = c("apgar1", "apgar5", "parity", "gagebrth", "mage", "meducyrs", "sexn"), + outcome = "haz", + folds = 2 + ) + # test Lrnr_bartMachine does not fail when cross-validated + lrnr_bartMachine <- Lrnr_bartMachine$new(verbose = FALSE) + cv_lrnr_bartMachine <- Lrnr_cv$new(lrnr_bartMachine) + fit_cv <- cv_lrnr_bartMachine$train(cpp_task) + preds_cv <- fit_cv$predict() + expect_equal(length(preds_cv), nrow(cpp_imputed)) +}) diff --git a/tests/testthat/test-binomial_learners.R b/tests/testthat/test-binomial_learners.R index d91da24e..5d8ab0a0 100644 --- a/tests/testthat/test-binomial_learners.R +++ b/tests/testthat/test-binomial_learners.R @@ -68,4 +68,5 @@ test_that("Lrnr_sl binomial integration test", { coefs <- coef(sl_fit$fit_object$cv_meta_fit) preds <- sl_fit$predict() loss <- sl_fit$cv_risk(loss_loglik_binomial) + expect_equal(loss$coefficients, as.numeric(coefs)) }) diff --git a/tests/testthat/test-caret.R b/tests/testthat/test-caret.R index 1e40b87a..ef72768e 100644 --- a/tests/testthat/test-caret.R +++ b/tests/testthat/test-caret.R @@ -71,6 +71,7 @@ test_that("Lrnr_caret RF match caret RF preds for continuous outcome", { set.seed(1530) fit_lrnr_caret_rf <- lrnr_caret_rf$train(task) prd_lrnr_caret_rf <- fit_lrnr_caret_rf$predict() + mse_lrnr_caret <- mean((task$Y - prd_lrnr_caret_rf)^2) ## fit caret RF using the data from the task set.seed(1530) @@ -82,8 +83,9 @@ test_that("Lrnr_caret RF match caret RF preds for continuous outcome", { ) ) prd_caret_rf <- as.numeric(predict(fit_caret_rf, newdata = task$X)) + mse_caret <- mean((task$Y - prd_caret_rf)^2) - expect_equal(prd_lrnr_caret_rf, prd_caret_rf) + expect_equal(mse_lrnr_caret, mse_caret, tolerance = 0.1) }) test_that("Lrnr_caret RF match caret RF preds for binary classification", { @@ -92,6 +94,7 @@ test_that("Lrnr_caret RF match caret RF preds for binary classification", { set.seed(1530) fit_lrnr_caret_rf <- lrnr_caret_rf$train(task_binaryY) prd_lrnr_caret_rf <- fit_lrnr_caret_rf$predict() + mse_lrnr_caret_rf <- mean((prd_lrnr_caret_rf - task_binaryY$Y)^2) ## fit caret RF using the data from the task set.seed(1530) @@ -105,8 +108,9 @@ test_that("Lrnr_caret RF match caret RF preds for binary classification", { prd_caret_rf <- as.numeric( predict(fit_caret_rf, newdata = task$X, type = "prob")[, 2] ) + mse_caret_rf <- mean((prd_caret_rf - task_binaryY$Y)^2) - expect_equal(prd_lrnr_caret_rf, prd_caret_rf) + expect_equal(mse_caret_rf, mse_lrnr_caret_rf, tolerance = 0.01) }) test_that("Lrnr_caret RF preds match caret RF preds for categorical outcome", { @@ -115,6 +119,7 @@ test_that("Lrnr_caret RF preds match caret RF preds for categorical outcome", { set.seed(1530) fit_lrnr_caret_rf <- lrnr_caret_rf$train(task_catY) prd_lrnr_caret_rf <- fit_lrnr_caret_rf$predict() + prd_lrnr_caret_rf <- unlist(lapply(prd_lrnr_caret_rf, function(x) which.max(x[[1]]))) ## fit caret RF using the data from the task set.seed(1530) @@ -128,7 +133,8 @@ test_that("Lrnr_caret RF preds match caret RF preds for categorical outcome", { prd_caret_rf <- pack_predictions( predict(fit_caret_rf, newdata = task$X, type = "prob") ) - + prd_caret_rf <- unlist(lapply(prd_caret_rf, function(x) which.max(x[[1]]))) + expect_equal(prd_lrnr_caret_rf, prd_caret_rf) }) @@ -140,7 +146,7 @@ test_that("Lrnr_caret RF preds match caret RF preds for binary regression", { ) set.seed(1530) fit_lrnr_caret_rf <- lrnr_caret_rf$train(task_binaryY) - prd_lrnr_caret_rf <- fit_lrnr_caret_rf$predict() + prd_lrnr_caret_rf <- as.numeric(fit_lrnr_caret_rf$predict() > 0.5) ## fit caret RF using the data from the task set.seed(1530) @@ -151,7 +157,7 @@ test_that("Lrnr_caret RF preds match caret RF preds for binary regression", { indexOut = fit_lrnr_caret_rf$fit_object$control$indexOut ) )) - prd_caret_rf <- as.numeric(predict(fit_caret_rf, newdata = task$X)) + prd_caret_rf <- as.numeric(predict(fit_caret_rf, newdata = task$X) > 0.5) expect_equal(prd_lrnr_caret_rf, prd_caret_rf) }) diff --git a/tests/testthat/test-character_covariates.R b/tests/testthat/test-character_covariates.R index 0d2ac23b..cc33573d 100644 --- a/tests/testthat/test-character_covariates.R +++ b/tests/testthat/test-character_covariates.R @@ -11,14 +11,16 @@ if (FALSE) { install("sl3", build_vignettes = FALSE, dependencies = FALSE) # INSTALL W/ devtools: } -data(cpp_imputed) -covars <- c("apgar1", "apgar5", "parity", "gagebrth", "mage", "meducyrs", "sexn") -outcome <- "haz" -cpp_imputed$sexn <- as.character(cpp_imputed$sexn) - -expect_warning( - task_character_to_factor <- make_sl3_Task(cpp_imputed, covars, outcome), - "Character variables found: sexn;\nConverting these to factors" -) - -expect_equal(class(task_character_to_factor$get_node("covariates")$sexn), "factor") +test_that("character covariates automatically cast to factors", { + data(cpp_imputed) + covars <- c("apgar1", "apgar5", "parity", "gagebrth", "mage", "meducyrs", "sexn") + outcome <- "haz" + cpp_imputed$sexn <- as.character(cpp_imputed$sexn) + + expect_warning( + task_character_to_factor <- make_sl3_Task(cpp_imputed, covars, outcome), + "Character variables found: sexn;\nConverting these to factors" + ) + + expect_equal(class(task_character_to_factor$get_node("covariates")$sexn), "factor") +}) diff --git a/tests/testthat/test-solnp_density.R b/tests/testthat/test-solnp_density.R new file mode 100644 index 00000000..4a4ab7e0 --- /dev/null +++ b/tests/testthat/test-solnp_density.R @@ -0,0 +1,48 @@ +context("solnp_density.R -- Lrnr_solnp_density") + +library(Rsolnp) + +data(cpp_imputed) +setDT(cpp_imputed) + +covs <- c("apgar1", "apgar5", "parity", "gagebrth", "mage", "meducyrs", "sexn") + +test_that("Lrnr_solnp_density as a meta-learner coefficients to sum to 1", { + set.seed(1234) + task <- sl3_Task$new(cpp_imputed, covariates = covs, outcome = "haz") + + hse_lrnr <- Lrnr_density_hse$new() + semi_lrnr <- Lrnr_density_semiparametric$new() + stack <- Stack$new(hse_lrnr, semi_lrnr) + sl <- Lrnr_sl$new(learners = stack, metalearner = Lrnr_solnp_density$new()) + + sl_fit <- sl$train(task) + expect_equal(sum(coef(sl_fit)), 1) +}) + +test_that("Lrnr_solnp_density coefficients match Rsolnp coefficients", { + task <- sl3_Task$new(cpp_imputed, covariates = covs, outcome = "haz") + set.seed(123) + + # sl3 + solnp_lrnr <- Lrnr_solnp_density$new() + fit <- solnp_lrnr$train(task) + + # Rsolnp + loss_func <- function(alphas) { + sum(-log(as.vector(as.matrix(task$X) %*% alphas))) + } + eq_fun <- function(alphas) { + sum(alphas) + } + + set.seed(123) + solnp_fit <- Rsolnp::solnp( + stats::runif(ncol(task$X)), loss_func, + eqfun = eq_fun, eqB = 1, + LB = rep(0L, ncol(task$X)) + ) + + expect_equal(as.numeric(coef(fit)), solnp_fit$pars) + expect_equal(sum(coef(fit)), 1) +})