[R] additional and modified tests

This commit is contained in:
Vadim Khotilovich
2016-06-27 02:00:46 -05:00
parent 3b6b344561
commit fd4300b95a
5 changed files with 295 additions and 143 deletions

View File

@@ -14,18 +14,18 @@ df[,ID := NULL]
sparse_matrix <- sparse.model.matrix(Improved~.-1, data = df)
label <- df[, ifelse(Improved == "Marked", 1, 0)]
bst.Tree <- xgboost(data = sparse_matrix, label = label, max.depth = 9,
eta = 1, nthread = 2, nround = 10, objective = "binary:logistic", booster = "gbtree")
bst.Tree <- xgboost(data = sparse_matrix, label = label, max_depth = 9,
eta = 1, nthread = 2, nrounds = 10, objective = "binary:logistic", booster = "gbtree")
bst.GLM <- xgboost(data = sparse_matrix, label = label,
eta = 1, nthread = 2, nround = 10, objective = "binary:logistic", booster = "gblinear")
eta = 1, nthread = 2, nrounds = 10, objective = "binary:logistic", booster = "gblinear")
feature.names <- colnames(sparse_matrix)
test_that("xgb.dump works", {
expect_length(xgb.dump(bst.Tree), 172)
expect_length(xgb.dump(bst.GLM), 14)
expect_true(xgb.dump(bst.Tree, 'xgb.model.dump', with.stats = T))
expect_true(xgb.dump(bst.Tree, 'xgb.model.dump', with_stats = T))
expect_true(file.exists('xgb.model.dump'))
expect_gt(file.size('xgb.model.dump'), 8000)
})
@@ -35,12 +35,15 @@ test_that("xgb-attribute functionality", {
list.val <- list(my_attr=val, a=123, b='ok')
list.ch <- list.val[order(names(list.val))]
list.ch <- lapply(list.ch, as.character)
# note: iter is 0-index in xgb attributes
list.default <- list(niter = "9")
list.ch <- c(list.ch, list.default)
# proper input:
expect_error(xgb.attr(bst.Tree, NULL))
expect_error(xgb.attr(val, val))
# set & get:
expect_null(xgb.attr(bst.Tree, "asdf"))
expect_null(xgb.attributes(bst.Tree)) # initially, expect no attributes
expect_equal(xgb.attributes(bst.Tree), list.default)
xgb.attr(bst.Tree, "my_attr") <- val
expect_equal(xgb.attr(bst.Tree, "my_attr"), val)
xgb.attributes(bst.Tree) <- list.val
@@ -53,8 +56,10 @@ test_that("xgb-attribute functionality", {
# deletion:
xgb.attr(bst, "my_attr") <- NULL
expect_null(xgb.attr(bst, "my_attr"))
expect_equal(xgb.attributes(bst), list.ch[c("a", "b")])
expect_equal(xgb.attributes(bst), list.ch[c("a", "b", "niter")])
xgb.attributes(bst) <- list(a=NULL, b=NULL)
expect_equal(xgb.attributes(bst), list.default)
xgb.attributes(bst) <- list(niter=NULL)
expect_null(xgb.attributes(bst))
})
@@ -88,10 +93,27 @@ test_that("xgb.plot.tree works with and without feature names", {
})
test_that("xgb.plot.multi.trees works with and without feature names", {
xgb.plot.multi.trees(model = bst.Tree, feature_names = feature.names, features.keep = 3)
xgb.plot.multi.trees(model = bst.Tree, features.keep = 3)
xgb.plot.multi.trees(model = bst.Tree, feature_names = feature.names, features_keep = 3)
xgb.plot.multi.trees(model = bst.Tree, features_keep = 3)
})
test_that("xgb.plot.deepness works", {
xgb.plot.deepness(model = bst.Tree)
})
test_that("check.deprecation works", {
ttt <- function(a = NNULL, DUMMY=NULL, ...) {
check.deprecation(...)
as.list((environment()))
}
res <- ttt(a = 1, DUMMY = 2, z = 3)
expect_equal(res, list(a = 1, DUMMY = 2))
expect_warning(
res <- ttt(a = 1, dummy = 22, z = 3)
, "\'dummy\' is deprecated")
expect_equal(res, list(a = 1, DUMMY = 22))
expect_warning(
res <- ttt(a = 1, dumm = 22, z = 3)
, "\'dumm\' was partially matched to \'dummy\'")
expect_equal(res, list(a = 1, DUMMY = 22))
})