Merge pull request #475 from terrytangyuan/master

More thorough unit testing for R package

CONTRIBUTORS.md

@@ -34,6 +34,7 @@ List of Contributors
 * [Zygmunt Zając](https://github.com/zygmuntz)
   - Zygmunt is the master behind the early stopping feature frequently used by kagglers.
 * [Ajinkya Kale](https://github.com/ajkl)
+* [Yuan Tang](https://github.com/terrytangyuan)
 * [Boliang Chen](https://github.com/cblsjtu)
 * [Vadim Khotilovich](https://github.com/khotilov)
 * [Yangqing Men](https://github.com/yanqingmen)

R-package/tests/testthat/test_custom_objective.R

@@ -0,0 +1,47 @@
+context('Test models with custom objective')
+
+require(xgboost)
+
+test_that("custom objective works", {
+  data(agaricus.train, package='xgboost')
+  data(agaricus.test, package='xgboost')
+  dtrain <- xgb.DMatrix(agaricus.train$data, label = agaricus.train$label)
+  dtest <- xgb.DMatrix(agaricus.test$data, label = agaricus.test$label)
+  
+  watchlist <- list(eval = dtest, train = dtrain)
+  num_round <- 2
+  
+  logregobj <- function(preds, dtrain) {
+    labels <- getinfo(dtrain, "label")
+    preds <- 1/(1 + exp(-preds))
+    grad <- preds - labels
+    hess <- preds * (1 - preds)
+    return(list(grad = grad, hess = hess))
+  }
+  evalerror <- function(preds, dtrain) {
+    labels <- getinfo(dtrain, "label")
+    err <- as.numeric(sum(labels != (preds > 0)))/length(labels)
+    return(list(metric = "error", value = err))
+  }
+  
+  param <- list(max.depth=2, eta=1, nthread = 2, silent=1, 
+                objective=logregobj, eval_metric=evalerror)
+  
+  bst <- xgb.train(param, dtrain, num_round, watchlist)
+  expect_equal(class(bst), "xgb.Booster")
+  expect_equal(length(bst$raw), 1064)
+  attr(dtrain, 'label') <- getinfo(dtrain, 'label')
+  
+  logregobjattr <- function(preds, dtrain) {
+    labels <- attr(dtrain, 'label')
+    preds <- 1/(1 + exp(-preds))
+    grad <- preds - labels
+    hess <- preds * (1 - preds)
+    return(list(grad = grad, hess = hess))
+  }
+  param <- list(max.depth=2, eta=1, nthread = 2, silent=1, 
+                objective=logregobjattr, eval_metric=evalerror)
+  bst <- xgb.train(param, dtrain, num_round, watchlist)
+  expect_equal(class(bst), "xgb.Booster")
+  expect_equal(length(bst$raw), 1064)
+})

R-package/tests/testthat/test_helpers.R

@@ -0,0 +1,32 @@
+context('Test helper functions')
+
+require(xgboost)
+require(data.table)
+require(Matrix)
+require(vcd)
+
+data(Arthritis)
+data(agaricus.train, package='xgboost')
+df <- data.table(Arthritis, keep.rownames = F)
+df[,AgeDiscret:= as.factor(round(Age/10,0))]
+df[,AgeCat:= as.factor(ifelse(Age > 30, "Old", "Young"))]
+df[,ID:=NULL]
+sparse_matrix = sparse.model.matrix(Improved~.-1, data = df)
+output_vector = df[,Y:=0][Improved == "Marked",Y:=1][,Y]
+bst <- xgboost(data = sparse_matrix, label = output_vector, max.depth = 9,
+               eta = 1, nthread = 2, nround = 10,objective = "binary:logistic")
+
+
+test_that("xgb.dump works", {
+  capture.output(print(xgb.dump(bst)))
+})
+
+test_that("xgb.importance works", {
+  xgb.dump(bst, 'xgb.model.dump', with.stats = T)
+  importance <- xgb.importance(sparse_matrix@Dimnames[[2]], 'xgb.model.dump')
+  expect_equal(dim(importance), c(7, 4))
+})
+
+test_that("xgb.plot.tree works", {
+  xgb.plot.tree(agaricus.train$data@Dimnames[[2]], model = bst)
+})

R-package/tests/testthat/test_poisson_regression.R

@@ -0,0 +1,13 @@
+context('Test poisson regression model')
+
+require(xgboost)
+
+test_that("poisson regression works", {
+  data(mtcars)
+  bst = xgboost(data=as.matrix(mtcars[,-11]),label=mtcars[,11],
+                objective='count:poisson',nrounds=5)
+  expect_equal(class(bst), "xgb.Booster")
+  pred = predict(bst,as.matrix(mtcars[,-11]))
+  expect_equal(length(pred), 32)
+  sqrt(mean((pred-mtcars[,11])^2))
+})