diff --git a/R-package/R/xgb.DMatrix.R b/R-package/R/xgb.DMatrix.R index 9c7ba2684845..9d1d53c12197 100644 --- a/R-package/R/xgb.DMatrix.R +++ b/R-package/R/xgb.DMatrix.R @@ -257,8 +257,6 @@ setinfo.xgb.DMatrix <- function(object, name, info, ...) { return(TRUE) } if (name == "weight") { - if (length(info) != nrow(object)) - stop("The length of weights must equal to the number of rows in the input data") .Call(XGDMatrixSetInfo_R, object, name, as.numeric(info)) return(TRUE) } diff --git a/R-package/tests/testthat/test_ranking.R b/R-package/tests/testthat/test_ranking.R new file mode 100644 index 000000000000..7a352bea2ec0 --- /dev/null +++ b/R-package/tests/testthat/test_ranking.R @@ -0,0 +1,51 @@ +require(xgboost) +require(Matrix) + +context('Learning to rank') + +test_that('Test ranking with unweighted data', { + X <- sparseMatrix(i = c(2, 3, 7, 9, 12, 15, 17, 18), + j = c(1, 1, 2, 2, 3, 3, 4, 4), + x = rep(1.0, 8), dims = c(20, 4)) + y <- c(0, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0) + group <- c(5, 5, 5, 5) + dtrain <- xgb.DMatrix(X, label = y, group = group) + + params <- list(eta = 1, tree_method = 'exact', objective = 'rank:pairwise', max_depth = 1, + eval_metric = 'auc', eval_metric = 'aucpr') + bst <- xgb.train(params, dtrain, nrounds = 10, watchlist = list(train = dtrain)) + # Check if the metric is monotone increasing + expect_true(all(diff(bst$evaluation_log$train_auc) >= 0)) + expect_true(all(diff(bst$evaluation_log$train_aucpr) >= 0)) +}) + +test_that('Test ranking with weighted data', { + X <- sparseMatrix(i = c(2, 3, 7, 9, 12, 15, 17, 18), + j = c(1, 1, 2, 2, 3, 3, 4, 4), + x = rep(1.0, 8), dims = c(20, 4)) + y <- c(0, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0) + group <- c(5, 5, 5, 5) + weight <- c(1.0, 2.0, 3.0, 4.0) + dtrain <- xgb.DMatrix(X, label = y, group = group, weight = weight) + + params <- list(eta = 1, tree_method = 'exact', objective = 'rank:pairwise', max_depth = 1, + eval_metric = 'auc', eval_metric = 'aucpr') + bst <- xgb.train(params, dtrain, nrounds = 10, watchlist = list(train = dtrain)) + # Check if the metric is monotone increasing + expect_true(all(diff(bst$evaluation_log$train_auc) >= 0)) + expect_true(all(diff(bst$evaluation_log$train_aucpr) >= 0)) + for (i in 1:10) { + pred <- predict(bst, newdata = dtrain, ntreelimit = i) + # is_sorted[i]: is i-th group correctly sorted by the ranking predictor? + is_sorted <- lapply(seq(1, 20, by = 5), + function (k) { + ind <- order(-pred[k:(k + 4)]) + z <- y[ind + (k - 1)] + all(diff(z) <= 0) # Check if z is monotone decreasing + }) + # Since we give weights 1, 2, 3, 4 to the four query groups, + # the ranking predictor will first try to correctly sort the last query group + # before correctly sorting other groups. + expect_true(all(diff(as.numeric(is_sorted)) >= 0)) + } +})