Nothing
context("Modeling framework")
test_that("modeling procedure", {
proc1 <- modeling_procedure("randomForest")
expect_identical(proc1, as.modeling_procedure("randomForest"))
proc2 <- modeling_procedure(fit_fun=identity, error_fun=rmse)
expect_that(names(proc1), is_identical_to(names(proc2)))
expect_that(proc1$fit_fun, is_a("function"))
expect_that(proc1$predict_fun, is_a("function"))
expect_that(proc1$importance_fun, is_a("function"))
expect_null(proc1$error_fun)
expect_that(proc2$fit_fun, is_a("function"))
expect_that(proc2$predict_fun, is_a("simpleError"))
expect_that(proc2$importance_fun, is_a("simpleError"))
expect_that(proc2$error_fun, is_a("function"))
})
x <- iris[-5]
y <- iris$Species
cv <- resample("crossvalidation", y, nfold=3, nrepeat=2)
procedure <- modeling_procedure("lda")
modeling_fun <- function(proc=procedure, ..., xx=x, .verbose=FALSE)
evaluate(proc, xx, y, resample=cv, ..., .verbose=.verbose)
test_that("Standard usage", {
result <- modeling_fun(.save=c(model=TRUE, prediction=TRUE, importance=FALSE))
expect_that(result, is_a("modeling_result"))
expect_that(length(result), is_equivalent_to(length(cv)))
expect_that(names(result), is_equivalent_to(names(cv)))
expect_that(subtree(result, TRUE, "error"), is_a("numeric"))
expect_true(all(sapply(result, function(p) all(c("model", "prediction") %in% names(p)))))
expect_false(is_multi_procedure(result))
double_procedure <- list(LDA = modeling_procedure("lda"),
QDA = modeling_procedure("qda"))
result <- modeling_fun(proc = double_procedure)
expect_true(is_multi_procedure(result))
expect_true(all(sapply(result, function(r) identical(names(r), names(double_procedure)))))
})
test_that("Checkpointing", {
if(file.access(".", 2) == 0){
tmp.dir <- tempdir()
result <- modeling_fun()
check.perf <- modeling_fun(.checkpoint_dir=tmp.dir)
expect_that(check.perf, is_identical_to(result))
expect_true(file.exists(tmp.dir))
file.remove(dir(tmp.dir, pattern = "rep.fold.\\.Rdata", full.names = TRUE))
}
})
test_that("Error handling", {
x[1] <- NA
expect_error(modeling_fun(xx=x, .return_error=FALSE))
result <- modeling_fun(xx=x, .return_error=TRUE, .verbose=-1) # Test verbosity too
expect_true(all(sapply(result, inherits, "error")))
})
test_that("Parallelization", {
requireNamespace("parallel")
if(parallel::detectCores() > 1 && .Platform$OS.type != "windows"){
procedure <- modeling_procedure("lda", error_fun = function(...){
Sys.sleep(0.5)
list(pid=Sys.getpid(), time=Sys.time())
})
modeling_fun <- function(..., resample=cv[1:4])
evaluate(procedure, x, y, resample=resample, ...)
seq.time <- system.time( seq.perf <- modeling_fun() )
if(.Platform$OS.type == "windows"){
cl <- makePSOCKcluster(2)
clusterExport(cl, c("procedure", "x", "y", "modeling_fun", "listify",
"get_debug_flags", "set_debug_flags", "is_blank", "is_tuned",
"is_tunable", "error_rate", "log_message", "indent",
"pre_split", "index_fit", "index_test", "na_fill", "fill",
"nice_require"))
par.time <- system.time(
par.perf <- parLapply(cl, cv[1:4], function(fold) modeling_fun(resample=fold))
)
stopCluster(cl)
} else {
par.time <- system.time( par.perf <- modeling_fun(.cores=2) )
}
expect_gt(seq.time["elapsed"], par.time["elapsed"])
expect_equal(length(unique(subtree(seq.perf, TRUE, "error", "pid"))), 1L)
expect_equal(length(unique(subtree(par.perf, TRUE, "error", "pid"))), 2L)
expect_gt(
diff(range(subtree(seq.perf, T, "error", "time"))),
diff(range(subtree(par.perf, T, "error", "time")))
)
}
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.