modified tests for nonreproducible learners, added some unit tests

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))
+})

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))
 })

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)
 })

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")
+})

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)
+})